J'ai cherché un contrôle OCX gratuit permetant d'utiliser un Bouton graphique joli et que l'on puisse paramètrer.
La toîle m'a alors fortement déçu. En effet je suis soit tomber sur des contrôls privés en droits, gratuits au téléchargement et payant a l'utilisation ;(, soit des composants basés sur des bmp, ce qui n'est, à mon goût, pas paramétrable... Loin de moi l'idée de critiquer le travail de mes confrères open-sourceurs vb6chiens.
Je vous propose donc ce composant : Bouton_pp (comme bouton plus plus en référence à mon éditeur de texte préféré.)
Toutes critiques, tous les commentairs constructifs sont les biens venus.
Mon but étant de promouvoir un composant gratuit et fonctionnel, l'avis de tous ceux qui en ont un est indispensables.
Source / Exemple :
Option Explicit
Const PI = 3.14159265
Const Nb_p = 20 'nombre de triangles pour tracer un coin arrondi
'##############################################################################################
'##############################################################################################
Private p_Value As eETAT
Private p_Texte As String
'Les dimensions de la bordure
Private p_Bordure_Hauteur As Byte '% de la bordure en Hauteur par rapport au composant
Private p_Bordure_Largeur As Byte '% de la bordure en Largeur par rapport au composant
'Les Couleurs OFF
Private P_Coul_Centre_Off As Long
Private p_Coul_Bord_OFF As Long
Private p_Coul_Text_OFF As Long
'Les Couleurs OVER
Private p_Coul_Centre_OVER As Long
Private p_Coul_Bord_OVER As Long
Private p_Coul_Text_OVER As Long
'Les Couleurs ON
Private p_Coul_Centre_ON As Long
Private p_Coul_Bord_ON As Long
Private p_Coul_Text_ON As Long
'La transparence
Private p_transparence As Byte
Private p_Enable As Boolean
Private WithEvents p_Font As StdFont
'##############################################################################################
'##############################################################################################
'##############################################################################################
'##############################################################################################
Public Event Click()
Public Event UnClick()
'##############################################################################################
'##############################################################################################
'##############################################################################################
'##############################################################################################
Private Sub UserControl_GotFocus()
If Not p_Enable Then Exit Sub
If (p_Value = e_OFF) Then
p_Value = e_OVER
Call Tracer
End If
End Sub
Private Sub UserControl_LostFocus()
If Not p_Enable Then Exit Sub
p_Value = e_OFF
Call Tracer
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not p_Enable Then Exit Sub
Dim OldEtat As eETAT
OldEtat = p_Value
If isMouseOver(UserControl.hwnd) Then
If p_Value = e_OFF Then
p_Value = e_OVER
Else
End If
If (UserControl.Ambient.UserMode = True) Then Clock.Enabled = True
Else
p_Value = e_OFF
Clock.Enabled = False
End If
If (OldEtat <> p_Value) Then Tracer
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not p_Enable Then Exit Sub
'Clock.Enabled = False 'le mouse up/move pourrait avoir lieu en l'air au cours d'une popup modale ;(
p_Value = e_ON
Call Tracer
RaiseEvent Click
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not p_Enable Then Exit Sub
RaiseEvent UnClick
If isMouseOver(UserControl.hwnd) Then
p_Value = e_OVER
If (UserControl.Ambient.UserMode = True) Then Clock.Enabled = True
Else
p_Value = e_OFF
Clock.Enabled = False
End If
Call Tracer
End Sub
Private Sub Clock_Timer()
Dim OldEtat As eETAT
OldEtat = p_Value
If Not isMouseOver(UserControl.hwnd) Then
p_Value = e_OFF
Clock.Enabled = False
Else
If (p_Value <> e_ON) Then p_Value = e_OVER
End If
If (OldEtat <> p_Value) Then Tracer
End Sub
'##############################################################################################
'##############################################################################################
'##############################################################################################
'##############################################################################################
Private Sub UserControl_Initialize()
P_Coul_Centre_Off = vbWhite
p_Coul_Bord_OFF = vbBlue
p_Coul_Text_OFF = vbBlack
p_Coul_Centre_OVER = vbWhite
p_Coul_Bord_OVER = vbBlue
p_Coul_Text_OVER = vbBlue
p_Coul_Centre_ON = vbWhite
p_Coul_Bord_ON = vbCyan
p_Coul_Text_ON = vbBlack
p_Bordure_Hauteur = 100
p_Bordure_Largeur = 6
p_Texte = UserControl.Name
p_Value = e_OFF
Set p_Font = New StdFont
p_Font.Name = "Times New Roman"
p_transparence = 0 'non transparent
p_Enable = True
End Sub
'----------------------------------------------------------------------------------------------
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("Coul_Centre_OFF", P_Coul_Centre_Off)
Call PropBag.WriteProperty("Coul_Bord_OFF", p_Coul_Bord_OFF)
Call PropBag.WriteProperty("Coul_Text_OFF", p_Coul_Text_OFF)
Call PropBag.WriteProperty("Coul_Centre_OVER", p_Coul_Centre_OVER)
Call PropBag.WriteProperty("Coul_Bord_OVER", p_Coul_Bord_OVER)
Call PropBag.WriteProperty("Coul_Text_OVER", p_Coul_Text_OVER)
Call PropBag.WriteProperty("Coul_Centre_ON", p_Coul_Centre_ON)
Call PropBag.WriteProperty("Coul_Bord_ON", p_Coul_Bord_ON)
Call PropBag.WriteProperty("Coul_Text_ON", p_Coul_Text_ON)
Call PropBag.WriteProperty("Value", p_Value)
Call PropBag.WriteProperty("Texte", p_Texte)
Call PropBag.WriteProperty("Bordure_Largeur", p_Bordure_Largeur)
Call PropBag.WriteProperty("Bordure_Hauteur", p_Bordure_Hauteur)
Call PropBag.WriteProperty("Font", p_Font, Ambient.Font)
Call PropBag.WriteProperty("Enable", p_Enable, UserControl.Ambient.UserMode)
Call PropBag.WriteProperty("Transparence", p_transparence, 0)
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
P_Coul_Centre_Off = PropBag.ReadProperty("Coul_Centre_OFF", 0)
p_Coul_Bord_OFF = PropBag.ReadProperty("Coul_Bord_OFF", 0)
p_Coul_Text_OFF = PropBag.ReadProperty("Coul_Text_OFF", 0)
p_Coul_Centre_OVER = PropBag.ReadProperty("Coul_Centre_OVER", 0)
p_Coul_Bord_OVER = PropBag.ReadProperty("Coul_Bord_OVER", 0)
p_Coul_Text_OVER = PropBag.ReadProperty("Coul_Text_OVER", 0)
p_Coul_Centre_ON = PropBag.ReadProperty("Coul_Centre_ON", 0)
p_Coul_Bord_ON = PropBag.ReadProperty("Coul_Bord_ON", 0)
p_Coul_Text_ON = PropBag.ReadProperty("Coul_Text_ON", 0)
p_Value = PropBag.ReadProperty("Value", e_OFF)
p_Bordure_Hauteur = PropBag.ReadProperty("Bordure_Hauteur", 100)
p_Bordure_Largeur = PropBag.ReadProperty("Bordure_Largeur", 6)
p_Texte = PropBag.ReadProperty("Texte", "")
Set p_Font = PropBag.ReadProperty("Font", Ambient.Font)
p_Enable = PropBag.ReadProperty("Enable", UserControl.Ambient.UserMode)
p_transparence = PropBag.ReadProperty("Transparence", 0)
End Sub
'----------------------------------------------------------------------------------------------
Private Sub UserControl_Paint()
Call Tracer
End Sub
Private Sub UserControl_Resize()
Call Tracer
End Sub
Private Sub UserControl_AmbientChanged(PropertyName As String)
If (PropertyName = "ScaleUnits") Then
UserControl_Paint
End If
End Sub
'##############################################################################################
'##############################################################################################
'##############################################################################################
'##############################################################################################
Public Property Get Enable() As Boolean
Enable = p_Enable
End Property
Public Property Let Enable(nwValue As Boolean)
p_Enable = nwValue
PropertyChanged "Enable"
End Property
Public Property Get Value() As eETAT
Value = p_Value
End Property
Public Property Let Value(nwValue As eETAT)
p_Value = nwValue
PropertyChanged "Value"
Call Tracer
End Property
Public Property Get Couleur_Centre_ON() As OLE_COLOR
Couleur_Centre_ON = p_Coul_Centre_ON
End Property
Public Property Let Couleur_Centre_ON(nwCoul As OLE_COLOR)
p_Coul_Centre_ON = nwCoul
PropertyChanged
If (p_Value = e_ON) Then Call Tracer
PropertyChanged "Couleur_Centre_ON"
End Property
Public Property Get Couleur_Centre_OVER() As OLE_COLOR
Couleur_Centre_OVER = p_Coul_Centre_OVER
End Property
Public Property Let Couleur_Centre_OVER(nwCoul As OLE_COLOR)
p_Coul_Centre_OVER = nwCoul
If (p_Value = e_OVER) Then Call Tracer
PropertyChanged "Couleur_Centre_OVER"
End Property
Public Property Get Couleur_Centre_OFF() As OLE_COLOR
Couleur_Centre_OFF = P_Coul_Centre_Off
End Property
Public Property Let Couleur_Centre_OFF(nwCoul As OLE_COLOR)
P_Coul_Centre_Off = nwCoul
If (p_Value = e_OFF) Then Call Tracer
PropertyChanged "Couleur_Centre_OFF"
End Property
'**********************************************************************************************
Public Property Get Couleur_Bord_ON() As OLE_COLOR
Couleur_Bord_ON = p_Coul_Bord_ON
End Property
Public Property Let Couleur_Bord_ON(nwCoul As OLE_COLOR)
p_Coul_Bord_ON = nwCoul
If (p_Value = e_ON) Then Call Tracer
PropertyChanged "Couleur_Bord_ON"
End Property
Public Property Get Couleur_Bord_OVER() As OLE_COLOR
Couleur_Bord_OVER = p_Coul_Bord_OVER
End Property
Public Property Let Couleur_Bord_OVER(nwCoul As OLE_COLOR)
p_Coul_Bord_OVER = nwCoul
If (p_Value = e_OVER) Then Call Tracer
PropertyChanged "Couleur_Bord_OVER"
End Property
Public Property Get Couleur_Bord_OFF() As OLE_COLOR
Couleur_Bord_OFF = p_Coul_Bord_OFF
End Property
Public Property Let Couleur_Bord_OFF(nwCoul As OLE_COLOR)
p_Coul_Bord_OFF = nwCoul
If (p_Value = e_OFF) Then Call Tracer
PropertyChanged "Couleur_Bord_OFF"
End Property
'**********************************************************************************************
Public Property Get Couleur_Text_ON() As OLE_COLOR
Couleur_Text_ON = p_Coul_Text_ON
End Property
Public Property Let Couleur_Text_ON(nwCoul As OLE_COLOR)
p_Coul_Text_ON = nwCoul
If (p_Value = e_ON) Then Call Tracer
PropertyChanged "Couleur_Text_ON"
End Property
Public Property Get Couleur_Text_OVER() As OLE_COLOR
Couleur_Text_OVER = p_Coul_Text_OVER
End Property
Public Property Let Couleur_Text_OVER(nwCoul As OLE_COLOR)
p_Coul_Text_OVER = nwCoul
If (p_Value = e_OVER) Then Call Tracer
PropertyChanged "Couleur_Text_OVER"
End Property
Public Property Get Couleur_Text_OFF() As OLE_COLOR
Couleur_Text_OFF = p_Coul_Text_OFF
End Property
Public Property Let Couleur_Text_OFF(nwCoul As OLE_COLOR)
p_Coul_Text_OFF = nwCoul
If (p_Value = e_OFF) Then Call Tracer
PropertyChanged "Couleur_Text_OFF"
End Property
'**********************************************************************************************
Public Property Get Bordure_Hauteur() As Byte
Bordure_Hauteur = p_Bordure_Hauteur
End Property
Public Property Let Bordure_Hauteur(nwValue As Byte)
p_Bordure_Hauteur = nwValue
Call Tracer
PropertyChanged "Bordure_Hauteur"
End Property
Public Property Get Bordure_Largeur() As Byte
Bordure_Largeur = p_Bordure_Largeur
End Property
Public Property Let Bordure_Largeur(nwValue As Byte)
p_Bordure_Largeur = nwValue
Call Tracer
PropertyChanged "Bordure_Largeur"
End Property
'**********************************************************************************************
Public Property Get Texte() As String
Texte = p_Texte
End Property
Public Property Let Texte(nwValue As String)
p_Texte = nwValue
Call Tracer
PropertyChanged "Texte"
End Property
Public Property Get Font() As Font
Set Font = p_Font
End Property
Public Property Set Font(ByVal New_Font As Font)
Set p_Font = New_Font
PropertyChanged "Font"
Call Tracer
End Property
Private Sub p_Font_FontChanged(ByVal PropertyName As String)
Call Tracer
PropertyChanged "Font"
End Sub
'**********************************************************************************************
Public Property Get Transparence() As Byte
Transparence = p_transparence
End Property
Public Property Let Transparence(nwValue As Byte)
If (nwValue < 0) Then
p_transparence = 0
ElseIf (nwValue > 100) Then
p_transparence = 100
Else
p_transparence = nwValue
End If
Call Tracer
PropertyChanged "Transparence"
End Property
'##############################################################################################
'##############################################################################################
Private Sub Tracer()
Dim Coul_centre As Long
Dim Coul_bord As Long
Dim Coul_text As Long
If (p_Value = e_ON) Then
Coul_centre = p_Coul_Centre_ON
Coul_bord = p_Coul_Bord_ON
Coul_text = p_Coul_Text_ON
ElseIf (p_Value = e_OVER) Then
Coul_centre = p_Coul_Centre_OVER
Coul_bord = p_Coul_Bord_OVER
Coul_text = p_Coul_Text_OVER
Else
Coul_centre = P_Coul_Centre_Off
Coul_bord = p_Coul_Bord_OFF
Coul_text = p_Coul_Text_OFF
End If
On Error Resume Next
'Gérer les dimensions et positions en fonction du scale mode du parent
Dim m_top As Long 'mon haut dans le composant parent
m_top = UserControl.ScaleY(UserControl.Extender.Top, UserControl.Parent.ScaleMode, vbPixels)
Dim m_left As Long 'ma gauche dans le composant parent
m_left = UserControl.ScaleX(UserControl.Extender.Left, UserControl.Parent.ScaleMode, vbPixels)
'###########################################################################################
' Créer un bitmap pour buffuriser
'###########################################################################################
'Création d'un bitmap pour tracer le dégrader dessus
Dim DC1 As Long
DC1 = GetDC(0)
Dim DC2 As Long
DC2 = GetDC(0)
Dim vDCDegrader As Long
vDCDegrader = CreateCompatibleDC(DC1)
Dim vBMPDegrader As Long
vBMPDegrader = CreateCompatibleBitmap(DC2, UserControl.ScaleWidth, UserControl.ScaleHeight)
Dim holdBMP As Long
holdBMP = SelectObject(vDCDegrader, vBMPDegrader)
'###########################################################################################
'###########################################################################################
' Afficher le dos (transparence des coins)
'###########################################################################################
Dim Res1 As Long
Res1 = BitBlt(vDCDegrader, _
0, 0, _
UserControl.ScaleWidth, UserControl.ScaleHeight, _
UserControl.Parent.hdc, _
m_left, m_top, _
vbSrcCopy)
'###########################################################################################
'###########################################################################################
' tracer un degrader
'###########################################################################################
Dim Brd_Larg As Long
Brd_Larg = UserControl.ScaleWidth * p_Bordure_Largeur / 200
Dim Brd_Haut As Long
Brd_Haut = UserControl.ScaleHeight * p_Bordure_Hauteur / 200
'Les points de la partie plate du bouton
Dim P(1 To 4) As POINTAPI
P(1).X = Brd_Larg
P(1).Y = Brd_Haut
P(2).X = UserControl.ScaleWidth - Brd_Larg
P(2).Y = Brd_Haut
P(3).X = UserControl.ScaleWidth - Brd_Larg
P(3).Y = UserControl.ScaleHeight - Brd_Haut
P(4).X = Brd_Larg
P(4).Y = UserControl.ScaleHeight - Brd_Haut
'Tracer le centre (faux degrader)
Call Grad_Rect(vDCDegrader, _
P(1).X, P(1).Y, Coul_centre, _
P(3).X, P(3).Y, Coul_centre, _
0)
'Tracer le bord haut
Call Grad_Rect(vDCDegrader, _
P(1).X, P(1).Y, Coul_centre, _
P(2).X, 0, Coul_bord, _
1) ' dégradé vertical
'Tracer le bord Bas
Call Grad_Rect(vDCDegrader, _
P(4).X, P(4).Y, Coul_centre, _
P(3).X, UserControl.ScaleHeight, Coul_bord, _
1) ' dégradé vertical
'Tracer le bord Gauche
Call Grad_Rect(vDCDegrader, _
0, P(1).Y, Coul_bord, _
P(4).X, P(4).Y, Coul_centre, _
0) ' dégradé horizontal
'Tracer le bord Droit
Call Grad_Rect(vDCDegrader, _
P(2).X, P(2).Y, Coul_centre, _
UserControl.ScaleWidth, P(3).Y, Coul_bord, _
0) ' dégradé horizontal
'Tracer les coins (arc de cercles par triangles successifs)
'/!\ les points des triangles doivent etre dans le sens des aiguiles d'une motre.
Dim Angl As Double
Dim dA As POINTAPI
Dim dB As POINTAPI
Dim dX As Double, dY As Double
Dim i As Integer
For i = 0 To (Nb_p - 1)
'distance A
Angl = (i * PI) / (2 * Nb_p)
dX = Cos(Angl) * Brd_Larg: dA.X = CLng(dX)
dY = Sin(Angl) * Brd_Haut: dA.Y = CLng(dY)
'distance B
Angl = ((i + 1) * PI) / (2 * Nb_p)
dX = Cos(Angl) * Brd_Larg: dB.X = CLng(dX)
dY = Sin(Angl) * Brd_Haut: dB.Y = CLng(dY)
'Coin Haut Gauche
Call Grad_Triangle(vDCDegrader, _
P(1).X - dA.X, P(1).Y - dA.Y, Coul_bord, _
P(1).X - dB.X, P(1).Y - dB.Y, Coul_bord, _
P(1).X, P(1).Y, Coul_centre)
'Coin Haut Droit
Call Grad_Triangle(vDCDegrader, _
P(2).X + dA.X, P(2).Y - dA.Y, Coul_bord, _
P(2).X + dB.X, P(2).Y - dB.Y, Coul_bord, _
P(2).X, P(2).Y, Coul_centre)
'Coin Bas Droit
Call Grad_Triangle(vDCDegrader, _
P(3).X, P(3).Y, Coul_centre, _
P(3).X + dA.X, P(3).Y + dA.Y, Coul_bord, _
P(3).X + dB.X, P(3).Y + dB.Y, Coul_bord)
'Coin Bas Gauche
Call Grad_Triangle(vDCDegrader, _
P(4).X - dA.X, P(4).Y + dA.Y, Coul_bord, _
P(4).X - dB.X, P(4).Y + dB.Y, Coul_bord, _
P(4).X, P(4).Y, Coul_centre)
Next
'###########################################################################################
'###########################################################################################
' Afficher le texte (doit se faire par DC ;( )
'###########################################################################################
Dim Haut_Carac_Pxl As Long 'Définir la hauteur en pixels du text pour tracer
Haut_Carac_Pxl = -MulDiv(CLng(p_Font.Size), GetDeviceCaps(hdc, LOGPIXELSY), 72)
'Créer le Font dans le DC
Dim hFont As Long, hOldFont As Long
hFont = CreateFont(Haut_Carac_Pxl, 0, 0, 0, _
CLng(p_Font.Weight), _
CLng(p_Font.Italic), _
CLng(p_Font.Underline), _
CLng(p_Font.Strikethrough), _
CLng(p_Font.Charset), _
0, 0, 0, 0, p_Font.Name)
hOldFont = SelectObject(vDCDegrader, hFont)
'Gérer la position du texte
Dim TextSize As POINTAPI 'trouver la hauteur et la largeur en pixel
Call GetTextExtentPoint32(vDCDegrader, p_Texte, Len(p_Texte), TextSize)
'Positionner le text (serra ammener a changer avec les propriété Allignement & PictureAllignement)
Dim Top_Str As Long
Top_Str = (UserControl.ScaleHeight - TextSize.Y) / 2 'centrer en hauteur
Dim Left_Str As Long
Left_Str = (UserControl.ScaleWidth - TextSize.X) / 2 'centrer en largeur
Call SetTextColor(vDCDegrader, Coul_text) 'définir la couleur de la police
Call SetBkMode(vDCDegrader, TRANSPARENT) 'l'arriere est transparent ( sinon carré blanc)
Call TextOut(vDCDegrader, Left_Str, Top_Str, p_Texte, Len(p_Texte)) 'tracer
Call SelectObject(vDCDegrader, hOldFont) 'obligatoire pour ne pas avoir de fuites mémoire
Call DeleteObject(hFont) 'détruire l'objet Font
'###########################################################################################
'###########################################################################################
' Afficher le bitmap sur le control
'###########################################################################################
Call SelectObject(vDCDegrader, vBMPDegrader)
Dim BF As BLENDFUNCTION, lBF As Long
BF.SourceConstantAlpha = p_transparence * 255 / 100
Call RtlMoveMemory(lBF, BF, 4)
Call AlphaBlend _
( _
vDCDegrader, _
0, 0, _
UserControl.ScaleWidth, UserControl.ScaleHeight, _
UserControl.Parent.hdc, _
m_left, m_top, _
UserControl.ScaleWidth, UserControl.ScaleHeight, _
lBF _
)
Dim Res2 As Long
Res2 = BitBlt(UserControl.hdc, _
0, 0, _
UserControl.ScaleWidth, UserControl.ScaleHeight, _
vDCDegrader, _
0, 0, _
vbSrcCopy)
'###########################################################################################
'###########################################################################################
' Détruire le bitmap + DC
'###########################################################################################
Call SelectObject(vDCDegrader, holdBMP)
Call DeleteObject(vBMPDegrader)
Call DeleteDC(vDCDegrader)
Call ReleaseDC(0, DC2)
Call ReleaseDC(0, DC1)
'###########################################################################################
UserControl.Parent.Refresh
End Sub
Conclusion :
Je dois vous avouer une chose, mon domaine c'est plutôt les alghorytmes. Je dois reconnaitre une faiblesse du côté du graphisme.
C'est pourquoi, les personnes ayant des prédispositions pour le disign pourront me donner des propriétés pour que mon bouton ai de la gueule.
Ce qui reste à implementer :
- Allignement du text (Autocentré pour le moment)
- Ajouter une image au bouton. (+ Positionner l'image / texte)
(- Lier le bouton a un fichier ini pour qu'il soit modifiable apres compilation)
amis VB6chiens , cordialement,
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.