36 manieres d' agrémenter ses labels et Commanbuttons d'un icone

**patricktoulon** · 03/02/2017, 14h35

Bonjour a tous
une demande très récente a encore été faite sur le moyen de mettre une icone dans ses contrôles
j'ai donc réuni toutes mes archives sur ce point qui constitue plusieurs manières d'y arriver et sous diverses formes en un seul userform

j'ai bien séparé les fonctions selon le mode utilisé afin que ceux intéressés par l'une ou l'autre ne soit pas perdu dans le code
et quoi que j'ai tellement simplifié que cela devrait etre facile même pour un débutant
elle contient 7 méthodes plus ou moins différentes

méthode 0 :un simple loadpicture sur un gif mesurant pas plus de 20X20 pixel que je n'ai pas développé car simple a utiliser
méthode 1 :utilisation de faceID des contrôles d'une command bar
méthode 2 :récupération des icones de fichier (utilisations des apis)
méthode 3 : téléchargement instantané sur le web (pour l'exemple le clin d'oeuil de DVP)(utilisation requête et adobstream)
méthode 4 : utilisation des shapes(formes automatique d'Excel) avec utilisation des apis
méthode 5 :utilisation des shapes(formes automatique d'Excel) avec utilisation d'une command bar provisoire(pasteface)
méthode 6 :un dérivé de la méthode 5 mais en copiant et pasteface sur un ctrl de command bar une image PNG ou gif

voila pour l'énumération des possibilités

voila une démo animée de cet userform
je donne aussi quelques explications notamment sur les images PNG dans le label de présentation dans chaque page de l'userform
Nom : demo2.gif
Affichages : 630
Taille : 424,6 Ko

Nom : demo2.gif
Affichages : 630
Taille : 424,6 Ko

voila le code contenu dans l'userform

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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
'
'             SUJET:  DES ICONES DANS MES CONTROLS
'            AUTEUR:  PATRICKTOULON POUR DVP
' DATE DE CREATION :  02/02/2017
'DECLARATION DES APIS
Option Explicit
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As FileInfo, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Type PicBmp: Size As Long: tType As Long: hBmp As Long: hPal As Long: Reserved As Long: End Type
Private Type GUID: Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(7) As Byte: End Type
Private Type FileInfo: hicon As Long: iIcon As Long: dwAttributes As Long: szDisplayName As String * 260: szTypeName As String * 80: End Type
'si le clipboard contient un  bitmap ou metafile?
Private Declare Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As Integer) As Long
'Ouverture du clipboard pour lecture
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
'trouve le  bitmap ou metafile
Private Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Integer) As Long
'ferme le clipboard
Private Declare Function CloseClipboard Lib "User32" () As Long
'Creation d'une copy du  metafile
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Const CF_ENHMETAFILE = 14
 
 
'**********************************************************************************************************
'**********************************************************************************************************
'                                                      METHODE 1
' METTRE UN ICON ISSUE DE LA COMMANDBARS EXEMPLE LA COMMANDBAR("Celle")
Private Sub CommandButton3_Click()
    With Label4
        .Picture = CommandBars("Cell").Controls(5).Picture    ' l'image du Label = celle du control(2) du menu contextuel cellule
        .PicturePosition = 1    ' on aligne l'image a gauche du control
    End With
    With CommandButton2
        .Picture = CommandBars("cell").Controls(6).Picture    ' l'image du bouton = celle du control(6) du menu contextuel cellule
        .PicturePosition = 1    '' on aligne l'image a gauche du control
    End With
End Sub
' FIN DE METHODE 1
'**************************************************************************************************************************
 
