Rotativescroll

Télécharger le projet
Commenter

Description

C le même principe qu'un slider mais sauf qu'il est rond
qui dit rond dit trigo dit plus embêtant à programmer (enfin c mon avis...)
il y a peut-être qq bug graphique ou autre prévené moi si tel est le cas.
les commentaire son les bien venu

Bonne prog a tous
SupraDolph

Source / Exemple : 


' Ce source a été créé par The Dolphin
' e-mail : supradolph@hotmail.com

' Créé le : 02/04/03
'                         SupraDolph ®

        
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

'Variables Globales
Dim Ctrl_Couleur1 As OLE_COLOR
Dim Ctrl_Couleur2 As OLE_COLOR
Dim Ctrl_Value As Single
Dim Ctrl_PosDepart As Single
Dim Ctrl_Back_Color As OLE_COLOR
Dim Ctrl_Region As Boolean

Dim X2 As Single, Y2 As Single
Dim X0 As Single, Y0 As Single
Dim r As Integer

'Constantes Globales
Const Def_Ctrl_Couleur1 = &HD2A58C
Const Def_Ctrl_Couleur2 = &H8E5637
Const Def_Ctrl_Value As Single = 0
Const Def_Ctrl_PosDepart As Single = 0
Const Def_Ctrl_Back_Color = &H8000000F
Const Def_Ctrl_Region As Boolean = False

Const pi As Single = 3.141592
Const Dist As Single = 0.45

'Evénements
Event Click()
Event Scroll()
Event DblClick()
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

Private Sub UserControl_Click()
RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
RaiseEvent DblClick
End Sub

Private Sub UserControl_InitProperties()
Ctrl_Couleur1 = Def_Ctrl_Couleur1
Ctrl_Couleur2 = Def_Ctrl_Couleur2
Ctrl_Value = Def_Ctrl_Value
Ctrl_PosDepart = Def_Ctrl_PosDepart
Ctrl_Back_Color = Def_Ctrl_Back_Color
Ctrl_Region = Def_Ctrl_Region
End Sub

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

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseMove(Button, Shift, X, Y)
    If Button <> 1 Then Exit Sub
    Dim Xp As Single, Yp As Single, Teta As Single, a As Single, b As Single, Depart As Single
    
    Xp = X - X0
    Yp = Y0 - Y
    If Xp < 0 And Yp > 0 Then
        Teta = pi - Abs(Atn(Yp / Xp))
        ElseIf Xp > 0 And Yp < 0 Then Teta = -Abs(Atn(Yp / Xp))
            ElseIf Xp < 0 And Yp < 0 Then Teta = -(pi - Atn(Yp / Xp))
                Else: Teta = Atn(Yp / Xp)
    End If
    a = Cos(Teta) * r * Dist
    b = Sin(-Teta) * r * Dist
    EffaceCercle Ctrl_Couleur1, r * 0.1, X2, Y2
    X2 = a + X0
    Y2 = b + Y0
    DégradeCercle Ctrl_Couleur2, Ctrl_Couleur1, r * 0.1, X2, Y2
    Ctrl_Value = IIf(Teta > 0, Teta * 50 / pi, Teta * 50 / pi + 100)
    Depart = 100 - Ctrl_PosDepart
    Ctrl_Value = IIf(Ctrl_Value + Depart > 100, Ctrl_Value - 100 + Depart, Ctrl_Value + Depart)
    RaiseEvent Scroll
End Sub

Private Function DégradeCercle(Couleur1 As OLE_COLOR, Couleur2 As OLE_COLOR, Rayon As Integer, X As Single, Y As Single, Optional Tx As Single = 0.7)
If Rayon = 0 Then Exit Function
    Dim R1 As Byte, R2 As Byte, V1 As Byte, V2 As Byte, B1 As Byte, B2 As Byte
    Dim i As Integer, Color As OLE_COLOR
    
    R1 = (Couleur1 Mod 256)
    V1 = ((Couleur1 - R1) / 256 Mod 256)
    B1 = Int((Couleur1 - Couleur1 Mod 256) / 256 / 256)
    
    R2 = (Couleur2 Mod 256)
    V2 = ((Couleur2 - R2) / 256 Mod 256)
    B2 = Int((Couleur2 - Couleur2 Mod 256) / 256 / 256)
    
    DrawWidth = 2
    For i = 0 To Rayon Step Rayon / (Rayon * 0.1)
        If i >= Rayon * Tx Then Color = RGB((R1 * ((Rayon * (1 - Tx) - (i - Rayon * Tx)) / (Rayon * (1 - Tx)))) + ((i - Rayon * Tx) / (Rayon * (1 - Tx)) * R2), (V1 * ((Rayon * (1 - Tx) - (i - Rayon * Tx)) / (Rayon * (1 - Tx)))) + ((i - Rayon * Tx) / (Rayon * (1 - Tx)) * V2), (B1 * ((Rayon * (1 - Tx) - (i - Rayon * Tx)) / (Rayon * (1 - Tx)))) + ((i - Rayon * Tx) / (Rayon * (1 - Tx)) * B2)) Else Color = Couleur1
        Circle (X, Y), i, Color
    Next i
