Make with VB2HTML

'================================================================================== 
'   Permet de faire des boutons sans focus se qui évite le désagrable contour
'   mais aussi des boutons qui restent enfonces
'   (permet de remplacer les onglets par exemple)
'
'   si vous trouvez un BUG ou que vous enrichisser cet OCX
'   merci de me faire parvenir vos améliorations et/ou commentaires
'
'   adresse en cours    : fred.just@free.fr
'   site actuel         : http://fred.just.free.fr/
'   adresse de secours  : fredjust@hotmail.com
'
'==================================================================================


Option Explicit
'Déclarations d'événements:
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Event Click()


Public Enum EnumPosition
    Down
    up
End Enum

Public Enum EnumStyle
    Normal
    Switch
End Enum

'Valeurs de propriétés par défaut:

Const m_def_ColorDownRightOne = vb3DDKShadow
Const m_def_ColorDownRightTwo = vb3DShadow
Const m_def_ColorTopLeftTwo = vb3DLight
Const m_def_ColorTopLeftOne = vb3DHighlight

Const m_def_Style = Normal
Const m_def_CaptionAuto = True
Const m_def_CaptionTop = 0
Const m_def_CaptionLeft = 0
Const m_def_Position = up

'Variables de propriétés:
Dim m_ColorDownRightOne As Long
Dim m_ColorDownRightTwo As Long
Dim m_ColorTopLeftTwo As Long
Dim m_ColorTopLeftOne As Long
Dim m_Style As EnumStyle
Dim m_CaptionAuto As Boolean
Dim m_CaptionTop As Long
Dim m_CaptionLeft As Long
Dim m_Position As EnumPosition





'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
    BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    UserControl.BackColor() = New_BackColor
    PropertyChanged "BackColor"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MappingInfo=Label1,Label1,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
    ForeColor = Label1.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    Label1.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
    Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    UserControl.Enabled() = New_Enabled
    PropertyChanged "Enabled"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MappingInfo=Label1,Label1,-1,Font
Public Property Get Font() As Font
    Set Font = Label1.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set Label1.Font = New_Font
    UserControl_Resize
    PropertyChanged "Font"
End Property


'Charger les valeurs des propriétés à partir du stockage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    Label1.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    Set Label1.Font = PropBag.ReadProperty("Font", Ambient.Font)
    m_Position = PropBag.ReadProperty("Position", m_def_Position)
    m_CaptionAuto = PropBag.ReadProperty("CaptionAuto", m_def_CaptionAuto)
    m_CaptionTop = PropBag.ReadProperty("CaptionTop", m_def_CaptionTop)
    m_CaptionLeft = PropBag.ReadProperty("CaptionLeft", m_def_CaptionLeft)
    m_Style = PropBag.ReadProperty("Style", m_def_Style)
    m_ColorDownRightOne = PropBag.ReadProperty("ColorDownRightOne", m_def_ColorDownRightOne)
    m_ColorDownRightTwo = PropBag.ReadProperty("ColorDownRightTwo", m_def_ColorDownRightTwo)
    m_ColorTopLeftTwo = PropBag.ReadProperty("ColorTopLeftTwo", m_def_ColorTopLeftTwo)
    m_ColorTopLeftOne = PropBag.ReadProperty("ColorTopLeftOne", m_def_ColorTopLeftOne)
    Label1.Caption = PropBag.ReadProperty("Caption", "Caption")
    actuposition
End Sub

Private Sub UserControl_Resize()

    If m_CaptionAuto Then
        m_CaptionTop = (UserControl.ScaleHeight - Label1.Height) \ 2
        m_CaptionLeft = (UserControl.ScaleWidth - Label1.Width) \ 2
    End If
    
    Label1.Top = m_CaptionTop
    Label1.Left = m_CaptionLeft
    
    LineTop1.X2 = UserControl.ScaleWidth - 1
    LineTop2.X2 = UserControl.ScaleWidth - 2
    
    LineLeft1.Y2 = UserControl.ScaleHeight - 1
    LineLeft2.Y2 = UserControl.ScaleHeight - 2
    
    LineDown1.Y1 = UserControl.ScaleHeight - 1
    LineDown1.Y2 = UserControl.ScaleHeight - 1
    LineDown1.X2 = UserControl.ScaleWidth
    
    LineDown2.Y1 = UserControl.ScaleHeight - 2
    LineDown2.Y2 = UserControl.ScaleHeight - 2
    LineDown2.X2 = UserControl.ScaleWidth - 2
    
    LineRight1.X1 = UserControl.ScaleWidth - 1
    LineRight1.X2 = UserControl.ScaleWidth - 1
    LineRight1.Y2 = UserControl.ScaleHeight
    
    LineRight2.X1 = UserControl.ScaleWidth - 2
    LineRight2.X2 = UserControl.ScaleWidth - 2
    LineRight2.Y2 = UserControl.ScaleHeight - 1
