Combobox haut en couleur juste et encore pour le fun

**patricktoulon** · 24/05/2017, 10h18

re
l'eerur de tronquage est en fait tres simple
j'ai tenu a avoir exactement le meme height que l'original je me suis donc préoccupé des height des labels sauf que la scroll de la framme fait 11.8 et celle de la combo 10.4
j'ai donc accepter que la combofake soit plus grande en terme de height
nous avons aussi la position du texte dans les cellules les propriétés des cellules(labels) n'offre pas autant d'option que les textboxs par exemple
pour la scroll verticale je peut reduire et modifier sa position
pour le bouton je vais essayer une astuce a moi pour te l'imiter a l'identique
j'avais essayé un label avec la lettre q en "wingdings" mais visiblement le label n'accepte pas ce font je ne sais pourquoi
pour les valeurs renvoyées on peu largement arranger au besoins et même paramétrer cela pour un retour au choix

quand j'aurais réglé tout ces petit détails je montrerais a unparia comment je m'en sert 10 fois dans le même userform ou 36 userform et sans Module standard

**pijaku** · 24/05/2017, 10h23

j'avais essayé un label avec la lettre q en "wingdings" mais visiblement le label n'accepte pas ce font je ne sais pourquoi

Sissi !
Il suffit de remplir le caption après avoir réglé ta Font :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
     With Label1
        .Font.Name = "Wingdings 3"
        .Font.Size = 6
        .Caption = "q"
    End With

quand j'aurais réglé tout ces petit détails je montrerais a unparia comment je m'en sert 10 fois dans le même userform ou 36 userform et sans Module standard

Là n'était pas le souci de Jacques.
Il voulait certainement s'en servir dans une feuille

**unparia** · 24/05/2017, 10h30

Mêmes remarques que Jacques à propos du "rouge", du scroll et du clic sur n'importe quel contrôle

,
réponse -->>

les couleur sont paremetrables

Tu n'as donc rien compris (encore une lecture en diagonale ? ) à ce dont il est question.
Quelle que soit la couleur choisie (on s'en fiche) -->> ce dont il est question est AUTRE CHOSE !

EDIT :
Au fait :

@unparia
oui la declararation de la classe dans le userform
tu me l'aurais dis directement on aurais perdu moins de temps

Et on en aurait pas perdu du tout si tu n'avais pas affirmé (et répété) que chez toi cela marchait en faisant exactement (comme je te l'avais demandé) ce que tu avais écrit, hein ...

**patricktoulon** · 24/05/2017, 12h46

est ce que comme ceci ca conviendrait mieux
Nom : demo4.gif
Affichages : 236
Taille : 451,6 Ko

**pijaku** · 24/05/2017, 12h51

Envoyé par patricktoulon

est ce que comme ceci ca conviendrait mieux

Visuellement ça à l'air.
Mais pour mieux te répondre, il faudrait le code...

**unparia** · 24/05/2017, 12h55

est ce que comme ceci ca conviendrait mieux

C'est déjà au moins "moins mal" et moins fantaisiste.
Reste à connaître les autres réactions et les gestes à faire (bouton/souris, etc ...) , que ne risque pas de montrer une "animation".
Une "animation", c'est zouli zouli flashy flashy (dirais-je bling-bling ?) , sans plus (et donne le tournis) . Seul le code "parle".

**patricktoulon** · 24/05/2017, 13h15

nouveau code brouillon de la classe