End Function

Private Function EffaceCercle(Couleur As OLE_COLOR, Rayon As Integer, X As Single, Y As Single)
If Rayon = 0 Then Exit Function
    Dim i As Integer
    DrawWidth = 1.5
    For i = 0 To Rayon
        Circle (X, Y), i, Couleur
    Next i
End Function

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

Private Sub UserControl_Resize()
X0 = ScaleWidth / 2
Y0 = ScaleHeight / 2
r = IIf(X0 <= Y0, X0, Y0)
Width = 2 * r
Height = Width
X0 = r
Y0 = r

If Ctrl_Region Then
    lReigon = CreateRoundRectRgn(0, 0, ScaleWidth / 15, ScaleHeight / 15, r, r)
    lResult = SetWindowRgn(hWnd, lReigon, True)
    UserControl.BackColor = Ctrl_Couleur2
Else
   UserControl.BackColor = Ctrl_Back_Color
    lReigon = CreateRoundRectRgn(0, 0, ScaleWidth / 15, ScaleHeight / 15, 0, 0)
    lResult = SetWindowRgn(hWnd, lReigon, True)
End If
Cls
DégradeCercle Ctrl_Couleur1, Ctrl_Couleur2, r - 20, X0, Y0

Teta = pi * Ctrl_Value / 50 + Ctrl_PosDepart * pi / 50
a = Cos(Teta) * r * Dist
b = Sin(-Teta) * r * Dist
X2 = a + X0
Y2 = b + Y0

DégradeCercle Ctrl_Couleur2, Ctrl_Couleur1, r * 0.1, X2, Y2, 0.9
End Sub

Private Sub UserControl_Show()
UserControl_Resize
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Ctrl_Couleur1 = PropBag.ReadProperty("Couleur1", Def_Ctrl_Couleur1)
Ctrl_Couleur2 = PropBag.ReadProperty("Couleur2", Def_Ctrl_Couleur2)
Ctrl_Value = PropBag.ReadProperty("Value", Def_Ctrl_Value)
Ctrl_PosDepart = PropBag.ReadProperty("PosDepart", Def_Ctrl_PosDepart)
Ctrl_Back_Color = PropBag.ReadProperty("BackColor", Def_Ctrl_Back_Color)
Ctrl_Region = PropBag.ReadProperty("Region", Def_Ctrl_Region)
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("Couleur1", Ctrl_Couleur1, Def_Ctrl_Couleur1)
Call PropBag.WriteProperty("Couleur2", Ctrl_Couleur2, Def_Ctrl_Couleur2)
Call PropBag.WriteProperty("Value", Ctrl_Value, Def_Ctrl_Value)
Call PropBag.WriteProperty("PosDepart", Ctrl_PosDepart, Def_Ctrl_PosDepart)
Call PropBag.WriteProperty("BackColor", Ctrl_Back_Color, Def_Ctrl_Back_Color)
Call PropBag.WriteProperty("Region", Ctrl_Region, Def_Ctrl_Region)
End Sub

Public Property Get Couleur1() As OLE_COLOR
Couleur1 = Ctrl_Couleur1
End Property

Public Property Let Couleur1(ByVal New_Couleur1 As OLE_COLOR)
Ctrl_Couleur1 = New_Couleur1

Cls
UserControl.BackColor = Ctrl_Back_Color

DégradeCercle Ctrl_Couleur1, Ctrl_Couleur2, r, X0, Y0
X2 = r * Dist + X0
Y2 = Y0
DégradeCercle Ctrl_Couleur2, Ctrl_Couleur1, r * 0.1, X2, Y2, 0.9

