( Sources convertis en 6 couleurs avec mon programme VB to HTML)
'================================================================================== ' 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