parcontre pour le bouton drop je vais certainement etre obligé de separer dans une sous classe en effet on a l'"event propagation" qui fait que ca agit autant de fois que de sous classe donc pour le visible/false de la frame c'est compliqué je ne l'ai donc pas encore fait

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
Option Explicit
Public WithEvents framm As MSForms.Frame
Public WithEvents formm As UserForm
Public WithEvents dropp As MSForms.Image
Public WithEvents selecté As MSForms.TextBox
Public WithEvents labLt As MSForms.Label
Public WithEvents memo As MSForms.Label
Public WithEvents combo As MSForms.ComboBox
Public WithEvents scrol As MSForms.ScrollBar
Private usf(100) As New combofake2
Function combocolor(comb, bicolorbyrow, Optional GriDline As Boolean = False, Optional GrildLineColor As Variant = vbBlack, Optional overcolor As Variant = vbCyan, Optional listrow As Variant = False)
    Dim cW, ecW#, ecL#, Fram, Ssel, Drop, cadr, lig#, col#, cc#, ccol#, cel, mabarre, bouton, countrows#, ccwidth#, Hheight, lab, scro, ccc, i
    comb.Parent.Tag = overcolor    'memorisation de la couleur OVER dans tag du userform
    cW = Split(Replace(comb.ColumnWidths, " pt", ""), ";")    'columnwidths  de la combobobox originale vers un array
    For i = 0 To UBound(cW): ccc = ccc + Val(cW(i)): Next
    If listrow = False Then listrow = comb.ListRows
    Set lab = comb.Parent.Controls.Add("Forms.label.1", "memo" & col, True)
    With lab: .Caption = listrow - 1: .Font.Size = comb.Font.Size:
        .AutoSize = True:
        Hheight = .Height + 0.5:
        .Top = -15
    End With
 
    'ajout du cadre complet
    Set cadr = comb.Parent.Controls.Add("Forms.label.1", "fondlab", True): cadr.BackColor = &H8000000F: cadr.BorderStyle = 1: cadr.Visible = False
    'ajout de la frame
    Set Fram = comb.Parent.Controls.Add("Forms.Frame.1", "fond", True):: Fram.Visible = False
    'ajout de la scrollbars verticale
    Set scro = comb.Parent.Controls.Add("Forms.scrollbar.1", "scrol", True): scro.Tag = listrow - 1: scro.Visible = False
    'ajout du textbox (combobox
    Set Ssel = comb.Parent.Controls.Add("Forms.textbox.1", "selectio", True)
    'ajout du bouton dropdown
    Set Drop = comb.Parent.Controls.Add("Forms.image.1", "drop", True)
    Drop.SpecialEffect = 1: Drop.PictureSizeMode = 1: Drop.BackStyle = 0    'juste pour avoir le meme effet de bordure que l'original
    'placement des controls de base
    Ssel.Move comb.Left + 30 + comb.Width, comb.Top, comb.Width, comb.Height
    Drop.Move Ssel.Left + Ssel.Width - comb.Height + 5, Ssel.Top + 1, comb.Height - 5, comb.Height - 1
    Fram.Move Ssel.Left, comb.Top + comb.Height, comb.Width - Drop.Width, (Hheight * listrow) + 2, ccc
    scro.Move Ssel.Left + Ssel.Width - Drop.Width, Fram.Top + 1, Drop.Width, IIf(ccc > Fram.Width, (Hheight * listrow) - 1, Hheight * listrow)
    cadr.Move Ssel.Left, Ssel.Top, Ssel.Width, Ssel.Height + Fram.Height + IIf(ccc > Fram.Width, Drop.Width, 0)
    For lig = 0 To listrow - 1
        ccol = 0
        For col = 0 To comb.ColumnCount - 1
            cc = cc + 1    'DECOMPTE pour alimenter les sousclasses(usf(1 a X)
            'ajout item(ligne/colonne)
            Set cel = Fram.Controls.Add("Forms.label.1", "Lig" & lig & "Ligcol" & col, True)
            With cel
                .Caption = "  " & comb.List(lig, col): .Height = Hheight: .Font.Size = comb.Font.Size - 1:    'alimentation des propriétés
                .BorderStyle = IIf(GriDline, 1, 0)  'bordure(gridline)
                .BorderColor = IIf(GriDline, GrildLineColor, .BackColor)    'couleur du gridline
                .WordWrap = False:    '    .SpecialEffect = 0
                .Left = ccol: .Width = cW(col): .Top = (.Height * lig):
                If col = comb.ColumnCount - 1 And ccol < Fram.Width - 10 Then .Width = .Width + (Fram.Width - 10) - ccol - 5
                .BackColor = IIf(lig Mod 2 = 0, bicolorbyrow(1), bicolorbyrow(0)): .Tag = .BackColor    'memorisation du backcolor du label pour le rollOVER
                'enregistrement des parties dans les sousclasses pour la gestion des evenements (click,move)
                Set usf(cc).formm = comb.Parent: Set usf(cc).framm = Fram: Set usf(cc).combo = comb: Set usf(cc).memo = lab
                Set usf(cc).dropp = Drop: Set usf(cc).labLt = cel: Set usf(cc).selecté = Ssel: Set usf(cc).scrol = scro
            End With
            ccol = ccol + Val(cW(col))
        Next
    Next
    'dimentionnement (equivalent a listrows pour l'original)
    With Fram
        '.Height = (Hheight * listrow) + 2
        If ccol > .Width - 10 Then .ScrollBars = 1: Fram.ScrollWidth = ccol + 1: .Height = .Height + Hheight + 3:    ' scro.Height = .Height - 25: scro.Top = scro.Top + 10
        If listrow - 1 = comb.ListCount - 1 Then scro.Visible = False: Fram.Width = Ssel.Width:    'Fram.Height = Fram.Height + 2:    ' scrol.Height = framm.Height
    End With
    'du tunning encore du tunning l'icone du bouton dropdown
    '82,36,73
    On Error Resume Next
    CommandBars("temp").Delete
    Dim fico, ico, sh
    With ActiveSheet
        Set ico = .Shapes.AddShape(82, 10, 10, 6, 3): ico.Line.Visible = False: ico.Fill.ForeColor.RGB = (vbBlue): ico.Fill.Visible = True:
        ico.Copy: .Delete ""
    End With
    Set mabarre = CommandBars.Add("temp", msoBarPopup, False, True): Set bouton = mabarre.Controls.Add(Type:=msoControlButton):
    bouton.PasteFace
    Drop.Picture = bouton.Picture
    On Error Resume Next
    CommandBars("temp").Delete
    'comb.Visible = False
 