'************************************************************************************************************
'************************************************************************************************************
'                                                      METHODE 2
Private Sub CommandButton5_Click()
'on prends un fichiers PDF quelconque pour le label
    With Label6
        .Picture = icon_du_fichier("C:\Users\" & Environ("Username") & "\Desktop\gestion fichier scripting ou dir .pdf")
        .PicturePosition = 1    ' on aligne l'image a gauche du control
    End With
    'on prends le fichier "EXE" de l'application elle meme pour le bouton
    With CommandButton4
        .Picture = icon_du_fichier(Application.Path & "\EXCEL.exe")
        .PicturePosition = 1    ' on aligne l'image a gauche du control
    End With
' LA FONCTION JUSTE EN DESSOUS
End Sub
Function icon_du_fichier(FileName As String)    'As IPicture
    Dim b As FileInfo, retval As Long, pic As PicBmp, iPic As IPicture, IID_IDispatch As GUID
    retval = SHGetFileInfo(FileName, 0, b, Len(b), &H100)    ' &HC100 =iconne identique mais avec la fleche de racourci
    With IID_IDispatch: .Data1 = &H20400: .Data4(0) = &HC0: .Data4(7) = &H46: End With
    With pic: .Size = Len(b): .tType = 3: .hBmp = b.hicon: End With
    Call OleCreatePictureIndirect(pic, IID_IDispatch, 1, iPic)
    Set icon_du_fichier = iPic
    'SavePicture IPic, "C:\Users\" & Environ("Username") & "\Desktop\icoco.ico"
End Function
' FIN DE METHODE 2
'**************************************************************************************************************************
 
'************************************************************************************************************
'************************************************************************************************************
'                                                         METHODE 3
'PARTIE ICONES DU WEB
'ICI ON TELECHARGE UNE IMAGE SUR LE WEB ET ON LA MET DANS LE CONTROLS
Private Sub CommandButton7_Click()
    With Label8
        .Picture = LoadPicture(Image_par_UrL("https://www.developpez.net/forums/images/smilies/icon_wink.gif"))
        .PicturePosition = 1    ' on aligne l'image a gauche du control
    End With
    With CommandButton6
        .Picture = LoadPicture(Image_par_UrL("https://www.developpez.net/forums/images/smilies/icon_wink.gif"))
        .PicturePosition = 1    ' on aligne l'image a gauche du control
    End With
    Kill ThisWorkbook.Path & "\imagetemp.gif"
End Sub
Function Image_par_UrL(url As String) As String
    Dim chemin As String
    chemin = ThisWorkbook.Path & "\imagetemp.gif"
    Dim ReQ As Object, oStream As Object
    On Error Resume Next    'On ne gère pas les erreurs
    Set ReQ = CreateObject("Microsoft.XMLHTTP")
    ReQ.Open "get", url, False: ReQ.send
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open: oStream.Type = 1: oStream.Write ReQ.responsebody: oStream.SaveToFile chemin: oStream.Close
    Image_par_UrL = ThisWorkbook.Path & "\imagetemp.gif"
    Set oStream = Nothing: Set ReQ = Nothing
End Function
' FIN DE METHODE 3
'**************************************************************************************************************************
 
'**************************************************************************************************************************
'**************************************************************************************************************************
'                                                     METHODE 4
'METTRE UNE SHAPE EN GUISE D ICONE AVEC LES APIS
Private Sub CommandButton9_Click()
'on appelle la creation de la shape  et on aligne la propriété picture du control a gauche
    With Label10: .Picture = Picture_BY_Shape(23, RGB(255, 200, 0)): .PicturePosition = 1: End With
    With CommandButton8: .Picture = Picture_BY_Shape(33, RGB(255, 0, 0)): .PicturePosition = 1: End With
End Sub
Function Picture_BY_Shape(model, couleur) As IPicture
'ici on construit le shape dans le sheets ,on le copie ,on le delate ,il est mainenant dans le clipboard
'on envoie ensuite la fonction createpicture qui va le recuperer dans le clip board
' et créé son conteneur avec oleacreatepicture indirect et les info contenu dans le clip board
    With ActiveSheet.Shapes.AddShape(model, 10, 10, 8, 8): .Line.Visible = False: .Fill.ForeColor.RGB = (couleur): .Fill.Visible = True: .Copy: .Delete: End With
    Set Picture_BY_Shape = CreatePicture
End Function
Function CreatePicture() As IPicture
    Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
    ' IPicture necessite la reference "OLE Automation" qui normalement est activé mais je le dis au cas ou
    Dim r As Long, uPicInfo As PicBmp, IID_IDispatch As GUID, iPic As IPicture
    lPicType = CF_ENHMETAFILE
    hPicAvail = IsClipboardFormatAvailable(lPicType)
    If hPicAvail <> 0 Then h = OpenClipboard(0&)  ' si il y a quelque chose de valideon ouvre ce quelque chose dans le  clipboard
    If h > 0 Then hPtr = GetClipboardData(CF_ENHMETAFILE): hCopy = CopyEnhMetaFile(hPtr, vbNullString)
    h = CloseClipboard    'fermeture du clipboard
    If hPtr <> 0 Then
        With IID_IDispatch    ' Creation de l'Interface GUID (for the IPicture interface)
            .Data1 = &H7BF80980: .Data2 = &HBF32: .Data3 = &H101A: .Data4(0) = &H8B: .Data4(1) = &HBB
            .Data4(2) = &H0: .Data4(3) = &HAA: .Data4(4) = &H0: .Data4(5) = &H30: .Data4(6) = &HC: .Data4(7) = &HAB
        End With
        With uPicInfo: .Size = Len(uPicInfo): .tType = 4: .hBmp = hCopy: .hPal = 0: End With
        r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, 0, iPic)    ' creation de l'object picture
        Set CreatePicture = iPic    ' la fonction devient le picture.
    End If
    hCopy = 0: hPtr = 0
