Un controle updown simplifié

Télécharger le projet
Commenter

Description

salu

voila, une fois j'avais essayé d'utiliser un controle UpDown, mais il fallait le mettre puis paramétrer en fonction de quel textbox on voulait qu'il soit.... enfin.
en voila un qui regroupe le text et les boutons, c'est donc beaucoup plus simple.

placez en un sur la form puis paramétrez Max, Min et Value.
En fait il s'utilise comme un slider ou un progressbar.
l'evenement change survien quand la valeur a été modifié.

voila, je met le code pour qu'il apparaisse dans la compil.

Source / Exemple : 


'/////////////////////////////////////
'Dans un controle nommé UpDown
'/////////////////////////////////////

Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer

Dim ButtonUpState As Byte
Dim ButtonDownState As Byte
Dim pressed As Byte
Dim M_Value As Long
Dim Clicked As Boolean
Dim M_Largeur As Integer
Dim M_Min As Long
Dim M_Max As Long

Public Event Change(NewValue)

'0 normal 1 enfoncé

Private Sub Augmente()
If M_Value < M_Max Then M_Value = M_Value + 1
RaiseEvent Change(M_Value)
redraw
End Sub
Private Sub Diminu()
If M_Value > M_Min Then M_Value = M_Value - 1
RaiseEvent Change(M_Value)
redraw
End Sub

Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyUp Then Augmente
If KeyCode = vbKeyDown Then Diminu
End Sub

Private Sub Text1_LostFocus()
Text1 = Int(Val(Text1))
M_Value = Int(Val(Text1))
If Int(Val(Text1)) > M_Max Then M_Value = M_Max
If Int(Val(Text1)) < M_Min Then M_Value = M_Min
RaiseEvent Change(M_Value)
redraw
End Sub

Private Sub Timer1_Timer()
'acceleration progression de la vitesse de in/de crementation
If Timer1.Interval <= 50 And Timer1.Interval > 1 Then Timer1.Interval = Timer1.Interval - 1
If Timer1.Interval = 100 Then Timer1.Interval = 50
If Timer1.Interval = 200 Then Timer1.Interval = 100
If Timer1.Interval = 300 Then Timer1.Interval = 200
If Timer1.Interval = 350 Then Timer1.Interval = 300

If Clicked Then
    If pressed = 0 Then Augmente Else Diminu
End If
redraw

If Abs(GetKeyState(1)) < 2 Then UserControl_MouseUp 1, 0, 0, 0
End Sub

Private Sub UserControl_DblClick()
Clicked = True
If pressed = 0 Then
ButtonUpState = 1
Augmente
Timer1.Interval = 350
End If

If pressed = 1 Then
ButtonDownState = 1
Diminu
Timer1.Interval = 350
End If

End Sub

Private Sub UserControl_InitProperties()
M_Largeur = 250
redraw
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Clicked = True
If Y < UserControl.Height / 2 Then
ButtonUpState = 1
Augmente
pressed = 0
Timer1.Interval = 350
End If

If Y > UserControl.Height / 2 Then
ButtonDownState = 1
Diminu
pressed = 1
Timer1.Interval = 350
End If

redraw

End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Changed = 0
If Button = 1 Then
    If X > UserControl.Width Or X < UserControl.Width - M_Largeur Then
        If ButtonUpState <> 0 Or ButtonDownState <> 0 Then Changed = 1
        ButtonUpState = 0
        ButtonDownState = 0
    Else
        If Y < UserControl.Height / 2 And pressed = 0 Then
            If ButtonUpState <> 1 Then Changed = 1
            ButtonUpState = 1
            If Timer1.Interval > 0 Then Timer1_Timer
        End If
        If Y > UserControl.Height / 2 And pressed = 1 Then
            If ButtonDownState <> 1 Then Changed = 1
            ButtonDownState = 1
            If Timer1.Interval > 0 Then Timer1_Timer
        End If
    End If
            If Changed <> 0 Then redraw
End If
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Clicked = False
Timer1.Interval = 0
ButtonUpState = 0
ButtonDownState = 0
redraw
End Sub

Private Sub UserControl_Paint()
redraw
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
M_Largeur = PropBag.ReadProperty("LargeurBoutons", 250)
M_Value = PropBag.ReadProperty("Value", 5)
M_Max = PropBag.ReadProperty("Max", 10)
M_Min = PropBag.ReadProperty("Min", 0)

redraw
End Sub

Private Sub UserControl_Resize()
redraw
End Sub

Public Sub Refresh()
redraw
End Sub

Private Sub redraw()
On Local Error Resume Next
Cls

Text1.Width = UserControl.Width - M_Largeur - 30
Text1.Height = UserControl.Height
If Text1.Height <> UserControl.Height Then UserControl.Height = Text1.Height
'pour aller plus vite
w = UserControl.Width - 15
h = UserControl.Height - 15
m = Int((UserControl.Height - 15) / 2) 'm=milieu

c = vbButtonFace 'c=clair
s = vbButtonShadow 's=sombre

