mon_advanced_checkbox.ctl

一款另类的彩色图形复选框控件源代码(CheckBox2009) (v3)

                    pic_des_big_check_avec_caption.Left = 0
                Else
                    pic_des_big_check.Top = 0
                    pic_des_big_check.Left = 0
                End If
            Else
                If m_Caption <> "" Then
                    pic_des_big_uncheck_avec_caption.Top = 0
                    pic_des_big_uncheck_avec_caption.Left = 0
                Else
                    pic_des_big_uncheck.Top = 0
                    pic_des_big_uncheck.Left = 0
                End If
            End If
        End If
    End If
    '-----------------------------------------
    
    If Small Then
        UserControl_Resize
        UserControl.Cls
        If m_Caption <> "" Then
            'Center stretch
            StretchBlt UserControl.hdc, 0, 0, ScaleWidth, ScaleHeight, picsmall.hdc, 5, 0, 1, ScaleHeight, vbSrcCopy
            'Left
            'StretchBlt UserControl.hdc, 0, 0, 10, ScaleHeight, picsmall.hdc, 0, 0, 10, ScaleHeight, vbSrcCopy
            BitBlt UserControl.hdc, 0, 0, 6, ScaleHeight, picsmall.hdc, 0, 0, vbSrcCopy
            'Right
            BitBlt UserControl.hdc, ScaleWidth - 10, 0, 9, ScaleHeight, picsmall.hdc, picsmall.Width - 9, 0, vbSrcCopy
            'end of checkbox
            If bolEnabled Then BitBlt UserControl.hdc, picsmall.Width - 1, 0, picarcsmall.Width, ScaleHeight, picarcsmall.hdc, 0, 0, vbSrcCopy
            'draw caption
            rc.Left = picsmall.Width + 6: rc.Top = (picsmall.Height - (picsmall.TextHeight("-") / Screen.TwipsPerPixelY)) / 2 '8
            rc.Right = UserControl.ScaleWidth: rc.Bottom = UserControl.ScaleHeight
            If bolEnabled Then
                UserControl.ForeColor = m_CaptionColor 'm_Activecolor
            Else
                UserControl.ForeColor = vbGrayText
            End If
            DrawText UserControl.hdc, m_Caption, LenB(StrConv(m_Caption, vbFromUnicode)), rc, 0 ', DT_CENTER
        Else
            UserControl.Picture = picsmall.Picture
        End If
        
        UserControl.Refresh
        
        If Checked Then
            mon_gradient m_Activecolor, 7, (UserControl.ScaleHeight / 2) - 1, 3
        Else
            mon_gradient m_desActivecolor, picsmall.Width - 8, (UserControl.ScaleHeight / 2) - 1, 3 '6
        End If
    Else
        UserControl_Resize
        UserControl.Cls
        If m_Caption <> "" Then
            'center stretch
            StretchBlt UserControl.hdc, 0, 0, ScaleWidth, ScaleHeight, picbig.hdc, 20, 0, 2, ScaleHeight, vbSrcCopy
            'Left
            BitBlt UserControl.hdc, 0, 0, 15, ScaleHeight, picbig.hdc, 0, 0, vbSrcCopy
            'Right
            BitBlt UserControl.hdc, ScaleWidth - 16, 0, 15, ScaleHeight, picbig.hdc, picbig.Width - 15, 0, vbSrcCopy
            'End of checkbox
            If bolEnabled Then BitBlt UserControl.hdc, picbig.Width - 3, 0, picarc.Width, ScaleHeight, picarc.hdc, 0, 0, vbSrcCopy
            'draw caption
            rc.Left = picbig.Width + 8: rc.Top = (picbig.Height - (picbig.TextHeight("-") / Screen.TwipsPerPixelY)) / 2 '8 'picbig.Height / 2
            rc.Right = UserControl.ScaleWidth: rc.Bottom = UserControl.ScaleHeight
            If bolEnabled Then
                UserControl.ForeColor = m_CaptionColor 'm_Activecolor
            Else
                UserControl.ForeColor = vbGrayText 'vbButtonShadow
            End If
            DrawText UserControl.hdc, m_Caption, LenB(StrConv(m_Caption, vbFromUnicode)), rc, 0 ', DT_CENTER
        Else
            UserControl.Picture = picbig.Picture
        End If
        
        UserControl.Refresh
        
        If Checked Then
            mon_gradient m_Activecolor, 15, (UserControl.ScaleHeight / 2) - 1, 8
        Else
            mon_gradient m_desActivecolor, picbig.Width - 16, (picbig.Height / 2) - 1, 8 '9
        End If
    
    End If
    
