( Sources convertis en 6 couleurs avec mon programme VB to HTML)

 
'Valeurs de propriétés par défaut:
Const m_def_AutoCaption = True
Const m_def_StrExtend = "%"
Const m_def_Interactive = True
Const m_def_Min = 0
Const m_def_Max = 100
Const m_def_Value = 50
'Variables de propriétés:
Dim m_AutoCaption As Boolean
Dim m_StrExtend As String
Dim m_Interactive As Boolean
Dim m_Min As Variant
Dim m_Max As Variant
Dim m_Value As Variant
'Déclarations d'événements:
Event Change()
Event DblClick() 'MappingInfo=Picture1,Picture1,-1,DblClick
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Picture1,Picture1,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Picture1,Picture1,-1,MouseMove
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Picture1,Picture1,-1,MouseUp




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

Public Property Let Appearance(ByVal New_Appearance As Integer)
    Picture1.Appearance() = New_Appearance
    UserControl_Resize
    PropertyChanged "Appearance"
End Property

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

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    Picture1.BackColor() = New_BackColor
    Value = m_Value
    PropertyChanged "BackColor"
End Property

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

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    Picture1.BorderStyle() = New_BorderStyle
    UserControl_Resize
    PropertyChanged "BorderStyle"
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 & IIf(m_AutoCaption, m_StrExtend, "")
    Label1.Move (Picture1.ScaleWidth - Label1.Width) \ 2, (Picture1.ScaleHeight - Label1.Height) \ 2
    PropertyChanged "Caption"
End Property

Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X + Label1.Left, Y + Label1.Top)
    Call Picture1_MouseDown(Button, Shift, X + Label1.Left, Y + Label1.Top)
    If Button = 2 And Shift = 4 Then about
End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X + Label1.Left, Y + Label1.Top)
    Call Picture1_MouseMove(Button, Shift, X + Label1.Left, Y + Label1.Top)
End Sub

Private Sub Picture1_DblClick()
    RaiseEvent DblClick
End Sub

'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

'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
    Value = m_Value
    PropertyChanged "ForeColor"
End Property

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
    If m_Interactive Then
            If Button = 1 Then
                Value = XinValue(X)
            End If
     End If
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
    If m_Interactive Then
            If Button = 1 Then
                Value = XinValue(X)
            End If
     End If
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=14,0,0,0
Public Property Get Min() As Variant
    Min = m_Min
End Property

Public Property Let Min(ByVal New_Min As Variant)
    m_Min = New_Min
    Value = m_Value
    PropertyChanged "Min"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=14,0,0,100
Public Property Get Max() As Variant
    Max = m_Max
End Property

Public Property Let Max(ByVal New_Max As Variant)
    m_Max = New_Max
    Value = m_Value
    PropertyChanged "Max"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=14,0,0,50
Public Property Get Value() As Variant
    Value = m_Value
End Property

Public Property Let Value(ByVal New_Value As Variant)
    m_Value = New_Value
    Picture1.Line (m_Value / m_Max * Picture1.ScaleWidth, 0)-(Picture1.ScaleWidth, Picture1.ScaleHeight), Picture1.BackColor, BF
    Picture1.Line (0, 0)-(m_Value / m_Max * Picture1.ScaleWidth, Picture1.ScaleHeight), Picture1.FillColor, BF
    If m_AutoCaption Then
        Label1.Caption = CStr(m_Value) & m_StrExtend
        Label1.Move (Picture1.ScaleWidth - Label1.Width) \ 2, (Picture1.ScaleHeight - Label1.Height) \ 2
    End If
    RaiseEvent Change
    PropertyChanged "Value"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=14
Public Function XinValue(ByVal X As Long) As Long
Dim tempo As Long
    tempo = X / Picture1.ScaleWidth * m_Max
    If tempo > m_Max Then tempo = m_Max
    If tempo < m_Min Then tempo = m_Min
    XinValue = tempo
