SUPRACOMMANDBOUTTON

Ce source a été créé par The Dolphin
Créé le : 24/03/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
Private Declare Function Arc Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
'Cette fonction dessine un arc elliptique.
'hdc est un pointeur (handle) vers la zone de dessin.
'X1, Y1 indique les coordonnées du point "haut-gauche" du rectangle qui contiendra l'arc.
'X2, Y2 indique les coordonnées du point "bas-droit" du rectangle qui contiendra l'arc.
'X3, Y3 spécifie les coordonnées du point de départ de la ligne servant au découpage de l'arc.
'X4, Y4 spécifie les coordonnées du point d'arrivée de la ligne servant au découpage de l'arc.
'Le dessin se fait dans le sens contraire des aiguilles d'une montre et par rapport aux points X3,Y3 et X4,Y4.

Private Type Coord
    X As Integer
    Y As Integer
End Type

Private Enum State
    BT_Focus = 1
    BT_Clique = 2
    BT_Standard = 3
    BT_Enabled = 4
End Enum

'déclaration pour detecter si le curseur est sur la form
Private Type POINTAPI
        X As Long
        Y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long

Dim Focus As Boolean

'Déclaration d'un type d'énumération
Public Enum Horizontal
    Gauche = 1
    Droite = 2
    Centre = 3
End Enum
Public Enum Vertical
    Haut = 1
    Bas = 2
    Centre = 3
End Enum

'Variables
Dim Ctrl_Caption As String          'Texte a écrire
Dim Ctrl_AlignementH As Horizontal  'Alignement Horizontal
Dim Ctrl_AlignementV As Vertical    'Alignement Vertical
Dim Ctrl_Font_Color As OLE_COLOR    'Couleur De La Police
Dim Ctrl_Couleur1 As OLE_COLOR
Dim Ctrl_Couleur2 As OLE_COLOR
Dim Ctrl_LightMode As Boolean
Dim Ctrl_Enabled As Boolean

'Constantes
Const Def_Ctrl_AlignementH = 3
Const Def_Ctrl_AlignementV = 3
Const Def_Ctrl_Font_Color = &H80000012
Const Def_Ctrl_Couleur1 = &HD2A58C
Const Def_Ctrl_Couleur2 = &H8E5637
Const Def_Ctrl_LightMode = True
Const Def_Ctrl_Enabled = True

'Evénements
Event Click()
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_InitProperties()
Ctrl_Caption = Extender.Name
Ctrl_AlignementH = Def_Ctrl_AlignementH
Ctrl_AlignementV = Def_Ctrl_AlignementV
Ctrl_Font_Color = Def_Ctrl_Font_Color
Ctrl_Couleur1 = Def_Ctrl_Couleur1
Ctrl_Couleur2 = Def_Ctrl_Couleur2
Ctrl_LightMode = Def_Ctrl_LightMode
Ctrl_Enabled = Def_Ctrl_Enabled
End Sub

Private Sub UserControl_GotFocus()
If Not Ctrl_Enabled Then Exit Sub
Focus = True
If Ctrl_LightMode = False Then TypeBt BT_Focus
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
If Not Ctrl_Enabled Then Exit Sub
If KeyCode = 13 Or KeyCode = 32 Then TypeBt BT_Clique
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
If Not Ctrl_Enabled Then Exit Sub
If KeyCode = 13 Or KeyCode = 32 Then TypeBt BT_Standard
End Sub

Private Sub UserControl_LostFocus()
If Not Ctrl_Enabled Then Exit Sub
Focus = False
TypeBt BT_Standard
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not Ctrl_Enabled Then Exit Sub
RaiseEvent MouseDown(Button, Shift, X, Y)
TypeBt BT_Clique
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not Ctrl_Enabled Then Exit Sub
If Timer1.Enabled Then Exit Sub
RaiseEvent MouseMove(Button, Shift, X, Y)
If Button = 0 Then
   Timer1.Enabled = True
End If
If Ctrl_LightMode Then TypeBt BT_Standard Else Tours &H4FB3EE
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not Ctrl_Enabled Then Exit Sub
RaiseEvent MouseUp(Button, Shift, X, Y)
TypeBt BT_Standard
End Sub

Private Sub UserControl_Resize()
Dim lReigon As Long
Dim lResult As Long
Dim Moy As Integer