If ButtonUpState = 0 Then
    Line (w - M_Largeur, 0)-(w - M_Largeur, m), 16777215
    Line (w - M_Largeur - 15, 0)-(w - M_Largeur - 15, m), c
    Line (w - M_Largeur, 0)-(w, 0), 16777215
    Line (w - M_Largeur + 15, 15)-(w, 15), c
    Line (w - M_Largeur, m)-(w, m), 0
    Line (w - M_Largeur, m - 15)-(w, m - 15), s
    Line (w, 0)-(w, m), 0
    Line (w - 15, 0)-(w - 15, m), s
    DessineTriangle Int(w - (M_Largeur / 2)) - 15, Int(m / 2) + 15, 1
Else
    Line (w - M_Largeur, 0)-(w - M_Largeur, m), 0
    Line (w - M_Largeur - 15, 0)-(w - M_Largeur - 15, m), s
    Line (w - M_Largeur - 30, 0)-(w, 0), 0
    Line (w - M_Largeur - 30, 15)-(w, 15), s
    Line (w - M_Largeur - 15, m)-(w, m), 16777215
    Line (w - M_Largeur - 15, m - 15)-(w, m - 15), c
    Line (w, 0)-(w, m), 16777215
    Line (w - 15, 0)-(w - 15, m), c
    DessineTriangle Int(w - (M_Largeur / 2)), Int(m / 2) + 30, 1
End If

If ButtonDownState = 0 Then
    Line (w - M_Largeur, m)-(w - M_Largeur, h), 16777215
    Line (w - M_Largeur - 15, m)-(w - M_Largeur - 15, h), c
    Line (w - M_Largeur, m)-(w, m), 16777215
    Line (w - M_Largeur + 15, m + 15)-(w, m + 15), c
    Line (w - M_Largeur, h)-(w, h), 0
    Line (w - M_Largeur, h - 15)-(w, h - 15), s
    Line (w, m)-(w, h + 15), 0
    Line (w - 15, m)-(w - 15, h), s
    DessineTriangle Int(w - (M_Largeur / 2)) - 15, Int(m / 2) + m - 45, 0
Else
    Line (w - M_Largeur, m)-(w - M_Largeur, h), 0
    Line (w - M_Largeur - 15, m)-(w - M_Largeur - 15, h), s
    Line (w - M_Largeur - 30, m)-(w, m), 0
    Line (w - M_Largeur - 30, m + 15)-(w, m + 15), s
    Line (w - M_Largeur - 15, h)-(w, h), 16777215
    Line (w - M_Largeur - 15, h - 15)-(w, h - 15), c
    Line (w, m)-(w, h + 15), 16777215
    Line (w - 15, m)-(w - 15, h), c
    DessineTriangle Int(w - (M_Largeur / 2)), Int(m / 2) + m - 30, 0
End If

Text1 = M_Value
End Sub

Private Sub DessineTriangle(X, Y, Orientation)
'orientation (1= haut 2 bas)
If Orientation = 1 Then
    PSet (X, Y - 15)
    PSet (X, Y - 30)
    PSet (X - 15, Y - 15)
    PSet (X - 30, Y - 15)
    PSet (X + 15, Y - 15)
    PSet (X + 30, Y - 15)
    PSet (X - 15, Y - 30)
    PSet (X + 15, Y - 30)
    PSet (X, Y - 45)
Else
    PSet (X, Y + 15)
    PSet (X, Y + 30)
    PSet (X - 15, Y + 15)
    PSet (X - 30, Y + 15)
    PSet (X + 15, Y + 15)
    PSet (X + 30, Y + 15)
    PSet (X - 15, Y + 30)
    PSet (X + 15, Y + 30)
    PSet (X, Y + 45)
End If

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "LargeurBoutons", M_Largeur, 250
PropBag.WriteProperty "Value", M_Value, 5
PropBag.WriteProperty "Max", M_Max, 10
PropBag.WriteProperty "Min", M_Min, 0

End Sub

Public Property Get LargeurBoutons() As Integer
LargeurBoutons = M_Largeur
End Property

Public Property Let LargeurBoutons(ByVal vNewValue As Integer)
M_Largeur = vNewValue
PropertyChanged "LargeurBoutons"
redraw
End Property

Public Property Get Min() As Long
Min = M_Min
End Property

Public Property Let Min(ByVal vNewValue As Long)
M_Min = vNewValue
PropertyChanged "Min"
redraw
End Property

Public Property Get Max() As Long
Max = M_Max
End Property

Public Property Let Max(ByVal vNewValue As Long)
M_Max = vNewValue
PropertyChanged "Max"
redraw
End Property

Public Property Get Value() As Long
Value = M_Value
End Property

Public Property Let Value(ByVal vNewValue As Long)
M_Value = Value
PropertyChanged "Value"
redraw
End Property

'/////////////////////////////////////
'Dans une form
'/////////////////////////////////////

Private Sub UpDown1_Change(NewValue As Variant)
me.caption = UpDown1.Value

'ou

me.caption = NewValue
End Sub

Conclusion :


voila
laissez moi vos commentaire.

PS : je fairai des MAJ, notemment pour pouvoir modifier les couleurs.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_Stephane)