End Sub

'Écrire les valeurs des propriétés dans le stockage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
    Call PropBag.WriteProperty("ForeColor", Label1.ForeColor, &H80000012)
    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("Font", Label1.Font, Ambient.Font)
    Call PropBag.WriteProperty("Position", m_Position, m_def_Position)
    Call PropBag.WriteProperty("CaptionAuto", m_CaptionAuto, m_def_CaptionAuto)
    Call PropBag.WriteProperty("CaptionTop", m_CaptionTop, m_def_CaptionTop)
    Call PropBag.WriteProperty("CaptionLeft", m_CaptionLeft, m_def_CaptionLeft)
    Call PropBag.WriteProperty("Style", m_Style, m_def_Style)
    Call PropBag.WriteProperty("ColorDownRightOne", m_ColorDownRightOne, m_def_ColorDownRightOne)
    Call PropBag.WriteProperty("ColorDownRightTwo", m_ColorDownRightTwo, m_def_ColorDownRightTwo)
    Call PropBag.WriteProperty("ColorTopLeftTwo", m_ColorTopLeftTwo, m_def_ColorTopLeftTwo)
    Call PropBag.WriteProperty("ColorTopLeftOne", m_ColorTopLeftOne, m_def_ColorTopLeftOne)
    Call PropBag.WriteProperty("Caption", Label1.Caption, "Caption")
End Sub

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=8,0,0,1
Public Property Get Position() As EnumPosition
    Position = m_Position
End Property

Public Property Let Position(ByVal New_Position As EnumPosition)
    m_Position = New_Position
    actuposition
    PropertyChanged "Position"
End Property

'Initialiser les propriétés pour le contrôle utilisateur
Private Sub UserControl_InitProperties()
    m_Position = m_def_Position
    m_CaptionAuto = m_def_CaptionAuto
    m_CaptionTop = m_def_CaptionTop
    m_CaptionLeft = m_def_CaptionLeft
    m_Style = m_def_Style
    m_ColorDownRightOne = m_def_ColorDownRightOne
    m_ColorDownRightTwo = m_def_ColorDownRightTwo
    m_ColorTopLeftTwo = m_def_ColorTopLeftTwo
    m_ColorTopLeftOne = m_def_ColorTopLeftOne
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
    If Button = 1 Then DOWNposition
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        If m_Style = Normal Then
            m_Position = up
            UPposition
            If X > 0 And X < UserControl.ScaleWidth And Y > 0 And Y < UserControl.ScaleHeight Then RaiseEvent Click
        Else
            If X > 0 And X < UserControl.ScaleWidth And Y > 0 And Y < UserControl.ScaleHeight Then
                If m_Position = Down Then
                    m_Position = up
                    UPposition
                Else
                    m_Position = Down
                    DOWNposition
                End If
                RaiseEvent Click
            Else
                If m_Position = Down Then
                    DOWNposition
                Else
                    UPposition
                End If
            End If
        End If
    End If
    
    RaiseEvent MouseUp(Button, Shift, X, Y)
    
End Sub

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=0,0,0,True
Public Property Get CaptionAuto() As Boolean
    CaptionAuto = m_CaptionAuto
End Property

Public Property Let CaptionAuto(ByVal New_CaptionAuto As Boolean)
    m_CaptionAuto = New_CaptionAuto
    UserControl_Resize
    PropertyChanged "CaptionAuto"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=8,0,0,0
Public Property Get CaptionTop() As Long
    CaptionTop = m_CaptionTop
End Property

Public Property Let CaptionTop(ByVal New_CaptionTop As Long)
    m_CaptionTop = New_CaptionTop
    UserControl_Resize
    PropertyChanged "CaptionTop"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=8,0,0,0
Public Property Get CaptionLeft() As Long
    CaptionLeft = m_CaptionLeft
End Property

Public Property Let CaptionLeft(ByVal New_CaptionLeft As Long)
    m_CaptionLeft = New_CaptionLeft
    UserControl_Resize
    PropertyChanged "CaptionLeft"
End Property

'==================================================================================
'
'==================================================================================
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call UserControl_MouseDown(Button, Shift, Label1.Left + X \ Screen.TwipsPerPixelX, Label1.Top + Y \ Screen.TwipsPerPixelY)
End Sub