Moy = (ScaleWidth * 0.1 + ScaleHeight * 0.1) / 30
lReigon = CreateRoundRectRgn(0, 0, ScaleWidth / 15, ScaleHeight / 15, Moy, Moy)
lResult = SetWindowRgn(hWnd, lReigon, True)
If Not Ctrl_Enabled Then TypeBt BT_Enabled Else TypeBt BT_Standard
End Sub

Private Function Degrade(Couleur1 As OLE_COLOR, Couleur2 As OLE_COLOR)
Dim i As Integer, Longeur As Integer, Largeur As Integer
Dim R1 As Integer, R2 As Integer, V1 As Integer, V2 As Integer, B1 As Integer, B2 As Integer

Longeur = ScaleHeight
Largeur = ScaleWidth

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)

If Ctrl_LightMode And Timer1.Enabled Then
    R1 = R1 + 30: V1 = V1 + 30: B1 = B1 + 30: R2 = R2 + 30: V2 = V2 + 30: B2 = B2 + 30
    VerifColor R1, V1, B1
    VerifColor R2, V2, B2
End If
Cls
For i = 0 To Longeur
    Line (0, i)-(Largeur, i), RGB((R1 * ((Longeur - i) / Longeur)) + (i / Longeur * R2), (V1 * ((Longeur - i) / Longeur)) + (i / Longeur * V2), (B1 * ((Longeur - i) / Longeur)) + (i / Longeur * B2))
Next i
End Function

Private Function Tours(Color As OLE_COLOR)
Dim HG As Coord, BD As Coord, DP As Coord, AR As Coord
Dim Moy As Integer

Moy = (ScaleWidth * 0.1 + ScaleHeight * 0.1) / 30

DrawWidth = 0.3 * Moy
ForeColor = Color
'Haut Gauche
HG.X = Moy
HG.Y = Moy
BD.X = 3 * HG.X
BD.Y = 3 * HG.Y
DP.X = 2 * HG.X
DP.Y = HG.Y
AR.X = HG.X
AR.Y = 2 * HG.Y
Arc hdc, HG.X, HG.Y, BD.X, BD.Y, DP.X, DP.Y, AR.X, AR.Y

'Bas Gauche
HG.X = Moy
HG.Y = ScaleHeight / 15 - 3 * Moy
BD.X = 3 * HG.X
BD.Y = ScaleHeight / 15 - Moy
DP.X = HG.X
DP.Y = ScaleHeight / 15 - 2 * Moy
AR.X = 2 * HG.X
AR.Y = BD.Y
Arc hdc, HG.X, HG.Y, BD.X, BD.Y, DP.X, DP.Y, AR.X, AR.Y

'Haut Droit
HG.X = ScaleWidth / 15 - 3 * Moy
HG.Y = Moy
BD.X = ScaleWidth / 15 - Moy
BD.Y = 3 * HG.Y
DP.X = BD.X
DP.Y = 2 * HG.Y
AR.X = ScaleWidth / 15 - 2 * Moy
AR.Y = HG.Y
Arc hdc, HG.X, HG.Y, BD.X, BD.Y, DP.X, DP.Y, AR.X, AR.Y

'Bas Droit
HG.X = ScaleWidth / 15 - 3 * Moy
HG.Y = ScaleHeight / 15 - 3 * Moy
BD.X = ScaleWidth / 15 - Moy
BD.Y = ScaleHeight / 15 - Moy
DP.X = ScaleWidth / 15 - 2 * Moy
DP.Y = BD.Y
AR.X = BD.X
AR.Y = ScaleHeight / 15 - 2 * Moy
Arc hdc, HG.X, HG.Y, BD.X, BD.Y, DP.X, DP.Y, AR.X, AR.Y

Line (2 * Moy * 15, Moy * 15)-(ScaleWidth - 2 * Moy * 15, Moy * 15), Color                              'Haut
Line (ScaleWidth - Moy * 15, 2 * Moy * 15)-(ScaleWidth - Moy * 15, ScaleHeight - 2 * Moy * 15), Color 'Droit
Line (2 * Moy * 15, ScaleHeight - Moy * 15)-(ScaleWidth - 2 * Moy * 15, ScaleHeight - Moy * 15), Color  'Bas
Line (Moy * 15, 2 * Moy * 15)-(Moy * 15, ScaleHeight - 2 * Moy * 15), Color                     'Gauche
DrawWidth = 1
End Function


