Controls ++(controls graphiques en construction)
Description
Me revoici avec mes contrôles graphiques paramétrables.
Contient :
- Bouton (OK)
- ProgressBar (OK , peut évoluer)
- ListBox (non implémenté)
- ScrollBar (non implémenté)
...
Basé sur les mêmes API que ma précédente source : http://www.vbfrance.com/codes/BOUTON-GRAPHIQUE-PARAMETRABLE_50899.aspx
Le mode de tracé a été complètement revu.
Le code est a été un minimum structuré et commenté (mais ca n'est pas forcement clair pour autant)
en espérant que cela serve,
Il reste quelques petites choses qui ne me satisfont pas, si des personnes connaissent la solution :
L'arriere plan des bouton ne correspond pas a ce qu'il y a derière mais a la form contenante.
par exemple, si je place un bouton sur un Frame Jaune placé sur un frame gris, les bords du bouton serront gris au lieu d'êtres jaunes ;( ...
De même, si un bouton est partielement sur un autre objet cet objet ne serra pas pris en compte pour la transparence...
Garantis sans fuite mémoire
Contient :
- Bouton (OK)
- ProgressBar (OK , peut évoluer)
- ListBox (non implémenté)
- ScrollBar (non implémenté)
...
Basé sur les mêmes API que ma précédente source : http://www.vbfrance.com/codes/BOUTON-GRAPHIQUE-PARAMETRABLE_50899.aspx
Le mode de tracé a été complètement revu.
Le code est a été un minimum structuré et commenté (mais ca n'est pas forcement clair pour autant)
en espérant que cela serve,
Source / Exemple :
Option Explicit
Private Type t_ETAT
position_m As Double 'position de la couleur "millieu" depuis le haut du control en %
couleur_1 As Long 'couleur du haut
couleur_2 As Long 'couleur du millieu haut
couleur_3 As Long 'couleur du millieu bas
couleur_4 As Long 'couleur du bas
bordure_l As Double 'taille en % des deux bordure verticales
bordure_h As Double 'taille en % des deux bordure horizontales
bordure_epp As Long 'épaisseur de la bordure en Pxl
couleur_brd As Long 'couleur de la bordure
couleur_texte As Long
transparence As Double 'taux de transparence du control
End Type
Private WithEvents p_Font As StdFont 'la police quel que soit l'état
Private p_caption As String 'le text quel que soit l'état
Private p_enable As Boolean
Private p_etat As eETAT
Private e_OFF As t_ETAT
Private e_OVER As t_ETAT
Private e_ON As t_ETAT
'##############################################################################################
'##############################################################################################
Public Event Click()
Public Event UnClick()
'##############################################################################################
'##############################################################################################
'######################################################
'######################################################
'######################################################
Private Sub UserControl_Initialize()
'Instanciation du composant
'valeurs par défaut
p_caption = UserControl.Name
p_etat = eETAT.e_OFF
p_enable = True
e_OFF = new_ETAT(51, &HFFFFFF, &H404040, &H404040, &H0&, 10, 30, 1, vbBlack, &HFFFFFF, 20)
e_OVER = new_ETAT(51, &HFFFFFF, &H404040, &H404040, &H0&, 10, 30, 1, vbBlack, &HFFFFFF, 10)
e_ON = new_ETAT(51, &H808080, &H404040, &H404040, &H808080, 10, 30, 1, vbBlack, &HFFFFFF, 0)
End Sub
'######################################################
Private Sub UserControl_Paint()
'Ré-affichage du composant
Call Affichage
End Sub
'######################################################
Private Sub UserControl_Resize()
'Modification des dimensions du composant
Call Affichage
End Sub
'######################################################
Private Sub UserControl_Terminate()
'Dé-Instanciation du composant
End Sub
'######################################################
Private Sub UserControl_AmbientChanged(PropertyName As String)
'Modification d'une propriété du composant parent
Call Affichage
End Sub
'######################################################
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
p_etat = PropBag.ReadProperty("etat", eETAT.e_OFF)
p_caption = PropBag.ReadProperty("Texte", "")
p_enable = PropBag.ReadProperty("Enable", True)
Set p_Font = PropBag.ReadProperty("Font", Ambient.Font)
Call Load_ETAT(e_OFF, "OFF", PropBag)
Call Load_ETAT(e_OVER, "OVER", PropBag)
Call Load_ETAT(e_ON, "ON", PropBag)
Call Affichage
End Sub
'######################################################
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("etat", p_etat, eETAT.e_OFF)
Call PropBag.WriteProperty("Texte", p_caption)
Call PropBag.WriteProperty("Font", p_Font, Ambient.Font)
Call PropBag.WriteProperty("Enable", p_enable, True)
Call Save_ETAT("OFF", e_OFF, PropBag)
Call Save_ETAT("OVER", e_OVER, PropBag)
Call Save_ETAT("ON", e_ON, PropBag)
End Sub
'######################################################
'######################################################
'######################################################
Private Sub UserControl_LostFocus()
If Not p_enable Then Exit Sub
p_etat = eETAT.e_OFF
Call Affichage
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_etat
If isMouseOver(UserControl.hwnd) Then
If p_etat = eETAT.e_OFF Then
p_etat = eETAT.e_OVER
Else
End If
If (UserControl.Ambient.UserMode = True) Then Clock.Enabled = True
Else
p_etat = eETAT.e_OFF
Clock.Enabled = False
End If
If (OldEtat <> p_etat) Then Affichage
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_etat = eETAT.e_ON
Call Affichage
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_etat = eETAT.e_OVER
If (UserControl.Ambient.UserMode = True) Then Clock.Enabled = True
Else
p_etat = eETAT.e_OFF
Clock.Enabled = False
End If
Call Affichage
End Sub
Private Sub Clock_Timer()
Dim OldEtat As eETAT
OldEtat = p_etat
If Not isMouseOver(UserControl.hwnd) Then
p_etat = eETAT.e_OFF
Clock.Enabled = False
Else
If (p_etat <> eETAT.e_ON) Then p_etat = eETAT.e_OVER
End If
If (OldEtat <> p_etat) Then Affichage
End Sub
'######################################################
'######################################################
'######################################################
'######################################################
'######################################################
Public Property Get Etat() As eETAT
Etat = p_etat
End Property
Public Property Let Etat(nwValue As eETAT)
p_etat = nwValue
PropertyChanged "Etat"
Call Affichage
End Property
'######################################################
Public Property Get Texte() As String
Texte = p_caption
End Property
Public Property Let Texte(nwValue As String)
p_caption = nwValue
PropertyChanged "Texte"
Call Affichage
End Property
Public Property Get Caption() As String
Caption = p_caption
End Property
Public Property Let Caption(nwValue As String)
p_caption = nwValue
PropertyChanged "Caption"
Call Affichage
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 Affichage
End Property
Private Sub p_Font_FontChanged(ByVal PropertyName As String)
PropertyChanged "Font"
Call Affichage
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
'######################################################
'######################################################
'######################################################
' Propriétés d'apparence d' OFF
'######################################################
Public Property Get OFF_Transparence() As Double
OFF_Transparence = e_OFF.transparence
End Property
Public Property Let OFF_Transparence(nwValue As Double)
If ((nwValue < 0) Or (nwValue > 100)) Then
'Valeur incorrecte
If (UserControl.Ambient.UserMode = False) Then
Call MsgBox("valeur pour OFF_Transparence incorrecte" & vbCrLf & _
"la valeur doit être comprise entre 0 et 100", vbOKOnly + vbExclamation, _
"Bouton ++ : parametre incorrect")
End If
Else
e_OFF.transparence = nwValue
PropertyChanged "OFF_Transparence"
Call Affichage
End If
End Property
'######################################################
Public Property Get OFF_Couleur_1() As OLE_COLOR
OFF_Couleur_1 = e_OFF.couleur_1
End Property
Public Property Let OFF_Couleur_1(nwValue As OLE_COLOR)
e_OFF.couleur_1 = nwValue
PropertyChanged "OFF_Couleur_1"
Call Affichage
End Property
'######################################################
Public Property Get OFF_Couleur_2() As OLE_COLOR
OFF_Couleur_2 = e_OFF.couleur_2
End Property
Public Property Let OFF_Couleur_2(nwValue As OLE_COLOR)
e_OFF.couleur_2 = nwValue
PropertyChanged "OFF_Couleur_2"
Call Affichage
End Property
'######################################################
Public Property Get OFF_Couleur_3() As OLE_COLOR
OFF_Couleur_3 = e_OFF.couleur_3
End Property
Public Property Let OFF_Couleur_3(nwValue As OLE_COLOR)
e_OFF.couleur_3 = nwValue
PropertyChanged "OFF_Couleur_3"
Call Affichage
End Property
'######################################################
Public Property Get OFF_Couleur_4() As OLE_COLOR
OFF_Couleur_4 = e_OFF.couleur_4
End Property
Public Property Let OFF_Couleur_4(nwValue As OLE_COLOR)
e_OFF.couleur_4 = nwValue
PropertyChanged "OFF_Couleur_4"
Call Affichage
End Property
'######################################################
Public Property Get OFF_Position_Millieu() As Double
OFF_Position_Millieu = e_OFF.position_m
End Property
Public Property Let OFF_Position_Millieu(nwValue As Double)
If ((nwValue < 0) Or (nwValue > 100)) Then
'Valeur incorrecte
If (UserControl.Ambient.UserMode = False) Then
Call MsgBox("valeur pour OFF_Position_Millieu incorrecte" & vbCrLf & _
"la valeur doit être comprise entre 0 et 100", vbOKOnly + vbExclamation, _
"Bouton ++ : parametre incorrect")
End If
Else
e_OFF.position_m = nwValue
PropertyChanged "OFF_Position_Millieu"
Call Affichage
End If
End Property
'######################################################
Public Property Get OFF_Bordure_Largeur() As Double
OFF_Bordure_Largeur = e_OFF.bordure_l
End Property
Public Property Let OFF_Bordure_Largeur(nwValue As Double)
If ((nwValue < 0) Or (nwValue > 100)) Then
'Valeur incorrecte
If (UserControl.Ambient.UserMode = False) Then
Call MsgBox("valeur pour OFF_Bordure_Largeur" & vbCrLf & _
"la valeur doit être comprise entre 0 et 100", vbOKOnly + vbExclamation, _
"Bouton ++ : parametre incorrect")
End If
Else
e_OFF.bordure_l = nwValue
PropertyChanged "OFF_Bordure_Largeur"
Call Affichage
End If
End Property
Public Property Get OFF_Bordure_Hauteur() As Double
OFF_Bordure_Hauteur = e_OFF.bordure_h
End Property
Public Property Let OFF_Bordure_Hauteur(nwValue As Double)
If ((nwValue < 0) Or (nwValue > 100)) Then
'Valeur incorrecte
If (UserControl.Ambient.UserMode = False) Then
Call MsgBox("valeur pour OFF_Bordure_Hauteur" & vbCrLf & _
"la valeur doit être comprise entre 0 et 100", vbOKOnly + vbExclamation, _
"Bouton ++ : parametre incorrect")
End If
Else
e_OFF.bordure_h = nwValue
PropertyChanged "OFF_Bordure_Hauteur"
Call Affichage
End If
End Property
'######################################################
Public Property Get OFF_Bordure_Couleur() As OLE_COLOR
OFF_Bordure_Couleur = e_OFF.couleur_brd
End Property
Public Property Let OFF_Bordure_Couleur(nwValue As OLE_COLOR)
e_OFF.couleur_brd = nwValue
PropertyChanged "OFF_Bordure_Couleur"
Call Affichage
End Property
'######################################################
Public Property Get OFF_Bordure_Epaisseur() As Long
OFF_Bordure_Epaisseur = e_OFF.bordure_epp
End Property
Public Property Let OFF_Bordure_Epaisseur(nwValue As Long)
e_OFF.bordure_epp = nwValue
PropertyChanged "OFF_Bordure_Epaisseur"
Call Affichage
End Property
'######################################################
Public Property Get OFF_Couleur_Texte() As OLE_COLOR
OFF_Couleur_Texte = e_OFF.couleur_texte
End Property
Public Property Let OFF_Couleur_Texte(nwValue As OLE_COLOR)
e_OFF.couleur_texte = nwValue
PropertyChanged "OFF_Couleur_Texte"
Call Affichage
End Property
'######################################################
'######################################################
'######################################################
'######################################################
' Propriétés d'apparence d' OVER
'######################################################
Public Property Get OVER_Transparence() As Double
OVER_Transparence = e_OVER.transparence
End Property
Public Property Let OVER_Transparence(nwValue As Double)
If ((nwValue < 0) Or (nwValue > 100)) Then
'Valeur incorrecte
If (UserControl.Ambient.UserMode = False) Then
Call MsgBox("valeur pour OVER_Transparence incorrecte" & vbCrLf & _
"la valeur doit être comprise entre 0 et 100", vbOKOnly + vbExclamation, _
"Bouton ++ : parametre incorrect")
End If
Else
e_OVER.transparence = nwValue
PropertyChanged "OVER_Transparence"
Call Affichage
End If
End Property
'######################################################
Public Property Get OVER_Couleur_1() As OLE_COLOR
OVER_Couleur_1 = e_OVER.couleur_1
End Property
Public Property Let OVER_Couleur_1(nwValue As OLE_COLOR)
e_OVER.couleur_1 = nwValue
PropertyChanged "OVER_Couleur_1"
Call Affichage
End Property
'######################################################
Public Property Get OVER_Couleur_2() As OLE_COLOR
OVER_Couleur_2 = e_OVER.couleur_2
End Property
Public Property Let OVER_Couleur_2(nwValue As OLE_COLOR)
e_OVER.couleur_2 = nwValue
PropertyChanged "OVER_Couleur_2"
Call Affichage
End Property
'######################################################
Public Property Get OVER_Couleur_3() As OLE_COLOR
OVER_Couleur_3 = e_OVER.couleur_3
End Property
Public Property Let OVER_Couleur_3(nwValue As OLE_COLOR)
e_OVER.couleur_3 = nwValue
PropertyChanged "OVER_Couleur_3"
Call Affichage
End Property
'######################################################
Public Property Get OVER_Couleur_4() As OLE_COLOR
OVER_Couleur_4 = e_OVER.couleur_4
End Property
Public Property Let OVER_Couleur_4(nwValue As OLE_COLOR)
e_OVER.couleur_4 = nwValue
PropertyChanged "OVER_Couleur_4"
Call Affichage
End Property
'######################################################
Public Property Get OVER_Position_Millieu() As Double
OVER_Position_Millieu = e_OVER.position_m
End Property
Public Property Let OVER_Position_Millieu(nwValue As Double)
If ((nwValue < 0) Or (nwValue > 100)) Then
'Valeur incorrecte
If (UserControl.Ambient.UserMode = False) Then
Call MsgBox("valeur pour OVER_Position_Millieu incorrecte" & vbCrLf & _
"la valeur doit être comprise entre 0 et 100", vbOKOnly + vbExclamation, _
"Bouton ++ : parametre incorrect")
End If
Else
e_OVER.position_m = nwValue
PropertyChanged "OVER_Position_Millieu"
Call Affichage
End If
End Property
'######################################################
Public Property Get OVER_Bordure_Largeur() As Double
OVER_Bordure_Largeur = e_OVER.bordure_l
End Property
Public Property Let OVER_Bordure_Largeur(nwValue As Double)
If ((nwValue < 0) Or (nwValue > 100)) Then
'Valeur incorrecte
If (UserControl.Ambient.UserMode = False) Then
Call MsgBox("valeur pour OVER_Bordure_Largeur" & vbCrLf & _
"la valeur doit être comprise entre 0 et 100", vbOKOnly + vbExclamation, _
"Bouton ++ : parametre incorrect")
End If
Else
e_OVER.bordure_l = nwValue
PropertyChanged "OVER_Bordure_Largeur"
Call Affichage
End If
End Property
Public Property Get OVER_Bordure_Hauteur() As Double
OVER_Bordure_Hauteur = e_OVER.bordure_h
End Property
Public Property Let OVER_Bordure_Hauteur(nwValue As Double)
If ((nwValue < 0) Or (nwValue > 100)) Then
'Valeur incorrecte
If (UserControl.Ambient.UserMode = False) Then
Call MsgBox("valeur pour OVER_Bordure_Hauteur" & vbCrLf & _
"la valeur doit être comprise entre 0 et 100", vbOKOnly + vbExclamation, _
"Bouton ++ : parametre incorrect")
End If
Else
e_OVER.bordure_h = nwValue
PropertyChanged "OVER_Bordure_Hauteur"
Call Affichage
End If
End Property
'######################################################
Public Property Get OVER_Bordure_Couleur() As OLE_COLOR
OVER_Bordure_Couleur = e_OVER.couleur_brd
End Property
Public Property Let OVER_Bordure_Couleur(nwValue As OLE_COLOR)
e_OVER.couleur_brd = nwValue
PropertyChanged "OVER_Bordure_Couleur"
Call Affichage
End Property
'######################################################
Public Property Get OVER_Bordure_Epaisseur() As Long
OVER_Bordure_Epaisseur = e_OVER.bordure_epp
End Property
Public Property Let OVER_Bordure_Epaisseur(nwValue As Long)
e_OVER.bordure_epp = nwValue
PropertyChanged "OVER_Bordure_Epaisseur"
Call Affichage
End Property
'######################################################
Public Property Get OVER_Couleur_Texte() As OLE_COLOR
OVER_Couleur_Texte = e_OVER.couleur_texte
End Property
Public Property Let OVER_Couleur_Texte(nwValue As OLE_COLOR)
e_OVER.couleur_texte = nwValue
PropertyChanged "OVER_Couleur_Texte"
Call Affichage
End Property
'######################################################
'######################################################
'######################################################
'######################################################
' Propriétés d'apparence d' ON
'######################################################
Public Property Get ON_Transparence() As Double
ON_Transparence = e_ON.transparence
End Property
Public Property Let ON_Transparence(nwValue As Double)
If ((nwValue < 0) Or (nwValue > 100)) Then
'Valeur incorrecte
If (UserControl.Ambient.UserMode = False) Then
Call MsgBox("valeur pour ON_Transparence incorrecte" & vbCrLf & _
"la valeur doit être comprise entre 0 et 100", vbOKOnly + vbExclamation, _
"Bouton ++ : parametre incorrect")
End If
Else
e_ON.transparence = nwValue
PropertyChanged "ON_Transparence"
Call Affichage
End If
End Property
'######################################################
Public Property Get ON_Couleur_1() As OLE_COLOR
ON_Couleur_1 = e_ON.couleur_1
End Property
Public Property Let ON_Couleur_1(nwValue As OLE_COLOR)
e_ON.couleur_1 = nwValue
PropertyChanged "ON_Couleur_1"
Call Affichage
End Property
'######################################################
Public Property Get ON_Couleur_2() As OLE_COLOR
ON_Couleur_2 = e_ON.couleur_2
End Property
Public Property Let ON_Couleur_2(nwValue As OLE_COLOR)
e_ON.couleur_2 = nwValue
PropertyChanged "ON_Couleur_2"
Call Affichage
End Property
'######################################################
Public Property Get ON_Couleur_3() As OLE_COLOR
ON_Couleur_3 = e_ON.couleur_3
End Property
Public Property Let ON_Couleur_3(nwValue As OLE_COLOR)
e_ON.couleur_3 = nwValue
PropertyChanged "ON_Couleur_3"
Call Affichage
End Property
'######################################################
Public Property Get ON_Couleur_4() As OLE_COLOR
ON_Couleur_4 = e_ON.couleur_4
End Property
Public Property Let ON_Couleur_4(nwValue As OLE_COLOR)
e_ON.couleur_4 = nwValue
PropertyChanged "ON_Couleur_4"
Call Affichage
End Property
'######################################################
Public Property Get ON_Position_Millieu() As Double
ON_Position_Millieu = e_ON.position_m
End Property
Public Property Let ON_Position_Millieu(nwValue As Double)
If ((nwValue < 0) Or (nwValue > 100)) Then
'Valeur incorrecte
If (UserControl.Ambient.UserMode = False) Then
Call MsgBox("valeur pour ON_Position_Millieu incorrecte" & vbCrLf & _
"la valeur doit être comprise entre 0 et 100", vbOKOnly + vbExclamation, _
"Bouton ++ : parametre incorrect")
End If
Else
e_ON.position_m = nwValue
PropertyChanged "ON_Position_Millieu"
Call Affichage
End If
End Property
'######################################################
Public Property Get ON_Bordure_Largeur() As Double
ON_Bordure_Largeur = e_ON.bordure_l
End Property
Public Property Let ON_Bordure_Largeur(nwValue As Double)
If ((nwValue < 0) Or (nwValue > 100)) Then
'Valeur incorrecte
If (UserControl.Ambient.UserMode = False) Then
Call MsgBox("valeur pour ON_Bordure_Largeur" & vbCrLf & _
"la valeur doit être comprise entre 0 et 100", vbOKOnly + vbExclamation, _
"Bouton ++ : parametre incorrect")
End If
Else
e_ON.bordure_l = nwValue
PropertyChanged "ON_Bordure_Largeur"
Call Affichage
End If
End Property
Public Property Get ON_Bordure_Hauteur() As Double
ON_Bordure_Hauteur = e_ON.bordure_h
End Property
Public Property Let ON_Bordure_Hauteur(nwValue As Double)
If ((nwValue < 0) Or (nwValue > 100)) Then
'Valeur incorrecte
If (UserControl.Ambient.UserMode = False) Then
Call MsgBox("valeur pour ON_Bordure_Hauteur" & vbCrLf & _
"la valeur doit être comprise entre 0 et 100", vbOKOnly + vbExclamation, _
"Bouton ++ : parametre incorrect")
End If
Else
e_ON.bordure_h = nwValue
PropertyChanged "ON_Bordure_Hauteur"
Call Affichage
End If
End Property
'######################################################
Public Property Get ON_Bordure_Couleur() As OLE_COLOR
ON_Bordure_Couleur = e_ON.couleur_brd
End Property
Public Property Let ON_Bordure_Couleur(nwValue As OLE_COLOR)
e_ON.couleur_brd = nwValue
PropertyChanged "ON_Bordure_Couleur"
Call Affichage
End Property
'######################################################
Public Property Get ON_Bordure_Epaisseur() As Long
ON_Bordure_Epaisseur = e_ON.bordure_epp
End Property
Public Property Let ON_Bordure_Epaisseur(nwValue As Long)
e_ON.bordure_epp = nwValue
PropertyChanged "ON_Bordure_Epaisseur"
Call Affichage
End Property
'######################################################
Public Property Get ON_Couleur_Texte() As OLE_COLOR
ON_Couleur_Texte = e_ON.couleur_texte
End Property
Public Property Let ON_Couleur_Texte(nwValue As OLE_COLOR)
e_ON.couleur_texte = nwValue
PropertyChanged "ON_Couleur_Texte"
Call Affichage
End Property
'######################################################
'######################################################
'######################################################
'######################################################
' Gestion du type t_etat
'######################################################
Private Function new_ETAT(pos_m As Double, coul_1 As Long, coul_2 As Double, coul_3 As Long, coul_4 As Long, _
brd_l As Double, brd_h As Double, brd_epp As Long, coul_brd As Long, Optional coul_texte As Long = vbBlack, _
Optional transp As Double = 0) As t_ETAT
With new_ETAT
.position_m = pos_m
.couleur_1 = coul_1
.couleur_2 = coul_2
.couleur_3 = coul_3
.couleur_4 = coul_4
.bordure_h = brd_h
.bordure_l = brd_l
.bordure_epp = brd_epp
.couleur_brd = coul_brd
.couleur_texte = coul_texte
.transparence = transp
End With
End Function
'######################################################
Private Sub Save_ETAT(nom As String, Ett As t_ETAT, PropBag As PropertyBag)
With PropBag
.WriteProperty nom & "_pos", Ett.position_m
.WriteProperty nom & "_coul_1", Ett.couleur_1
.WriteProperty nom & "_coul_2", Ett.couleur_2
.WriteProperty nom & "_coul_3", Ett.couleur_3
.WriteProperty nom & "_coul_4", Ett.couleur_4
.WriteProperty nom & "_brd_l", Ett.bordure_l
.WriteProperty nom & "_brd_h", Ett.bordure_h
.WriteProperty nom & "_brd_epp", Ett.bordure_epp
.WriteProperty nom & "_brd_coul", Ett.couleur_brd
.WriteProperty nom & "_coul_texte", Ett.couleur_texte
.WriteProperty nom & "_trsp", Ett.transparence
End With
End Sub
Private Sub Load_ETAT(ByRef Ett As t_ETAT, nom As String, PropBag As PropertyBag)
With Ett
.position_m = PropBag.ReadProperty(nom & "_pos", 30)
.couleur_1 = PropBag.ReadProperty(nom & "_coul_1", vbWhite)
.couleur_2 = PropBag.ReadProperty(nom & "_coul_2", vbBlack)
.couleur_3 = PropBag.ReadProperty(nom & "_coul_3", vbBlack)
.couleur_4 = PropBag.ReadProperty(nom & "_coul_4", vbBlack)
.bordure_l = PropBag.ReadProperty(nom & "_brd_l", 20)
.bordure_h = PropBag.ReadProperty(nom & "_brd_h", 20)
.bordure_epp = PropBag.ReadProperty(nom & "_brd_epp", 0)
.couleur_brd = PropBag.ReadProperty(nom & "_brd_coul", vbWhite)
.couleur_texte = PropBag.ReadProperty(nom & "_coul_texte", vbBlack)
.transparence = PropBag.ReadProperty(nom & "_trsp", 0)
End With
End Sub
'######################################################
'######################################################
'############################################################################################################
' Affichage sur l'intégralité du bouton en fonction d'un état
'############################################################################################################
Private Sub Affichage()
If (p_etat = eETAT.e_OVER) Then
Call Dessiner(e_OVER)
ElseIf (p_etat = eETAT.e_ON) Then
Call Dessiner(e_ON)
Else
Call Dessiner(e_OFF)
End If
End Sub
Private Sub Dessiner(Ett As t_ETAT)
On Error Resume Next
'Gérer les dimensions et positions en fonction du scale mode du parent pour tout avoir en pxl
Dim m_top As Long: m_top = UserControl.ScaleY(UserControl.Extender.Top, UserControl.Parent.ScaleMode, vbPixels)
Dim m_left As Long: m_left = UserControl.ScaleX(UserControl.Extender.Left, UserControl.Parent.ScaleMode, vbPixels)
Dim brd_l As Long: brd_l = (UserControl.ScaleWidth * Ett.bordure_l) / 200
Dim brd_h As Long: brd_h = (UserControl.ScaleHeight * Ett.bordure_h) / 200
Dim haut_millieu As Long: haut_millieu = (UserControl.ScaleHeight * Ett.position_m) / 100
'###########################################################################################
' Créer un bitmap pour buffuriser et ainsi eviter des clignotements
'###########################################################################################
Dim DC1 As Long: DC1 = GetDC(0)
Dim DC2 As Long: DC2 = GetDC(0)
Dim DC3 As Long: DC3 = GetDC(0)
Dim vDC As Long: vDC = CreateCompatibleDC(DC1)
Dim vDC_2 As Long: vDC_2 = CreateCompatibleDC(DC2) 'il faut 2 DC pour pouvoir copier d'un BMPa l'autre
Dim vBMP_buff As Long: vBMP_buff = CreateCompatibleBitmap(DC3, UserControl.ScaleWidth, UserControl.ScaleHeight)
Dim vBMP_mix As Long: vBMP_mix = CreateCompatibleBitmap(DC3, UserControl.ScaleWidth, UserControl.ScaleHeight)
Dim vBMP_grad As Long: vBMP_grad = CreateCompatibleBitmap(DC3, 1, UserControl.ScaleHeight)
Dim holdBMP_1 As Long: holdBMP_1 = SelectObject(vDC, vBMP_buff)
Dim holdBMP_2 As Long: holdBMP_2 = SelectObject(vDC_2, vBMP_mix)
'###########################################################################################
'------------------------------------------------------
'CREER LA REGION
'------------------------------------------------------
Dim hRgn As Long
hRgn = CreateRoundRectRgn(1, 1, UserControl.ScaleWidth, UserControl.ScaleHeight, brd_l, brd_h)
'------------------------------------------------------
'------------------------------------------------------
'AFFICHER LES ANGLES SUR LE BUFFEUR
'------------------------------------------------------
Call SelectObject(vDC, vBMP_buff)
Dim Res1 As Long 'afficher le fond
Res1 = BitBlt(vDC, _
0, 0, _
UserControl.ScaleWidth, UserControl.ScaleHeight, _
UserControl.Parent.hDC, _
m_left, m_top, _
vbSrcCopy)
'vider le centre (mettre tout noir =&h000000)
Dim hBrush As Long: hBrush = CreateSolidBrush(vbBlack)
Call FillRgn(vDC, hRgn, hBrush)
Call DeleteObject(hBrush)
'------------------------------------------------------
'------------------------------------------------------
'TRACER LE DEGRADER SUR UNE COLONE
'------------------------------------------------------
Call SelectObject(vDC, vBMP_grad)
'Tracer le dégrader entre "Haut" et "Milieu"
Call Grad_Rect(vDC, _
0, 0, _
Ett.couleur_1, _
1, haut_millieu, _
Ett.couleur_2, _
1) '1 = vertical
'Tracer le dégrader entre "Millieu" et "Bas"
Call Grad_Rect(vDC, _
0, haut_millieu, _
Ett.couleur_3, _
1, UserControl.ScaleHeight, _
Ett.couleur_4, _
1) '1=vertical
'------------------------------------------------------
'------------------------------------------------------
'remplir le millieu du mix
'------------------------------------------------------
Call SelectObject(vDC, vBMP_grad)
Call SelectObject(vDC_2, vBMP_mix)
'remplir le centre (mettre tout blanc =&hFFFFFF)
hBrush = CreateSolidBrush(vbWhite)
Call FillRgn(vDC_2, hRgn, hBrush)
Call DeleteObject(hBrush)
'appliquer le dégrader
Dim res2 As Long
res2 = StretchBlt(vDC_2, _
0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, _
vDC, _
0, 0, 1, UserControl.ScaleHeight, _
vbSrcAnd)
'------------------------------------------------------
'###########################################################################################
' Afficher le texte (doit se faire par DC ;( )
'###########################################################################################
Call SelectObject(vDC_2, vBMP_mix)
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(vDC_2, hFont)
'Gérer la position du texte
Dim TextSize As POINTAPI 'trouver la hauteur et la largeur en pixel
Call GetTextExtentPoint32(vDC_2, p_caption, Len(p_caption), 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(vDC_2, Ett.couleur_texte) 'définir la couleur de la police
Call SetBkMode(vDC_2, TRANSPARENT) 'l'arriere est transparent ( sinon carré blanc)
Call TextOut(vDC_2, Left_Str, Top_Str, p_caption, Len(p_caption)) 'tracer
Call SelectObject(vDC_2, hOldFont) 'obligatoire pour ne pas avoir de fuites mémoire
Call DeleteObject(hFont) 'détruire l'objet Font
'###########################################################################################
'------------------------------------------------------
'appliquer les coins
'------------------------------------------------------
Call SelectObject(vDC, vBMP_buff)
Call SelectObject(vDC_2, vBMP_mix)
Dim Res3 As Long
Res3 = BitBlt(vDC_2, _
0, 0, _
UserControl.ScaleWidth, UserControl.ScaleHeight, _
vDC, _
0, 0, _
vbSrcPaint)
'------------------------------------------------------
'###########################################################################################
' Appliquer la transparence
'###########################################################################################
Call SelectObject(vDC_2, vBMP_mix)
Dim BF As BLENDFUNCTION, lBF As Long
BF.SourceConstantAlpha = Ett.transparence * 255 / 100
Call RtlMoveMemory(lBF, BF, 4)
Call AlphaBlend _
( _
vDC_2, _
0, 0, _
UserControl.ScaleWidth, UserControl.ScaleHeight, _
UserControl.Parent.hDC, _
m_left, m_top, _
UserControl.ScaleWidth, UserControl.ScaleHeight, _
lBF _
)
'###########################################################################################
'------------------------------------------------------
'Appliquer le bitmap au control
'------------------------------------------------------
Call SelectObject(vDC_2, vBMP_mix)
Dim Res4 As Long
Res4 = BitBlt(UserControl.hDC, _
0, 0, _
UserControl.ScaleWidth, UserControl.ScaleHeight, _
vDC_2, _
0, 0, _
vbSrcCopy)
'------------------------------------------------------
'###########################################################################################
' Libérer les objets
'###########################################################################################
Call DeleteObject(hRgn) 'libérer la région
Call SelectObject(vDC, holdBMP_1)
Call SelectObject(vDC_2, holdBMP_2)
Call DeleteObject(vBMP_grad)
Call DeleteObject(vBMP_buff)
Call DeleteObject(vBMP_mix)
Call DeleteDC(vDC)
Call DeleteDC(vDC_2)
Call ReleaseDC(0, DC3)
Call ReleaseDC(0, DC2)
Call ReleaseDC(0, DC1)
'###########################################################################################
End Sub
'############################################################################################################
'############################################################################################################
Conclusion :
Il reste quelques petites choses qui ne me satisfont pas, si des personnes connaissent la solution :
L'arriere plan des bouton ne correspond pas a ce qu'il y a derière mais a la form contenante.
par exemple, si je place un bouton sur un Frame Jaune placé sur un frame gris, les bords du bouton serront gris au lieu d'êtres jaunes ;( ...
De même, si un bouton est partielement sur un autre objet cet objet ne serra pas pris en compte pour la transparence...
Garantis sans fuite mémoire
Codes Sources
A voir également
- Controls ++(controls graphiques en construction)
- Ed controls ✓ - Forum Visual Basic 6
- Réponse examen asp construction ✓ - Forum C / C++ / C++.NET
- Construction d'une pyramide france ioi ✓ - Forum Python
- Microsoft windows common controls-2 6.0 - Forum VB.NET
- Microsoft Windows Common Controls 6.0 - Forum Visual Basic
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.