Supracommandboutton
Description
Ba voila c un commandBoutton original qui je l'espère vous séduira
il marche a peu prés comme un commandbutton classique mise a par Forecolr que j'appel Fontcolor.
si vous ne voulez pas telecharger le zip mettez le code si dessous dans un control utilisateur avec un timer(Timer1 Enabled-False Interval-100)
Bon Prog a tous
SupraDolph
il marche a peu prés comme un commandbutton classique mise a par Forecolr que j'appel Fontcolor.
si vous ne voulez pas telecharger le zip mettez le code si dessous dans un control utilisateur avec un timer(Timer1 Enabled-False Interval-100)
Bon Prog a tous
SupraDolph
Source / Exemple :
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
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.