End Function
Private Sub scrol_Change()
    Dim cc, lig, col, LroW
    cc = -1: LroW = scrol.Tag
    For lig = scrol.Value To LroW + scrol.Value
        For col = 0 To combo.ColumnCount - 1: cc = cc + 1: framm.Controls(cc) = "  " & combo.List(lig, col): Next
    Next
End Sub
Private Sub scrol_Scroll()
    Dim cc, lig, col, LroW
    cc = -1: LroW = scrol.Tag
    For lig = scrol.Value To LroW + scrol.Value
        For col = 0 To combo.ColumnCount - 1: cc = cc + 1: framm.Controls(cc) = "  " & combo.List(lig, col): Next
    Next
End Sub
Private Sub dropp_Click()
    framm.Visible = True
    formm.Controls("fondlab").Visible = True
    With scrol: .Visible = True: .Max = combo.ListCount - scrol.Tag - 1: .Min = 0: .Value = 0: .LargeChange = 1: End With
    'If scrol.Tag <= combo.ListCount - 1 Then scrol.Visible = False: framm.Width = selecté.Width:    'framm.Height = framm.Height : ' scrol.Height = framm.Height
    '.Height = framm.Height:
End Sub
Private Sub labLt_Click()
    formm.Controls(combo.Name).Tag = Split(labLt.Name, "col")(1)    'memorisation de l'index colonne dans le tag de la combobox originale
    formm.Controls(combo.Name).ListIndex = scrol.Value + Val(Split(labLt.Name, "Lig")(1))    'modification de la propriété listindex de la combobox originale
    selecté.Value = Mid(labLt.Caption, 3, 1000)  'le textbox de substitution du haut de la combobox prent la valeur de l'item cliqué(ligne/colonne)
    framm.Visible = False: scrol.Visible = False    'fermeture frame(imite le comportement de l'originale
End Sub
Private Sub labLt_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If framm.Tag <> "" Then
        If framm.Tag <> labLt.Name Then framm.Controls(framm.Tag).BackColor = framm.Controls(framm.Tag).Tag
    End If
    framm.Tag = labLt.Name
    labLt.BackColor = formm.Controls(1).Parent.Tag
End Sub
'remise de la couleur initiale sur l'evenement frame et userform
Private Sub framm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If framm.Tag <> "" Then framm.Controls(framm.Tag).BackColor = framm.Controls(framm.Tag).Tag
End Sub
Private Sub formm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If framm.Tag <> "" Then framm.Controls(framm.Tag).BackColor = framm.Controls(framm.Tag).Tag
End Sub
Private Sub formm_Click()
    framm.Visible = False: scrol.Visible = False    'fermeture frameet scroll(imite le comportement de l'originale
'fermeture de la fram(imite le comportement de l'originale)
End Sub

**unparia** · 24/05/2017, 13h21

je ne l'ai donc pas encore fait

j'attendrai donc que ce soit fait (juste pour ne pas me transformer une fois de plus en testeur/gratteur/qualificateur).

A plus, donc.

**pijaku** · 24/05/2017, 13h26

Envoyé par unparia

j'attendrai donc que ce soit fait (juste pour ne pas me transformer une fois de plus en testeur/gratteur/qualificateur).

D'autant que le souci dénoncé par toi précédemment (le rouge qui reste rouge...) n'est pas résolu.

**patricktoulon** · 24/05/2017, 13h26

j'ai une autre idée mais après test je n'est pas réussi
donc y a t- il un moyen pour bloquer le dropdown d'une combo??

**patricktoulon** · 24/05/2017, 13h30

