XL 2021 Colorer 1ère ligne Combobox (vba)

[Claudinedu13]

Bonjour, j'ai une combobox dans un formulaire

Function items_civilites()
ComboBox2.AddItem "..."
ComboBox2.AddItem "Monsieur"
ComboBox2.AddItem "Madame"
ComboBox2.AddItem "Société"
End Function

Est il possible de colorer la première ligne ...

 

[patricktoulon]

Re le Wingdings 3 avec "Q" ou "q" ne fonctionne pas sur les labels

 

[patricktoulon]

C'est sûr, et c'est plus "élégant".
Comme c'est une question qui revient souvent, ça pourrait faire l'objet d'une ressource en ajustant les hauteurs approximativement selon la Font.Size à moins de pouvoir récupérer la hauteur de la DropDown area en mode éclair en API. Je crois qu'on avait fait ça pour le Scroll ComboBox.

il me semble en effet

 

[Dudu2]

 

[patricktoulon]

ok en Wingdings 3 c'est le chrw(81)

 

[patricktoulon]

fait le en dynamique tu verra

 

[patricktoulon]

c'est etonnant c'est le même que "Q"

 

[patricktoulon]

ok en dynamique il faut un doevent entre .caption="Q" et .font.name="Wingdings 3"

 

[patricktoulon]

re
le code un peu commenté

Option Explicit
Public WithEvents drpb As msforms.Label 'event du faux dropbutton
Public WithEvents ItemX As msforms.Label 'event des item dans la frame
Public WithEvents formX As UserForm 'event du userform
Public uf As Object 'object userform en variable object ne gère pas les events
Public framm As Object 'object frame en variable object ne gère pas les events
Public comBB As Object 'object combobox en variable object ne gère pas les events
Public fait As Boolean 'on le fait qu'une fois
Dim cl(0 To 100) As New ComBoTransform 'array des instance de classe(la fleme de faire un redim preserve )
Public Function transforme(comb As Object, uf)
    Dim i&, Fram, It, dropbutton, pict As IPicture
   If Me.fait Then Exit Function
    fait = True
   
    Set Fram = uf.Controls.Add("Forms.Frame.1", "fond") 'ajoute la frame
    Set dropbutton = uf.Controls.Add("Forms.Label.1", "dropbutton") 'ajoute le faux dropbutton
    comb.ShowDropButtonWhen = 0 'on masque le vrai dropbutton
    With dropbutton 'avec le faux dropbutton
        .Height = comb.Height - 1
        .Width = 13
        .Font.Name = "Wingdings 3"
        DoEvents
        .Caption = "q"
        .Font.Bold = True
        .Left = comb.Left + comb.Width - .Width - 2
        .Top = comb.Top
        .TextAlign = 2
        .BorderStyle = 1
    End With
    comb.Width = comb.Width - 15 'on enleve le width du dropbutton a la comboboxsinon elle masquera toujours le label
    With Fram 'properties frames
        .Width = comb.Width + 15
        .Left = comb.Left
        .Height = comb.ListRows * 13
        .Top = comb.Top + comb.Height
        .ScrollBars = 2
        .Visible = False
        .BorderStyle = 1
        For i = 0 To comb.ListCount - 1 'boucle sur les item de la combo
            With cl(i) 'ajoute chaque element dans chaque instance de classe
                Set .drpb = dropbutton               'gère un event
                Set .uf = uf 'ne gère pas d'évent
                Set .framm = Fram 'ne gère pas d'évent
                Set .comBB = comb 'ne gère pas d'évent
                Set .formX = uf                     ' gère  d'évent
            End With
            Set It = .Controls.Add("Forms.Label.1", "It" & i)
            With It
                .Caption = comb.List(i)
                .Width = Fram.Width
                .Height = 13
                .BorderStyle = 0
                .BackColor = Array(vbGreen, vbYellow)(Abs(i Mod 2 = 0))
                .Top = 15 * i
                .Left = 2
                .Font.Name = "verdana"
            End With
            Set cl(i).ItemX = It 'gère un event
        Next
        .ScrollHeight = comb.ListCount * (It.Height + 2)
    End With