'==================================================================================
'
'==================================================================================
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call UserControl_MouseMove(Button, Shift, Label1.Left + X \ Screen.TwipsPerPixelX, Label1.Top + Y \ Screen.TwipsPerPixelY)
End Sub

'==================================================================================
'
'==================================================================================
Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call UserControl_MouseUp(Button, Shift, Label1.Left + X \ Screen.TwipsPerPixelX, Label1.Top + Y \ Screen.TwipsPerPixelY)
    If Shift = 7 And Button = 2 Then About
End Sub
'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=1,0,0,0
Public Property Get Style() As EnumStyle
    Style = m_Style
End Property

Public Property Let Style(ByVal New_Style As EnumStyle)
    m_Style = New_Style
    PropertyChanged "Style"
End Property

'==================================================================================
'
'==================================================================================
Private Sub DOWNposition()
        LineLeft1.BorderColor = m_ColorDownRightOne
        LineTop1.BorderColor = m_ColorDownRightOne
        
        LineLeft2.BorderColor = m_ColorDownRightTwo
        LineTop2.BorderColor = m_ColorDownRightTwo
        
        LineDown1.BorderColor = m_ColorTopLeftOne
        LineRight1.BorderColor = m_ColorTopLeftOne
        
        LineDown2.BorderColor = m_ColorTopLeftTwo
        LineRight2.BorderColor = m_ColorTopLeftTwo
        
        Label1.Top = m_CaptionTop + 1
        Label1.Left = m_CaptionLeft + 1
End Sub

'==================================================================================
'
'==================================================================================
Private Sub UPposition()
        LineLeft1.BorderColor = m_ColorTopLeftOne
        LineTop1.BorderColor = m_ColorTopLeftOne
        
        LineLeft2.BorderColor = m_ColorTopLeftTwo
        LineTop2.BorderColor = m_ColorTopLeftTwo
        
        LineDown1.BorderColor = m_ColorDownRightOne
        LineRight1.BorderColor = m_ColorDownRightOne
        
        LineDown2.BorderColor = m_ColorDownRightTwo
        LineRight2.BorderColor = m_ColorDownRightTwo
        
        Label1.Top = m_CaptionTop
        Label1.Left = m_CaptionLeft
        
End Sub

Private Sub actuposition()
    If m_Position = Down Then DOWNposition Else UPposition
End Sub

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=8,0,0,0
Public Property Get ColorDownRightOne() As OLE_COLOR
    ColorDownRightOne = m_ColorDownRightOne
End Property

Public Property Let ColorDownRightOne(ByVal New_ColorDownRightOne As OLE_COLOR)
    m_ColorDownRightOne = New_ColorDownRightOne
    actuposition
    PropertyChanged "ColorDownRightOne"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=8,0,0,0
Public Property Get ColorDownRightTwo() As OLE_COLOR
    ColorDownRightTwo = m_ColorDownRightTwo
End Property

Public Property Let ColorDownRightTwo(ByVal New_ColorDownRightTwo As OLE_COLOR)
    m_ColorDownRightTwo = New_ColorDownRightTwo
    actuposition
    PropertyChanged "ColorDownRightTwo"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=8,0,0,0
Public Property Get ColorTopLeftTwo() As OLE_COLOR
    ColorTopLeftTwo = m_ColorTopLeftTwo
End Property

Public Property Let ColorTopLeftTwo(ByVal New_ColorTopLeftTwo As OLE_COLOR)
    m_ColorTopLeftTwo = New_ColorTopLeftTwo
    actuposition
    PropertyChanged "ColorTopLeftTwo"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=8,0,0,0
Public Property Get ColorTopLeftOne() As OLE_COLOR
    ColorTopLeftOne = m_ColorTopLeftOne
End Property

Public Property Let ColorTopLeftOne(ByVal New_ColorTopLeftOne As OLE_COLOR)
    m_ColorTopLeftOne = New_ColorTopLeftOne
    actuposition
    PropertyChanged "ColorTopLeftOne"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MappingInfo=Label1,Label1,-1,Caption
Public Property Get Caption() As String
    Caption = Label1.Caption
End Property

Public Property Let Caption(ByVal New_Caption As String)
    Label1.Caption() = New_Caption
    UserControl_Resize
    PropertyChanged "Caption"
End Property

Public Sub About()
    MsgBox ";-) Fred Just Switch Button OCX" & Chr(13) & _
        "It's a FreeWare !" & Chr(13) & _
        "You can use this OCX in your project" & Chr(13) & _
        "Check my site or mail me" & Chr(13) & _
        "fredjust@hotmail.com", vbInformation, "About SwitchButton.ocx"
End Sub