c'est bon j'ai trouvé

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Private Sub ComboBox1_DropButtonClick()
ComboBox1.Enabled = False
ComboBox1.Enabled = True
End Sub

ca va me permettre de supprimer j'ajout du textbox et du faux dropbouton c'est toujours ca de gagné

**patricktoulon** · 24/05/2017, 16h35

bon voila la derniere version
la classe se nomme "combofake3"

j'ai changé pas mal de chose notament les états et mesures de scrolle directement dans l'instruction de la classe et plus dans les évènements

le tout bien encadré dans une frame parent

si vous regardez bien dans le withevents j'ai deux évènements combo
c'est une astuce pour éviter le "event propagation" qui est applique le même nombre de fois que de controls gérer par la classe

je vous laisse regarder
code classe

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
Option Explicit
Public WithEvents framm As MSForms.Frame
Public WithEvents formm As UserForm
Public WithEvents selecté As MSForms.TextBox
Public WithEvents labLt As MSForms.Label
Public WithEvents grille As MSForms.Frame
Public WithEvents combo As MSForms.ComboBox
Public WithEvents comboseule As MSForms.ComboBox
Public WithEvents scrol As MSForms.ScrollBar
Private usf(100) As New combofake3
Function combocolor3(comb, bicolorbyrow, Optional GriDline As Boolean = False, Optional GrildLineColor As Variant = vbBlack, Optional overcolor As Variant = vbCyan, Optional listrow As Variant = False)
    Dim cW, ecW#, ecL#, Fram, Ssel, Drop, cadr, lig#, col#, cc#, ccol#, cel, mabarre, bouton, countrows#, ccwidth#, Hheight, lab, scro, ccc, i, grille
    comb.Parent.Tag = overcolor    'memorisation de la couleur OVER dans tag du userform
    cW = Split(Replace(comb.ColumnWidths, " pt", ""), ";")    'columnwidths  de la combobobox originale vers un array
    For i = 0 To UBound(cW): ccc = ccc + Val(cW(i)): Next
    If listrow = False Then listrow = comb.ListRows
    Set lab = comb.Parent.Controls.Add("Forms.label.1", "memo" & col, True)
    With lab: .Caption = listrow - 1: .Font.Size = comb.Font.Size: .AutoSize = True: Hheight = .Height + 0.5: .Top = -15: End With
    'ajout du textbox (combobox
    Set Ssel = comb.Parent.Controls.Add("Forms.textbox.1", "selectio", True)
    With Ssel: .Move comb.Left + 2, comb.Top + 2, comb.Width - comb.Height + 2, comb.Height - 4: .BorderStyle = 1: .BorderColor = vbWhite: End With
 
    'ajout du cadre complet
    Set cadr = comb.Parent.Controls.Add("Forms.Frame.1", "fondcombo", True): cadr.BackColor = &H8000000F: cadr.BorderStyle = 1: cadr.Visible = False
    With cadr: .Move comb.Left, comb.Top + comb.Height - 1, comb.Width, (Hheight * listrow) + IIf(ccc > comb.Width, 14, 4): End With
    'ajout du cadre grille
    Set grille = cadr.Controls.Add("Forms.Frame.1", "grille", True): grille.BackColor = &H8000000F: grille.BorderStyle = 1: grille.Visible = True
    With grille: .Move -1, 1, cadr.Width - 13, (Hheight * listrow) + IIf(ccc > comb.Width, 14, 1):
        .Width = IIf(listrow - 1 = comb.ListCount - 1, cadr.Width, cadr.Width - 13)
        If ccc > .Width Then .ScrollBars = 1: .ScrollWidth = ccc + 1
    End With
    'ajout de la scrollbars verticale
    Set scro = cadr.Controls.Add("Forms.scrollbar.1", "scrol", True)
    With scro: .Move cadr.Width - 13, 0 + 1, 12, IIf(ccc > comb.Width, cadr.Height - 14, cadr.Height - 2): scro.Tag = listrow - 1:
        scro.Visible = IIf(listrow - 1 = comb.ListCount - 1, False, True): scro.Max = (comb.ListCount - 1) - listrow + 1: .LargeChange = 1: End With
 
    For lig = 0 To listrow - 1
        ccol = 0
        For col = 0 To comb.ColumnCount - 1
            cc = cc + 1    'DECOMPTE pour alimenter les sousclasses(usf(1 a X)
            'ajout item(ligne/colonne)
            Set cel = grille.Controls.Add("Forms.label.1", "Lig" & lig & "Ligcol" & col, True)
            With cel
                .Caption = "  " & comb.List(lig, col): .Height = Hheight: .Font.Size = comb.Font.Size - 1:    'alimentation des propriétés
                .BorderStyle = IIf(GriDline, 1, 0)  'bordure(gridline)
                .BorderColor = IIf(GriDline, GrildLineColor, .BackColor)    'couleur du gridline
                .WordWrap = False:
                .ForeColor = comb.ForeColor
                .Left = 1 + ccol + IIf(col > 1, -(1 * col), 0): .Width = cW(col): .Top = (.Height * lig):
                If col = comb.ColumnCount - 1 And ccol < grille.Width - 10 Then .Width = .Width + (grille.Width - 10) - ccol - 5
                .BackColor = IIf(lig Mod 2 = 0, bicolorbyrow(1), bicolorbyrow(0)): .Tag = .BackColor    'memorisation du backcolor du label pour le rollOVER
                'enregistrement des parties dans les sousclasses pour la gestion des evenements (click,move)
                Set usf(cc).formm = comb.Parent: Set usf(cc).framm = cadr: Set usf(cc).grille = grille: Set usf(cc).combo = comb:
                Set usf(cc).labLt = cel: Set usf(cc).selecté = Ssel: Set usf(cc).scrol = scro: Set usf(100).comboseule = comb
            End With
            ccol = ccol + Val(cW(col))
        Next
    Next
    comb.Parent.Repaint