PropertyChanged "Couleur1"
End Property

Public Property Get Couleur2() As OLE_COLOR
Couleur2 = Ctrl_Couleur2
End Property

Public Property Let Couleur2(ByVal New_Couleur2 As OLE_COLOR)
Ctrl_Couleur2 = New_Couleur2

Cls
UserControl.BackColor = Ctrl_Back_Color

DégradeCercle Ctrl_Couleur1, Ctrl_Couleur2, r, X0, Y0
X2 = r * Dist + X0
Y2 = Y0
DégradeCercle Ctrl_Couleur2, Ctrl_Couleur1, r * 0.1, X2, Y2, 0.9

PropertyChanged "Couleur2"
End Property

Public Property Get Value() As Single
Value = Ctrl_Value
End Property

Public Property Let Value(ByVal New_Value As Single)
Ctrl_Value = New_Value
If Ctrl_Value > 100 Then
    Ctrl_Value = 100
    MsgBox "La valeur doit-être comprise entre 0 et 100." & vbCrLf & "Cette valeur correspond à l'angle du disque ( [0°;360°] ou [0;2pi] )." & vbCrLf & "La valeur va automatiquement être mise à 100.", 16, "Valuer de Propriété Incorrecte"
ElseIf Ctrl_Value < 0 Then Ctrl_Value = 0: MsgBox "La valeur doit-être comprise entre 0 et 100." & vbCrLf & "Cette valeur correspond à l'angle du disque ( [0°;360°] ou [0;2pi] )." & vbCrLf & "La valeur va automatiquement être mise à 0.", 16, "Valuer de Propriété Incorrecte"
End If

Teta = pi * Ctrl_Value / 50 + Ctrl_PosDepart * pi / 50
a = Cos(Teta) * r * Dist
b = Sin(-Teta) * r * Dist
EffaceCercle Ctrl_Couleur1, r * 0.1, X2, Y2
X2 = a + X0
Y2 = b + Y0
DégradeCercle Ctrl_Couleur2, Ctrl_Couleur1, r * 0.1, X2, Y2, 0.9

PropertyChanged "Value"
End Property

Public Property Get PosDepart() As Single
PosDepart = Ctrl_PosDepart
End Property

Public Property Let PosDepart(ByVal New_PosDepart As Single)
Ctrl_PosDepart = New_PosDepart
If Ctrl_PosDepart > 100 Then
    Ctrl_PosDepart = 100
    MsgBox "La valeur doit-être comprise entre 0 et 100." & vbCrLf & "Cette valeur correspond à l'angle du disque ( [0°;360°] ou [0;2pi] )." & vbCrLf & "La valeur va automatiquement être mise à 100.", 16, "Valuer de Propriété Incorrecte"
ElseIf Ctrl_PosDepart < 0 Then Ctrl_PosDepart = 0: MsgBox "La valeur doit-être comprise entre 0 et 100." & vbCrLf & "Cette valeur correspond à l'angle du disque ( [0°;360°] ou [0;2pi] )." & vbCrLf & "La valeur va automatiquement être mise à 0.", 16, "Valuer de Propriété Incorrecte"
End If
Teta = pi * Ctrl_Value / 50 + Ctrl_PosDepart * pi / 50
a = Cos(Teta) * r * Dist
b = Sin(-Teta) * r * Dist
EffaceCercle Ctrl_Couleur1, r * 0.1, X2, Y2
X2 = a + X0
Y2 = b + Y0
DégradeCercle Ctrl_Couleur2, Ctrl_Couleur1, r * 0.1, X2, Y2, 0.9
PropertyChanged "PosDepart"
End Property

Public Property Get BackColor() As OLE_COLOR
BackColor = Ctrl_Back_Color
End Property

Public Property Let BackColor(ByVal New_Back_Color As OLE_COLOR)
Ctrl_Back_Color = New_Back_Color
If Ctrl_Region = False Then UserControl_Resize
PropertyChanged "BackColor"
End Property

Public Property Get Region() As Boolean
Region = Ctrl_Region
End Property

Public Property Let Region(ByVal New_Region As Boolean)
Ctrl_Region = New_Region
UserControl_Resize
PropertyChanged "Region"
End Property
Télécharger le projet

Codes Sources

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 (SupraDolph)