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
| 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 combo As MSForms.ComboBox
Private usf(100) As New combofake
Function combocolor(comb, bicolorbyrow, Optional GriDline As Boolean = False, Optional GrildLineColor As Variant = vbBlack, Optional overcolor As Variant = vbCyan)
Dim cW, ecW#, ecL#, Fram, Ssel, Drop, i#, col#, cc#, ccol#, cel, mabarre, bouton
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
'ajout de la frame
Set Fram = comb.Parent.Controls.Add("Forms.Frame.1", "fond", True): Fram.Width = 100: Fram.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 'juste pour avoir le meme effet de bordure que l'original
'placement des controls de base
Ssel.Move comb.Left, comb.Top, comb.Width, comb.Height
Drop.Move comb.Left + comb.Width - comb.Height, comb.Top + 1, comb.Height - 2, comb.Height - 2
Fram.Move comb.Left, comb.Top + comb.Height, comb.Width, comb.Width
'boucle sur la liste (ligne/colonnes)
For i = 0 To comb.ListCount - 1
ecL = IIf(GriDline, IIf(i > 0, 1 * i, 0), 0) 'on enleve 1*i pour que les borduretop et bottom se croisent (effet BORDERCOLLAPSE)
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" & i & "Ligcol" & col, True)
With cel
ecW = IIf(GriDline, IIf(col > 0, 1 * col, 0), 0) 'on enleve 1*i pour que les bordureright et left se croisent (effet BORDERCOLLAPSE)
.Caption = comb.List(i, col): .AutoSize = True: .Font.Size = comb.Font.Size: 'alimentation des propriétés
.BorderStyle = IIf(GriDline, 1, 0) 'bordure(gridline)
.BorderColor = IIf(GriDline, GrildLineColor, 0) 'couleur du gridline
.WordWrap = False: .Top = (.Height * i) - ecL:
'maintenant que l'on a le height on enleve le autosize et met le widh a la dimention des columnswidths
.Left = ccol - ecW: .AutoSize = False: .Width = cW(col):
.BackColor = IIf(i 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).dropp = Drop: Set usf(cc).labLt = cel: Set usf(cc).selecté = Ssel
End With
ccol = ccol + Val(cW(col))
Next
Next
'dimentionnement (equivalent a listrows pour l'original)
With Fram
.Height = .Controls(1).Height * comb.ListRows + IIf(GriDline, 5, 15): .ScrollBars = 3:
End With
'du tunning encore du tunning l'icone du bouton dropdown
'82,36,73
On Error Resume Next
CommandBars("temp").Delete
With ActiveSheet.Shapes.AddShape(36, 10, 10, 10, 15): .Line.Visible = False: .Fill.ForeColor.RGB = (vbBlue): .Fill.Visible = True: .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 dropp_Click()
Dim the_next
framm.Visible = True
Set the_next = framm.Controls("Lig" & combo.ListCount - 1 & "Ligcol" & combo.ColumnCount - 1)
'reglage des scrolls a l'identique de l'originale
framm.ScrollWidth = the_next.Left + the_next.Width
framm.ScrollHeight = the_next.Top + the_next.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 = Split(labLt.Name, "Lig")(1) 'modification de la propriété listindex de la combobox originale
selecté.Value = labLt.Caption 'le textbox de substitution du haut de la combobox prent la valeur de l'item cliqué(ligne/colonne)
framm.Visible = False 'fermeture frame(imite le comportement de l'originale
End Sub
'effet mose OVER
'vous trouverez ce principe dans quasi toutes mes contributions sur les userforms et ses controls
'application de la couleur
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
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 'fermeture de la fram(imite le comportement de l'originale)
End Sub |
Partager