16-10-22, 05:56 AM
كود :
Option Explicit Event Click() Private Declare Function ExtFloodFill& Lib "gdi32" (ByVal HDc&, ByVal x&, ByVal y&, Optional ByVal CrColor& = vbWhite, Optional ByVal FillType& = 1) Private Declare Function TextOutW& Lib "gdi32" (ByVal HDc&, ByVal x&, ByVal y&, ByVal lpString&, ByVal nCount&) Private Declare Function GetTextExtentPoint32W Lib "gdi32" (ByVal HDc&, ByVal lpUniCode&, ByVal CharCount&, lpSize As Any) As Long Public Enum UniBoxSymbols 'a definition of the "Box"-Unicode-Points as "speaking Enum-Values" symNone = 32 'the Space-Char-Value (to render nothing per default) symHorz = &H2500 symDownAndRight = &H250C symDownAndLeft = &H2510 symUpAndRight = &H2514 symUpAndLeft = &H2518 End Enum 'the Public Properties of a given Tooth (each Section as "center, left, top etc." can be filled with a differing Color) Public Nr&, BorderColor&, CrCenter&, CrLeft&, CrTop&, CrRight&, CrBottom& Public BraceSymbol As UniBoxSymbols, CenterSymbol As String Private Sub UserControl_Initialize() ScaleMode = vbPixels: AutoRedraw = True: DrawWidth = 2: FillStyle = 0 FontName = "Arial": FontSize = 10: FontBold = True ResetAllFillColorsToWhite 'initialize all "Section-Colors" to white End Sub Private Sub UserControl_Resize() Refresh End Sub Private Sub UserControl_Click() RaiseEvent Click End Sub Public Sub ResetAllFillColorsToWhite() 'a Public Method which resets all FillColors to their default (white) CrCenter = vbWhite: CrLeft = vbWhite: CrTop = vbWhite: CrRight = vbWhite: CrBottom = vbWhite End Sub Public Sub Refresh() 'and a Public Refresh-Method, to reflect the "current state" of a given Tooth in the Controls Render-Output Cls Dim Size As Long: Size = ScaleWidth Dim Offs As Long: Offs = Size \ 4 + 1 FillColor = vbWhite: ForeColor = BorderColor Line (1, 1)-(Size - 1, Size - 1), , B 'Background with Border Line (1, 1)-(Size - 1, Size - 1): Line (1, Size - 1)-(Size - 1, 1) 'Diagonals FillColor = CrCenter: Line (Offs, Offs)-(Size - Offs, Size - Offs), , B 'CenterSquare FillColor = CrLeft: ExtFloodFill HDc, Offs \ 2, Size \ 2 FillColor = CrTop: ExtFloodFill HDc, Size \ 2, Offs \ 2 FillColor = CrRight: ExtFloodFill HDc, Size - Offs \ 2, Size \ 2 FillColor = CrBottom: ExtFloodFill HDc, Size \ 2, Size - Offs \ 2 TextOutCentered Nr, 10, vbBlack, Size \ 2 + 10 'print the Tooth-Nr-Caption at the bottom TextOutCentered ChrW(BraceSymbol), 20 * Size / 31, vbBlue 'print the BraceSymbolChar (a ChrW translation of the Enums UnicodePoint) TextOutCentered CenterSymbol, 20 * Size / 31, vbMagenta 'print the CenterSymbolChar UserControl.Refresh End Sub Private Sub TextOutCentered(ByVal S$, FontSize, FontColor, Optional ByVal yOffs&) ForeColor = FontColor: Font.Size = FontSize If S = ChrW(symHorz) Then S = String(2, S) 'double the Horz-Char (to cover the entire width) Dim x As Long, y As Long, TW As Long, TH As Long CalcTextExtent S, TW, TH 'we also need to use a matching unicode-capable TextExtent-measuring x = (ScaleWidth - TW) \ 2 y = yOffs + (ScaleWidth - TH) \ 2 TextOutW HDc, x, y, StrPtr(S), Len(S) 'use TextOutW instead of Print, to be Unicode-Aware End Sub Private Sub CalcTextExtent(S$, dx, dy) Dim Ext&(1): GetTextExtentPoint32W HDc, StrPtr(S), Len(S), Ext(0) dx = Ext(0): dy = Ext(1)
End Subكود :
Option Explicit Private SelTooth As ucTooth, T As ucTooth, i As Long Private Sub Form_Load() ScaleMode = vbPixels For i = 11 To 85 Select Case i Case 11 To 18, 21 To 28, 31 To 38, 41 To 48, 51 To 55, 61 To 65, 71 To 75, 81 To 85 If i > 11 Then Load ucT(i) 'instantiate the yet missing tooth-control ucT(i).Nr = i: ucT(i).Visible = True End Select Next ucT(11).CrCenter = vbGreen: ucT(12).CrCenter = vbRed ucT(21).CrCenter = vbGreen: ucT(22).CrCenter = vbRed ucT(31).CenterSymbol = "#" ucT(41).CenterSymbol = "$" ucT(51).BraceSymbol = symDownAndLeft For i = 52 To 54: ucT(i).BraceSymbol = symHorz: Next ucT(55).BraceSymbol = symDownAndRight ucT(61).BraceSymbol = symUpAndRight For i = 62 To 64: ucT(i).BraceSymbol = symHorz: Next ucT(65).BraceSymbol = symUpAndLeft SetBraceColorEdges 85, 81, vbCyan, False 'we use a little Helper-Function to "format a range" SetBraceColorEdges 71, 75, vbCyan, True 'we use a little Helper-Function to "format a range" RefreshAllTeeth 'refresh the state of all teeth we have changed the State-Variables for (above) End Sub Private Sub SetBraceColorEdges(idxFrom, idxTo, Color, ByVal Top As Boolean) ucT(idxFrom).CrLeft = Color For i = idxFrom To idxTo Step IIf(idxFrom < idxTo, 1, -1) If Top Then ucT(i).CrTop = Color Else ucT(i).CrBottom = Color Next ucT(idxTo).CrRight = Color End Sub Public Sub RefreshAllTeeth() For Each T In ucT: T.Refresh: Next End Sub Private Sub Form_Resize() Const TopOffs = 40 For Each T In ucT Dim dx: dx = ScaleWidth \ 19 'calculate the width of a single tooth Dim dy: dy = dx + 20 'set the height of the tooth (it's higher because of the Caption) Dim cx: cx = (ScaleWidth - dx) \ 2 'calc the horizontal center-offset on our Form Dim sc: sc = Choose(T.Nr \ 10, -1, 1, 1, -1, -1, 1, 1, -1) 'scale-factor in x-direction Dim x0: x0 = cx + sc * (8 + dx \ 2 + ((T.Nr Mod 10) - 1) * (dx + 4)) 'x-Offset Dim y0: y0 = TopOffs + Choose((T.Nr + 10) \ 20, 0, 3, 1, 2) * (dy + 12) 'y-Offset ucT(T.Nr).Move x0, y0, dx, dy Next RefreshAllTeeth End Sub Private Sub ucT_Click(Index As Integer) If Not SelTooth Is Nothing Then SelTooth.BorderColor = vbBlack 'reset the BorderColor of the last selected Tooth Set SelTooth = ucT(Index) SelTooth.BorderColor = vbBlue 'mark the currently selected Tooth with a blue Border RefreshAllTeeth Caption = "Currently selected Tooth: " & SelTooth.Nr
End Sub