End Sub

Public Property Get Activecolor() As OLE_COLOR
   Activecolor = m_Activecolor
End Property
Public Property Get CaptionColor() As OLE_COLOR
   CaptionColor = m_CaptionColor
End Property
Public Property Get desActivecolor() As OLE_COLOR
   desActivecolor = m_desActivecolor
End Property
Public Property Let Activecolor(ByVal New_Activecolor As OLE_COLOR)
   m_Activecolor = New_Activecolor
   PropertyChanged "Activecolor"
   PaintControl
End Property
Public Property Let CaptionColor(ByVal New_CaptionColor As OLE_COLOR)
   m_CaptionColor = New_CaptionColor
   PropertyChanged "CaptionColor"
   PaintControl
End Property
Public Property Get Font() As Font
Set Font = fntFont
End Property
Public Property Set Font(ByVal NewValue As Font)
Set fntFont = NewValue
Set UserControl.Font = NewValue

Set picbig.Font = UserControl.Font
Set picsmall.Font = UserControl.Font


PropertyChanged "Font"
PaintControl
End Property
Public Property Let desActivecolor(ByVal New_desActivecolor As OLE_COLOR)
   m_desActivecolor = New_desActivecolor
   PropertyChanged "desActivecolor"
   PaintControl
End Property
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Button Enabled/Disable."
Enabled = bolEnabled
End Property


Public Property Get Small() As Boolean
Small = bolSmall
End Property
Public Property Get Checked() As Boolean
Checked = bolChecked
End Property

Public Property Let Enabled(ByVal NewValue As Boolean)
bolEnabled = NewValue
PropertyChanged "Enabled"

UserControl.Enabled = bolEnabled

PaintControl
End Property


Public Property Let Small(ByVal NewValue As Boolean)
bolSmall = NewValue
PropertyChanged "Small"

PaintControl


If Small = True Then
    RoundedValue = 9 '10
Else
    RoundedValue = 26
End If


End Property
Public Property Let Checked(ByVal NewValue As Boolean)
bolChecked = NewValue
PropertyChanged "Checked"

PaintControl


End Property
Public Property Get RoundedValue() As Long
Attribute RoundedValue.VB_Description = "Button Border Rounded Value."
RoundedValue = lonRoundValue
End Property

Public Property Let RoundedValue(ByVal NewValue As Long)


lonRoundValue = NewValue
PropertyChanged "RoundedValue"


UserControl_Resize

End Property

Private Sub UserControl_Click()
If bolEnabled = True Then
    If button_clique = 1 Then
        
        Checked = Not Checked
        'PaintControl
        
        RaiseEvent Click
        RaiseEvent MouseLeaves(0, 0)
    End If
End If
End Sub

Private Sub UserControl_Initialize()
m_Activecolor = &H8000&
m_desActivecolor = &H808080
m_Caption = ""
m_CaptionColor = vbBlack
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If bolEnabled = True Then
    button_clique = Button
    If Button = 1 Then
        bolMouseDown = True
        RaiseEvent MouseDown(Button, Shift, X, Y)
'        PaintControl
    End If
End If

