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