Private Sub Timer1_Timer()
    Dim Pos As POINTAPI
    Dim WFP As Long
    
    GetCursorPos Pos
    WFP = WindowFromPoint(Pos.X, Pos.Y)
    
    If WFP <> hWnd Then
        Timer1.Enabled = False
        TypeBt BT_Standard
        If Focus Then UserControl_GotFocus
    End If
End Sub

Private Function TypeBt(Etat As State)
Dim Moy As Integer

Moy = (ScaleWidth * 0.05 + ScaleHeight * 0.05) / 2
Select Case Etat
    Case BT_Clique
        Degrade Ctrl_Couleur2, Ctrl_Couleur1
        Cadre Ctrl_Couleur2, Ctrl_Couleur1, Moy
        Texte
    Case BT_Focus
        Tours &HE86D39
    Case BT_Standard
        Degrade Ctrl_Couleur1, Ctrl_Couleur2
        Cadre Ctrl_Couleur1, Ctrl_Couleur2, Moy
        Texte
    Case BT_Enabled
        Degrade &HE0E0E0, &HC0C0C0
        Cadre &HE0E0E0, &HC0C0C0, Moy
        Texte
End Select
End Function

Public Function Cadre(Couleur1 As OLE_COLOR, Couleur2 As OLE_COLOR, Largeur As Integer)
On Error GoTo fin
Dim i As Integer, Longeur As Integer
Dim R1 As Integer, R2 As Integer, V1 As Integer, V2 As Integer, B1 As Integer, B2 As Integer

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)

If Ctrl_LightMode And Timer1.Enabled Or Focus Then
    R1 = R1 + 30: V1 = V1 + 30: B1 = B1 + 30: R2 = R2 + 30: V2 = V2 + 30: B2 = B2 + 30
    VerifColor R1, V1, B1
    VerifColor R2, V2, B2
End If

For i = 0 To Largeur
    Line (i, i)-(ScaleWidth - i, i), RGB((R2 * ((Largeur - i) / Largeur)) + (i / Largeur * R1), (V2 * ((Largeur - i) / Largeur)) + (i / Largeur * V1), (B2 * ((Largeur - i) / Largeur)) + (i / Largeur * B1))  'Haut
    Line (i, i)-(i, ScaleHeight - i), RGB((R2 * ((Largeur - i) / Largeur)) + (i / Largeur * R1), (V2 * ((Largeur - i) / Largeur)) + (i / Largeur * V1), (B2 * ((Largeur - i) / Largeur)) + (i / Largeur * B1))  'Gauche
    Line (i, ScaleHeight - i - 20)-(ScaleWidth - i + 1, ScaleHeight - i - 20), RGB((R1 * ((Largeur - i) / Largeur)) + (i / Largeur * R2), (V1 * ((Largeur - i) / Largeur)) + (i / Largeur * V2), (B1 * ((Largeur - i) / Largeur)) + (i / Largeur * B2)) 'Bas
    Line (ScaleWidth - i - 20, i)-(ScaleWidth - i - 20, ScaleHeight - i), RGB((R1 * ((Largeur - i) / Largeur)) + (i / Largeur * R2), (V1 * ((Largeur - i) / Largeur)) + (i / Largeur * V2), (B1 * ((Largeur - i) / Largeur)) + (i / Largeur * B2)) 'Droite
Next i
fin:
End Function

Private Function VerifColor(Rouge, Vert, Bleu)
'procédure qui vérifie si la nouvelle couleur est valide
If Rouge < 0 Then Rouge = 0
If Vert < 0 Then Vert = 0
If Bleu < 0 Then Bleu = 0
If Rouge > 255 Then Rouge = 255
If Vert > 255 Then Vert = 255
If Bleu > 255 Then Bleu = 255
End Function

Private Function Texte()
Dim VCurrentX As Integer, VCurrentY As Integer
Select Case Ctrl_AlignementH
    Case 1
        VCurrentX = 0
    Case 2
        VCurrentX = ScaleWidth - TextWidth(Ctrl_Caption)
    Case 3
        VCurrentX = (ScaleWidth - TextWidth(Ctrl_Caption)) / 2
End Select
Select Case Ctrl_AlignementV
    Case 1
        VCurrentY = 0
    Case 2
        VCurrentY = ScaleHeight - TextHeight(Ctrl_Caption)
    Case 3
        VCurrentY = (ScaleHeight - TextHeight(Ctrl_Caption)) / 2