End Function
' FIN DE METHODE 4
'**************************************************************************************************************************
 
'**************************************************************************************************************************
'**************************************************************************************************************************
'                                                         METHODE 5
'METTRE UNE FORME AUTOMATIQUE(SHAPES) EN GUISE D ICONE SANS API
Private Sub CommandButton11_Click()
    With Label12
        .Picture = paste_shape_on_ctrX(33, vbRed)
        .PicturePosition = 1    ' on aligne l'image a gauche du control
    End With
    With CommandButton10
        .Picture = paste_shape_on_ctrX(103, vbMagenta)
        .PicturePosition = 1    '' on aligne l'image a gauche du control
    End With
End Sub
Function paste_shape_on_ctrX(model, couleur)
    Dim mabarre, bouton
    delpopup "temp"
    With ActiveSheet.Shapes.AddShape(model, 10, 10, 15, 15): .Line.Visible = False: .Fill.ForeColor.RGB = (couleur): .Fill.Visible = True: .Copy: .Delete: End With
    Set mabarre = CommandBars.Add("temp", msoBarPopup, False, True): Set bouton = mabarre.Controls.Add(Type:=msoControlButton): bouton.PasteFace
    Set paste_shape_on_ctrX = bouton.Picture
End Function
Function delpopup(Nom)
    On Error Resume Next: CommandBars(Nom).Delete
End Function
' FIN DE METHODE 5
'********************************************************************************************************************
 
'**********************************************************************************************************
'**********************************************************************************************************
'                                                      METHODE 6
' METTRE UN ICON ISSUE d'une image PNG sans api
Private Sub CommandButton12_Click()
    Dim chemin As String
    chemin = "H:\Imagess\icon\pour les icons et png\PNG\1rightarrow.png"    'adapter le chemin
    With Label13
        .Picture = paste_png_on_CMB_control(chemin, Label13)
        .PicturePosition = 1    ' on aligne l'image a gauche du control
    End With
    chemin = "H:\Imagess\icon\pour les icons et png\PNG Classés\Coupe du Monde\Switzerland.png"
    With CommandButton13
        .Picture = paste_png_on_CMB_control(chemin, CommandButton13)
        .PicturePosition = 1    '' on aligne l'image a gauche du control
    End With
End Sub
Function paste_png_on_CMB_control(url, ctrl)
    Dim FOND, IMG, groupe, mabarre As CommandBar, bouton
    Set FOND = ActiveSheet.Shapes.AddShape(1, 10, 10, 15, 15): FOND.Line.Visible = False: FOND.Fill.ForeColor.RGB = (ctrl.BackColor): FOND.Fill.Visible = True
    Set IMG = ActiveSheet.Pictures.Insert(url): IMG.Width = 15: IMG.Height = 15: IMG.Top = FOND.Top: IMG.Left = FOND.Left
    Set groupe = ActiveSheet.Shapes.Range(Array(IMG.Name, FOND.Name)).Group
    groupe.Copy: groupe.Delete
     delpopup "temp"
    Set mabarre = CommandBars.Add("temp", msoBarPopup, False, True): Set bouton = mabarre.Controls.Add(Type:=msoControlButton): bouton.PasteFace
    Set paste_png_on_CMB_control = bouton.Picture
    delpopup "temp"
End Function
' FIN DE METHODE 6
'********************************************************************************************************************

je dépose quand même un fichier pour les intéressés

voila les codes sont relativement simple a comprendre

Bonne utilisation

**patricktoulon** · 03/02/2017, 15h49

re
une fois n'est pas coutume hein!!! ca c'est tout moi !!!

j'en rajoute une pour les PNG/GIF
en effet avec les apis on peut se permettre des icones un petit peu plus gros

j'ai donc ajouté png avec Apis
je change donc la piece jointe du premier post
démo animée
Nom : demo2.gif
Affichages : 571
Taille : 140,3 Ko

Nom : demo2.gif
Affichages : 571
Taille : 140,3 Ko

laissez moi le temps de changer la pièce jointe
petite précision
la méthode png avec api et sans api fonctionne aussi avec les fichier icone (".ico") et les cliparts (wmf ou gif)