End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If bolEnabled = False Then Exit Sub
    RaiseEvent MouseMove(Button, Shift, X, Y)
    SetCapture hWnd
    If PointInControl(X, Y) Then
        'pointer on control
        If Not bolMouseOver Then
            bolMouseOver = True
            RaiseEvent MouseEnters(udtPoint.X, udtPoint.Y)
        End If
    Else
        'pointer out of control
        bolMouseOver = False
        bolMouseDown = False
        ReleaseCapture
        RaiseEvent MouseLeaves(udtPoint.X, udtPoint.Y)
    End If
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If bolEnabled = True Then
    button_clique = Button
    If Button = 1 Then
        RaiseEvent MouseUp(Button, Shift, X, Y)
        bolMouseDown = False
    End If
End If
End Sub

Private Sub UserControl_Paint()
'PaintControl
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
'On Error Resume Next
With PropBag
    
    Let Enabled = .ReadProperty("Enabled", True)
    Let Checked = .ReadProperty("Checked", False)
    Let Small = .ReadProperty("Small", True)
    Let RoundedValue = .ReadProperty("RoundedValue", 5)
    Let Activecolor = .ReadProperty("Activecolor", m_Activecolor) ' &H117B28) 'vbGreen)
    Let desActivecolor = .ReadProperty("desActivecolor", m_desActivecolor) ' &H117B28) 'vbGreen)
    
    Let Caption = .ReadProperty("Caption", "")
    Set Font = .ReadProperty("Font", Ambient.Font)
    Let CaptionColor = .ReadProperty("CaptionColor", m_CaptionColor)
End With
End Sub
Private Sub UserControl_Resize()
    
    If Small Then
        'UserControl.Width = (picsmall.Width + 1) * Screen.TwipsPerPixelX
        If m_Caption <> "" Then
            UserControl.Width = ((picsmall.Width + 1) * Screen.TwipsPerPixelX) + (picsmall.TextWidth(m_Caption) + 300)
        Else
            UserControl.Width = (picsmall.Width + 1) * Screen.TwipsPerPixelX '* 2
        End If
        UserControl.Height = (picsmall.Height + 1) * Screen.TwipsPerPixelY
    Else
        If m_Caption <> "" Then
            UserControl.Width = ((picbig.Width + 1) * Screen.TwipsPerPixelX) + (picbig.TextWidth(m_Caption) + 300)
        Else
            UserControl.Width = (picbig.Width + 1) * Screen.TwipsPerPixelX '* 2
        End If
        UserControl.Height = (picbig.Height + 1) * Screen.TwipsPerPixelY
    End If
    

lonRect = CreateRoundRectRgn(0, 0, ScaleWidth, ScaleHeight, lonRoundValue, lonRoundValue)     '- 1
SetWindowRgn UserControl.hWnd, lonRect, True



End Sub

Private Sub UserControl_Terminate()
bolMouseDown = False
bolMouseOver = False
'bolHasFocus = False
'UserControl.Cls
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
'On Error Resume Next
With PropBag
    .WriteProperty "Enabled", bolEnabled, True
    .WriteProperty "Checked", bolChecked, False
    .WriteProperty "Small", bolSmall, True
    .WriteProperty "RoundedValue", lonRoundValue, 5
    .WriteProperty "Activecolor", m_Activecolor, &H8000& '&H117B28 'vbGreen
    .WriteProperty "desActivecolor", m_desActivecolor, &H808080 '&H94A392
    
    .WriteProperty "Caption", m_Caption, ""
    .WriteProperty "Font", fntFont, Ambient.Font
    .WriteProperty "CaptionColor", m_CaptionColor, vbBlack
End With
End Sub
Private Sub UserControl_InitProperties()
Let Enabled = True
Let Checked = False
Let Small = False 'True
Let RoundedValue = 27 '26 '5

m_Activecolor = &H8000&
m_desActivecolor = &H808080
m_CaptionColor = vbBlack
Set Font = UserControl.Font '"tahoma" 'Ambient.Font

End Sub

Public Property Get Caption() As String
Caption = m_Caption
End Property

Public Property Let Caption(ByVal New_Caption As String)
   m_Caption = New_Caption
   PropertyChanged "Caption"
   PaintControl
End Property