Controls ++(controls graphiques en construction)

Soyez le premier à donner votre avis sur cette source.

Vue 6 652 fois - Téléchargée 741 fois

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,

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

Ajouter un commentaire

Commentaires

bbsoft
Messages postés
4
Date d'inscription
jeudi 3 avril 2008
Statut
Membre
Dernière intervention
26 juillet 2015
-
Salutations,
Tout d'abord je te félicite pour ton travail et collaboration énorme que tu fais, je ne sais pas si tu consultes encore tes messages, mais je l'espère bien.
voilà: j'ai développé une application énorme qui m'a pris beaucoup d'années, dans ma fenêtre principale j'avais un menu déroulant style windows. quand j'ai vu tes boutons ++, j'ai eu l'idée de les utiliser comme menu principal.
j'ai beaucoup de bug (fenêtres blanches avec "... a cessé de fonctionner de windows 7".
ma question: est ce que le blocage est-il du aux boutons graphiques, si oui avez-vous une maj qui corrige le problème.
Merci et bonne continuation.
Flocreate
Messages postés
307
Date d'inscription
lundi 17 juillet 2006
Statut
Membre
Dernière intervention
27 mai 2012
3 -
bon, avec ces dernieres mises a jour, je trouve que ca a vraiment de la gueule ;)
j'atends vos critiques avec impassience.
Flocreate
Messages postés
307
Date d'inscription
lundi 17 juillet 2006
Statut
Membre
Dernière intervention
27 mai 2012
3 -
http://www.vbfrance.com/forum/sujet-ENREGISTREMENT-DANS-FICHIER-LOGIGRAMME-DESSINE-DANS-PICTUREBOX_1159298.aspx
cependant, je ne comprends pas les paramaitres a utiliser .
dois-je me placer du côté du composant en demandant son parent ou bien au niveau du parent et demander les enfants. en tous les cas je n'arrive pas a ne pas avoir le composant lui même.
ce qui au final fait que ca ne marche pas.
Flocreate
Messages postés
307
Date d'inscription
lundi 17 juillet 2006
Statut
Membre
Dernière intervention
27 mai 2012
3 -
pour le momment j'ai abandonné le principe d'utiliser une PictureBox
je me suis repenché sur le Usercontrol unique

originellement j'utilisait le DC du ".Parent" en fait je viens de voir que le ".Extender.Container" serrait déja mieux ^^
'#######################################################################################
Dim m_t As Long: m_t = UserControl.ScaleY(UserControl.Extender.Top, UserControl.Extender.Container.ScaleMode, vbPixels)
Dim m_l As Long: m_l = UserControl.ScaleX(UserControl.Extender.Left, UserControl.Extender.Container.ScaleMode, vbPixels)

Dim Res1 As Long
Res1 = BitBlt(UserControl.hDC, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, _
UserControl.Extender.Container.hDC, m_l, m_t, _
vbSrcCopy)
'#######################################################################################

la solution que j'envisage n'ai a mon avis pas tres propre mais voyons voir quand même ^^ :
- faire la liste des contrôls contenus par le conteneur.
- trouver les Plans (qui est au dessus de qui)
- récupérer les dc de chacun (pour ceux présents sur la zone souhaitée)
- ajouter chaque dc successivement
Ainsi, on retrouverait bien l'arriere plan

premiere chose sur laquelle je bloque : connaitre les diférentes position (plan) des composants les uns par rapport aux autres. Ceci dans la mesure ou il semblerait que le ZOrder est un "Sub" et non un "Property"
Renfield
Messages postés
17280
Date d'inscription
mercredi 2 janvier 2002
Statut
Modérateur
Dernière intervention
21 juillet 2019
58 -
pour le fond, le "truc" c'est que le parent ne dessine pas la zone située sous le UserControl.
ca permet de s'economiser cela (voir ClipRegion, pour de la théorie)

tu as bien un moyen, c'est de demander un DC particulier, n'incluant pas de ClipRegion

voir GetDCEx

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.