End Function

'LES EVENTS
Private Sub formX_Click(): framm.Visible = False: End Sub
Private Sub drpb_Click(): framm.Visible = True: framm.ScrollTop = 0: End Sub
Private Sub ItemX_Click(): comBB.Value = ItemX.Caption: framm.Visible = False: End Sub

 

[Dudu2]

Ok, si je fais une ressource (pour l'instant j'ai des trucs à faire pour un utilisateur), je m'en inspirerai directement.

 

[patricktoulon]

re
j'ai remplacé par un bouton ca s'accorde mieux le text est centré

Option Explicit
Public WithEvents drpb As msforms.CommandButton    'event du faux dropbutton
Public WithEvents ItemX As msforms.Label    'event des item dans la frame
Public WithEvents formX As UserForm    'event du userform
Public uf As Object    'object userform en variable object ne gère pas les events
Public framm As Object    'object frame en variable object ne gère pas les events
Public comBB As Object    'object combobox en variable object ne gère pas les events
Public fait As Boolean    'on le fait qu'une fois
Dim cl(0 To 100) As New ComBoTransform    'array des instance de classe
Public Function transforme(comb As Object, uf)
    Dim i&, Fram, It, dropbutton, pict As IPicture
    If Me.fait Then Exit Function
    fait = True

     comb.ShowDropButtonWhen = 0    'on masque le vrai dropbutton
     
      'ajoute le faux dropbutton
     Set dropbutton = uf.Controls.Add("Forms.CommandButton.1", "dropbutton")
   With dropbutton    'avec le faux dropbutton
        .Height = comb.Height - 1
        .Width = 16
        .Font.Name = "Wingdings 3"
        DoEvents
        .Caption = "q"
        .Font.Bold = True
        .Font.Size = 6
        .Left = comb.Left + comb.Width - .Width
        .Top = comb.Top
    End With
    comb.Width = comb.Width - 15    'on enleve le width du dropbutton a la comboboxsinon elle masquera toujours le label
   
  'ajoute la frame
  Set Fram = uf.Controls.Add("Forms.Frame.1", "fond")
    With Fram    'properties frames
        .Width = comb.Width + 15
        .Left = comb.Left
        .Height = comb.ListRows * 13
        .Top = comb.Top + comb.Height
        .ScrollBars = 2
        .Visible = False
        .BorderStyle = 1
        For i = 0 To comb.ListCount - 1    'boucle sur les item de la combo
            With cl(i)    'ajoute chaque element dans chaque instance de classe
                Set .drpb = dropbutton               'gère un event
                Set .uf = uf    'ne gère pas d'évent
                Set .framm = Fram    'ne gère pas d'évent
                Set .comBB = comb    'ne gère pas d'évent
                Set .formX = uf                     ' gère  d'évent
            End With
            Set It = .Controls.Add("Forms.Label.1", "It" & i) 'ajoute le label dans la frame
            With It
                .Caption = comb.List(i)
                .Width = Fram.Width
                .Height = 13
                .BorderStyle = 0
                .BackColor = Array(vbGreen, vbYellow)(Abs(i Mod 2 = 0))
                .Top = 15 * i
                .Left = 2
                .Font.Name = "verdana"
                .Font.Size = 12
            End With
            Set cl(i).ItemX = It    'gère un event
        Next
        .ScrollHeight = comb.ListCount * (It.Height + 2)
    End With
End Function

Private Sub formX_Click(): framm.Visible = False: End Sub
Private Sub drpb_Click(): framm.Visible = True: framm.ScrollTop = 0: End Sub
Private Sub ItemX_Click(): comBB.Value = ItemX.Caption: framm.Visible = False: End Sub

j'avais fait même mieux que ça à l'epoque
j'utilisait le même nombre de label que du listrows et une scrollbar dans la frame
autrement pour 2 item ou 1000 je n'avais que nombre du listrows d'instance de classe
beaucoup plus rapide moins lourd etc....