End Function
 
Private Sub scrol_Change()
    Dim cc, lig, col, LroW
    cc = -1: LroW = scrol.Tag
    For lig = scrol.Value To LroW + scrol.Value
        For col = 0 To combo.ColumnCount - 1: cc = cc + 1: grille.Controls(cc) = "  " & combo.List(lig, col): Next
    Next
End Sub
Private Sub scrol_Scroll()
    Dim cc, lig, col, LroW, Sv
    cc = -1: LroW = scrol.Tag: Sv = scrol.Value
    For lig = Sv To LroW + Sv: For col = 0 To combo.ColumnCount - 1: cc = cc + 1: grille.Controls(cc) = "  " & combo.List(lig, col): Next: Next
End Sub
Private Sub labLt_Click()
    formm.Controls(combo.Name).Tag = Split(labLt.Name, "col")(1)    'memorisation de l'index colonne dans le tag de la combobox originale
    formm.Controls(combo.Name).ListIndex = scrol.Value + Val(Split(labLt.Name, "Lig")(1))    'modification de la propriété listindex de la combobox originale
    selecté.Value = Mid(labLt.Caption, 3, 1000)  'le textbox de substitution du haut de la combobox prent la valeur de l'item cliqué(ligne/colonne)
    framm.Visible = False: scrol.Visible = False    'fermeture frame(imite le comportement de l'originale
End Sub
Private Sub labLt_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If framm.Tag <> "" Then
        If framm.Tag <> labLt.Name Then framm.Controls(framm.Tag).BackColor = framm.Controls(framm.Tag).Tag
    End If
    framm.Tag = labLt.Name
    labLt.BackColor = formm.Controls(1).Parent.Tag
End Sub
'remise de la couleur initiale sur l'evenement frame et userform
Private Sub framm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If framm.Tag <> "" Then framm.Controls(framm.Tag).BackColor = framm.Controls(framm.Tag).Tag
End Sub
Private Sub formm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If framm.Tag <> "" Then framm.Controls(framm.Tag).BackColor = framm.Controls(framm.Tag).Tag
End Sub
Private Sub formm_Click()
    framm.Visible = False: scrol.Visible = False    'fermeture frameet scroll(imite le comportement de l'originale
'fermeture de la fram(imite le comportement de l'originale)
End Sub
Private Sub comboseule_DropButtonClick()
    Dim f
    comboseule.Enabled = False
    comboseule.Enabled = True
    Set f = comboseule.Parent.Controls("fondcombo")
    If f.Visible = True Then
        f.Visible = False
    Else
        f.Visible = True
    End If
With comboseule: .Parent.Controls("scrol").Visible = IIf(.Parent.Controls("scrol").Tag - 1 = comboseule.ListCount - 1, False, True): End With
comboseule.Parent.Repaint
End Sub

code du userform toujours pareil

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Option Explicit
Dim cls As New combofake3
Private Sub CommandButton1_Click()
cls.combocolor3 ComboBox1, Array(&HC0FFFF, &HC0C0FF), True, vbGreen, vbRed, 8
End Sub
Private Sub UserForm_Activate()
Dim plage As Range, i#, cW$
Set plage = Range("A1:d100")
ComboBox1.Font.Size = plage.Cells(1).Font.Size
ComboBox1.ColumnCount = plage.Columns.Count
ComboBox1.List = plage.Value
For i = 1 To plage.Columns.Count
cW = cW & plage.Columns(i).Width & IIf(i < plage.Columns.Count, " pt;", "")
Next
ComboBox1.ColumnWidths = cW
End Sub