End Function

'Initialiser les propriétés pour le contrôle utilisateur
Private Sub UserControl_InitProperties()
    m_Min = m_def_Min
    m_Max = m_def_Max
    m_Value = m_def_Value
    m_Interactive = m_def_Interactive
    m_StrExtend = m_def_StrExtend
    m_AutoCaption = m_def_AutoCaption
End Sub



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

    Picture1.Appearance = PropBag.ReadProperty("Appearance", 1)
    Picture1.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
    Picture1.BorderStyle = PropBag.ReadProperty("BorderStyle", 1)
    Label1.Caption = PropBag.ReadProperty("Caption", "50")
    Set Label1.Font = PropBag.ReadProperty("Font", Ambient.Font)
    Label1.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    m_Min = PropBag.ReadProperty("Min", m_def_Min)
    m_Max = PropBag.ReadProperty("Max", m_def_Max)
    m_Value = PropBag.ReadProperty("Value", m_def_Value)
    Picture1.FillColor = PropBag.ReadProperty("FillColor", &HFF&)
    m_Interactive = PropBag.ReadProperty("Interactive", m_def_Interactive)
    m_StrExtend = PropBag.ReadProperty("StrExtend", m_def_StrExtend)
    m_AutoCaption = PropBag.ReadProperty("AutoCaption", m_def_AutoCaption)
End Sub

Private Sub UserControl_Resize()
    Picture1.Move 0, 0, UserControl.Width, UserControl.Height
    Label1.Move (Picture1.ScaleWidth - Label1.Width) \ 2, (Picture1.ScaleHeight - Label1.Height) \ 2
    Value = m_Value
End Sub

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

    Call PropBag.WriteProperty("Appearance", Picture1.Appearance, 1)
    Call PropBag.WriteProperty("BackColor", Picture1.BackColor, &H8000000F)
    Call PropBag.WriteProperty("BorderStyle", Picture1.BorderStyle, 1)
    Call PropBag.WriteProperty("Caption", Label1.Caption, "50")
    Call PropBag.WriteProperty("Font", Label1.Font, Ambient.Font)
    Call PropBag.WriteProperty("ForeColor", Label1.ForeColor, &H80000012)
    Call PropBag.WriteProperty("Min", m_Min, m_def_Min)
    Call PropBag.WriteProperty("Max", m_Max, m_def_Max)
    Call PropBag.WriteProperty("Value", m_Value, m_def_Value)
    Call PropBag.WriteProperty("FillColor", Picture1.FillColor, &HFF&)
    Call PropBag.WriteProperty("Interactive", m_Interactive, m_def_Interactive)
    Call PropBag.WriteProperty("StrExtend", m_StrExtend, m_def_StrExtend)
    Call PropBag.WriteProperty("AutoCaption", m_AutoCaption, m_def_AutoCaption)
End Sub

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

Public Property Let FillColor(ByVal New_FillColor As OLE_COLOR)
    Picture1.FillColor() = New_FillColor
    Value = m_Value
    PropertyChanged "FillColor"
End Property

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

Public Property Let Interactive(ByVal New_Interactive As Boolean)
    m_Interactive = New_Interactive
    PropertyChanged "Interactive"
End Property

'ATTENTION! NE SUPPRIMEZ PAS OU NE MODIFIEZ PAS LES LIGNES COMMENTÉES SUIVANTES!
'MemberInfo=13,0,0,%
Public Property Get StrExtend() As String
    StrExtend = m_StrExtend
End Property

Public Property Let StrExtend(ByVal New_StrExtend As String)
    m_StrExtend = New_StrExtend
    Value = m_Value
    PropertyChanged "StrExtend"
End Property

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

Public Property Let AutoCaption(ByVal New_AutoCaption As Boolean)
    m_AutoCaption = New_AutoCaption
    PropertyChanged "AutoCaption"
End Property