End Select
ForeColor = IIf(Ctrl_Enabled, Ctrl_Font_Color, &H6C6C6C)
CurrentX = VCurrentX
CurrentY = VCurrentY
Print Ctrl_Caption
End Function

Public Property Get Caption() As String
Caption = Ctrl_Caption
End Property

Public Property Let Caption(ByVal New_Caption As String)
Ctrl_Caption = New_Caption
TypeBt BT_Standard
PropertyChanged "Caption"
End Property

Public Property Get Font() As Font
Set Font = UserControl.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
Set UserControl.Font = New_Font
UserControl.FontName = Font.Name
UserControl.FontSize = Font.Size
UserControl.FontBold = Font.Bold
UserControl.FontItalic = Font.Italic
UserControl.FontStrikethru = Font.Strikethrough
UserControl.FontUnderline = Font.Underline
TypeBt BT_Standard
PropertyChanged "Font"
End Property

Public Property Get AlignementH() As Horizontal
AlignementH = Ctrl_AlignementH
End Property

Public Property Let AlignementH(ByVal New_AlignementH As Horizontal)
Ctrl_AlignementH = New_AlignementH
TypeBt BT_Standard
PropertyChanged "AlignementH"
End Property

Public Property Get AlignementV() As Vertical
AlignementV = Ctrl_AlignementV
End Property

Public Property Let AlignementV(ByVal New_AlignementV As Vertical)
Ctrl_AlignementV = New_AlignementV
TypeBt BT_Standard
PropertyChanged "AlignementV"
End Property

Public Property Get FontColor() As OLE_COLOR
FontColor = Ctrl_Font_Color
End Property

Public Property Let FontColor(ByVal New_Font_Color As OLE_COLOR)
Ctrl_Font_Color = New_Font_Color
TypeBt BT_Standard
PropertyChanged "FontColor"
End Property

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
TypeBt BT_Standard
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
TypeBt BT_Standard
PropertyChanged "Couleur2"
End Property

Public Property Get LightMode() As Boolean
LightMode = Ctrl_LightMode
End Property

Public Property Let LightMode(ByVal New_LightMode As Boolean)
Ctrl_LightMode = New_LightMode
TypeBt BT_Standard
PropertyChanged "LightMode"
End Property

Public Property Get Enabled() As Boolean
Enabled = Ctrl_Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
Ctrl_Enabled = New_Enabled
UserControl.Enabled = Ctrl_Enabled
If Not Ctrl_Enabled Then TypeBt BT_Enabled Else TypeBt BT_Standard
PropertyChanged "Enabled"
End Property

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
Ctrl_Caption = PropBag.ReadProperty("Caption", Extender.Name)
Ctrl_AlignementH = PropBag.ReadProperty("AlignementH", Def_Ctrl_AlignementH)
Ctrl_AlignementV = PropBag.ReadProperty("Alignementv", Def_Ctrl_AlignementV)
Ctrl_Font_Color = PropBag.ReadProperty("FontColor", Def_Ctrl_Font_Color)
Ctrl_Couleur1 = PropBag.ReadProperty("Couleur1", Def_Ctrl_Couleur1)
Ctrl_Couleur2 = PropBag.ReadProperty("Couleur2", Def_Ctrl_Couleur2)
Ctrl_LightMode = PropBag.ReadProperty("LightMode", Def_Ctrl_LightMode)
Ctrl_Enabled = PropBag.ReadProperty("Enabled", Def_Ctrl_Enabled)
End Sub

Private Sub UserControl_Show()
UserControl_Resize
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
Call PropBag.WriteProperty("Caption", Ctrl_Caption, Extender.Name)
Call PropBag.WriteProperty("AlignementH", Ctrl_AlignementH, Def_Ctrl_AlignementH)
Call PropBag.WriteProperty("AlignementV", Ctrl_AlignementV, Def_Ctrl_AlignementV)
Call PropBag.WriteProperty("FontColor", Ctrl_Font_Color, Def_Ctrl_Font_Color)
Call PropBag.WriteProperty("Couleur1", Ctrl_Couleur1, Def_Ctrl_Couleur1)
Call PropBag.WriteProperty("Couleur2", Ctrl_Couleur2, Def_Ctrl_Couleur2)
Call PropBag.WriteProperty("LightMode", Ctrl_LightMode, Def_Ctrl_LightMode)
Call PropBag.WriteProperty("Enabled", Ctrl_Enabled, Def_Ctrl_Enabled)
End Sub