c'est bluffant

Nom : Capture.JPG
Affichages : 206
Taille : 74,3 Ko

**unparia** · 24/05/2017, 18h19

je vais en tester combien ? Je vais abandonner si cela continue ainsi. Arrange-toi pour tester toi-même la prochaine et vérifier que tu as apporté les corrections à faire. A défaut, je ne testerai plus rien.
Tu as juste amélioré certains aspects (les ascenseurs).
Et les autres défauts ? -->> toujours là : par exemple et entre autres le rouge qui reste indûment dans certains cas et se "promène" ensuite ailleurs en jouant avec l'ascenseur (me relire) et l'obligation de cliquer sur le userform pour "replier" la combo

Sans préjudice de tout ce dont nous parlerons (les aspects FONDAMENTAUX, bien plus sérieux, eux) quand tu auras terminé de jouer avec ce qui est le plus futile.

**patricktoulon** · 24/05/2017, 18h53

c'est bon laisse tomber pour moi ca me conviens
je n'ai pas tout les soucis que tu as avec

**unparia** · 24/05/2017, 18h59

c'est bon laisse tomber pour moi ca me conviens
je n'ai pas tout les soucis que tu as avec

Tout est alors pour le mieux dans le meilleur des mondes, donc

(Et cela tombe bien : toute ma tribu (enfants et petits enfants ) vient d'arriver et je vais leur donner la priorité.

**pijaku** · 24/05/2017, 21h27

Je serais absent quelques jours pour ma famille (également Jacques, au passage j'embrasse la tienne, passe du bon temps hors Internet!!!).
Je reviens donc lundi ou mardi pour tester et avis...
Bon week end à tous

**pijaku** · 29/05/2017, 08h00

De retour!

Bonjour,

Envoyé par patricktoulon

c'est bon laisse tomber pour moi ca me conviens

Cela signifie t'il que l'on arrête de tester?

Pour ma part, je retrouve le même souci que Jacques, à savoir la couleur rouge de survol d'une "cellule" qui reste rouge lorsque l'on va sur "l'ascenseur".
Encore plus flagrant sur le scroll horizontal.
Ajoutons également le "repli" de cette combobox qui ne réagit pas comme une vraie combobox.
Pour vérifier cela, place un textbox dans ton userform et teste avec ouverture d'une combo normale et de ta combo.

Sinon, visuellement, elle est bien.

Maintenant, ne te "reste" qu'à prendre en compte les remarques déjà dites et beaucoup d'autres suivront, je te l'assure.

**patricktoulon** · 06/06/2017, 19h38

re
bonjour
la reaction de la combo est similaire a la vrai maintent
clik sur drop button (ouverture/fermeture)
click sur la partie value fermeture
click dans userform fermeture
reste la couleur de survol
peut être vais je devoir diminuer la taille de 1 point en largeur et en hauteur pour que le move sur frame fasse son effet

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
Option Explicit
Public WithEvents framm As MSForms.Frame
Public WithEvents formm As UserForm
Public WithEvents selecté As MSForms.TextBox
Public WithEvents labLt As MSForms.Label
Public WithEvents grille As MSForms.Frame
Public WithEvents combo As MSForms.ComboBox
Public WithEvents comboseule As MSForms.ComboBox
Public WithEvents scrol As MSForms.ScrollBar
Private usf(100) As New combofake3
Function combocolor3(comb, bicolorbyrow, Optional GriDline As Boolean = False, Optional GrildLineColor As Variant = vbBlack, Optional overcolor As Variant = vbCyan, Optional listrow As Variant = False)
    Dim cW, ecW#, ecL#, Fram, Ssel, Drop, cadr, lig#, col#, cc#, ccol#, cel, mabarre, bouton, countrows#, ccwidth#, Hheight, lab, scro, ccc, i, grille
    comb.Parent.Tag = overcolor    'memorisation de la couleur OVER dans tag du userform
    cW = Split(Replace(comb.ColumnWidths, " pt", ""), ";")    'columnwidths  de la combobobox originale vers un array
    For i = 0 To UBound(cW): ccc = ccc + Val(cW(i)): Next
    If listrow = False Then listrow = comb.ListRows
    Set lab = comb.Parent.Controls.Add("Forms.label.1", "memo" & col, True)
    With lab: .Caption = listrow - 1: .Font.Size = comb.Font.Size: .AutoSize = True: Hheight = .Height + 0.5: .Top = -15: End With
    'ajout du textbox (combobox
    Set Ssel = comb.Parent.Controls.Add("Forms.textbox.1", "selectio", True)
    With Ssel: .Move comb.Left + 2, comb.Top + 2, comb.Width - comb.Height + 2, comb.Height - 4: .BorderStyle = 1: .BorderColor = vbWhite: End With
 
    'ajout du cadre complet
    Set cadr = comb.Parent.Controls.Add("Forms.Frame.1", "fondcombo", True): cadr.BackColor = &H8000000F: cadr.BorderStyle = 1: cadr.Visible = False
    With cadr: .Move comb.Left, comb.Top + comb.Height - 1, comb.Width, (Hheight * listrow) + IIf(ccc > comb.Width, 14, 4): End With
    'ajout du cadre grille
    Set grille = cadr.Controls.Add("Forms.Frame.1", "grille", True): grille.BackColor = &H8000000F: grille.BorderStyle = 1: grille.Visible = True
    With grille: .Move -1, 1, cadr.Width - 13, (Hheight * listrow) + IIf(ccc > comb.Width, 14, 1):
        .Width = IIf(listrow - 1 = comb.ListCount - 1, cadr.Width, cadr.Width - 13)
        If ccc > .Width Then .ScrollBars = 1: .ScrollWidth = ccc + 1
    End With
    'ajout de la scrollbars verticale
    Set scro = cadr.Controls.Add("Forms.scrollbar.1", "scrol", True)
    With scro: .Move cadr.Width - 13, 0 + 1, 12, IIf(ccc > comb.Width, cadr.Height - 14, cadr.Height - 2): scro.Tag = listrow - 1:
        scro.Visible = IIf(listrow - 1 = comb.ListCount - 1, False, True): scro.Max = (comb.ListCount - 1) - listrow + 1: .LargeChange = 1: End With
 
    For lig = 0 To listrow - 1
        ccol = 0
        For col = 0 To comb.ColumnCount - 1
            cc = cc + 1    'DECOMPTE pour alimenter les sousclasses(usf(1 a X)
            'ajout item(ligne/colonne)
            Set cel = grille.Controls.Add("Forms.label.1", "Lig" & lig & "Ligcol" & col, True)
            With cel
                .Caption = "  " & comb.List(lig, col): .Height = Hheight: .Font.Size = comb.Font.Size - 1:    'alimentation des propriétés
                .BorderStyle = IIf(GriDline, 1, 0)  'bordure(gridline)
                .BorderColor = IIf(GriDline, GrildLineColor, .BackColor)    'couleur du gridline
                .WordWrap = False:
                .ForeColor = comb.ForeColor
                .Left = 1 + ccol + IIf(col > 1, -(1 * col), 0): .Width = cW(col): .Top = (.Height * lig):
                If col = comb.ColumnCount - 1 And ccol < grille.Width - 10 Then .Width = .Width + (grille.Width - 10) - ccol - 5
                .BackColor = IIf(lig Mod 2 = 0, bicolorbyrow(1), bicolorbyrow(0)): .Tag = .BackColor    'memorisation du backcolor du label pour le rollOVER
                'enregistrement des parties dans les sousclasses pour la gestion des evenements (click,move)
                Set usf(cc).formm = comb.Parent: Set usf(cc).framm = cadr: Set usf(cc).grille = grille: Set usf(cc).combo = comb:
                Set usf(cc).labLt = cel: Set usf(cc).selecté = Ssel: Set usf(cc).scrol = scro: Set usf(100).comboseule = comb
            End With
            ccol = ccol + Val(cW(col))
        Next
    Next
    comb.Parent.Repaint
End Function
 
Private Sub scrol_Change()
    Dim cc, lig, col, LroW
    cc = -1: LroW = scrol.Tag
    For lig = scrol.Value To LroW + scrol.Value
        For col = 0 To combo.ColumnCount - 1: cc = cc + 1: grille.Controls(cc) = "  " & combo.List(lig, col): Next
    Next
End Sub
Private Sub scrol_Scroll()
    Dim cc, lig, col, LroW, Sv
    cc = -1: LroW = scrol.Tag: Sv = scrol.Value
    For lig = Sv To LroW + Sv: For col = 0 To combo.ColumnCount - 1: cc = cc + 1: grille.Controls(cc) = "  " & combo.List(lig, col): Next: Next
End Sub
Private Sub labLt_Click()
    formm.Controls(combo.Name).Tag = Split(labLt.Name, "col")(1)    'memorisation de l'index colonne dans le tag de la combobox originale
    formm.Controls(combo.Name).ListIndex = scrol.Value + Val(Split(labLt.Name, "Lig")(1))    'modification de la propriété listindex de la combobox originale
    selecté.Value = Mid(labLt.Caption, 3, 1000)  'le textbox de substitution du haut de la combobox prent la valeur de l'item cliqué(ligne/colonne)
    framm.Visible = False: scrol.Visible = False    'fermeture frame(imite le comportement de l'originale
End Sub
Private Sub selecté_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
framm.Visible = False:
End Sub
Private Sub selecté_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If framm.Tag <> "" Then
        If framm.Tag <> labLt.Name Then framm.Controls(framm.Tag).BackColor = framm.Controls(framm.Tag).Tag
    End If
    framm.Tag = labLt.Name
    labLt.BackColor = formm.Controls(1).Parent.Tag
End Sub
Private Sub labLt_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim i#
    If framm.Tag <> "" Then
        If framm.Tag <> labLt.Name Then framm.Controls(framm.Tag).BackColor = framm.Controls(framm.Tag).Tag
    End If
    framm.Tag = labLt.Name
    labLt.BackColor = formm.Controls(1).Parent.Tag
End Sub
'remise de la couleur initiale sur l'evenement frame et userform
Private Sub framm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If framm.Tag <> "" Then framm.Controls(framm.Tag).BackColor = framm.Controls(framm.Tag).Tag
End Sub
Private Sub formm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If framm.Tag <> "" Then framm.Controls(framm.Tag).BackColor = framm.Controls(framm.Tag).Tag
End Sub
Private Sub formm_Click()
    framm.Visible = False: scrol.Visible = False    'fermeture frameet scroll(imite le comportement de l'originale
'fermeture de la fram(imite le comportement de l'originale)
End Sub
Private Sub comboseule_DropButtonClick()
    Dim f
    comboseule.Enabled = False
    comboseule.Enabled = True
    Set f = comboseule.Parent.Controls("fondcombo")
    If f.Visible = True Then
        f.Visible = False
    Else
        f.Visible = True
    End If
With comboseule: .Parent.Controls("scrol").Visible = IIf(.Parent.Controls("scrol").Tag - 1 = comboseule.ListCount - 1, False, True): End With
comboseule.Parent.Repaint
End Sub

**pijaku** · 08/06/2017, 08h48

Bonjour Patrick,

Comme je serais absent un moment à partir de demain soir, je vais essayer de te faire une réponse la plus complète possible.

Envoyé par patricktoulon

la reaction de la combo est similaire a la vrai maintenant
clik sur drop button (ouverture/fermeture)
click sur la partie value fermeture
click dans userform fermeture

C'est bien, tu avances. Mais...
Ne te reste plus qu'à gérer le clic sur n'importe quel autre contrôle...

Envoyé par patricktoulon

reste la couleur de survol

Oui.
Bon courage.
L'idéal serait de colorer toute la ligne de la combobox, comme une vraie le ferait.

Un "truc", tout petit, me gène dans le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Public WithEvents formm As UserForm
'.....
Set usf(cc).formm = comb.Parent

Le Parent n'est pas nécessairement un UserForm (cas d'une combobox dans un Frame, un Multipage).
Cela fonctionne tel quel, y compris le Sub formm_MouseMove, mais ce n'est pas tout à fait exact.

Parlons de la Combobox maintenant.
1- souci quand elle est encapsulée dans un frame :
Vraie combobox :
Pièce jointe 283609
combofake :
Pièce jointe 283610
2- il te faut maintenant te "taper" toutes les propriétés des combobox pour les adapter à la tienne (exemple la ColumnHeads (cf images ci-dessus))
3- il te faut également ajouter la saisie semi-automatique ==> indispensable propriété des ComboBox...

...

**unparia** · 08/06/2017, 17h25

Bonjour Franck
Les points que tu soulèves, notamment le 2) et le 3) sont encore plus nombreux que tu peux l'imaginer.
On a là un ersatz de combobox doté de futilités diverses au détriment de nombreuses fonctionnalités très utiles d'une combobox.
Mais je m'en tiens à ce que patricktoulon a déclaré le 24 mai dernier, à savoir :

c'est bon laisse tomber pour moi ca me conviens
je n'ai pas tout les soucis que tu as avec

Si cela lui convient, à lui, ma foi ...