Discussion :

[Tenanio]

Bonjour à tous,

J'aurais besoin de vos lumières sur un truc vraiment tout bête mais qui me bloque. Je souhaite insérer une icône sur un bouton d'un menu perso. Cette icône est une image BMP en 16x16 située sur un contrôle Image.

Est-il possible de reprendre cette image en guise d'icône sans passer par une insertion dans une feuille puis par un Copy et un PasteFace ?

Sinon, est-il possible de directement récupérer l'image dans un dossier et l'appliquer sur le bouton toujours sans passer par une insertion dans une feuille puis par un Copy et un PasteFace ?

Merci d'avance.

Tenanio.

[sabzzz]

bonjour Tenanio,

il y a cette exemple dans l'aide xl2002, sous la rubrique "Picture, propriété"

Code :

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

1
2
3
Dim picPicture As IPictureDisp
Set picPicture = stdole.StdFunctions.LoadPicture("c:\temp\picture.bmp")
Application.CommandBars("MaBarre").Controls(1).Picture = picButton

[Tenanio]

Hello Sabzzz et merci pour ton aide.

J'ai adapté le code que tu m'as donné mais malheureusement j'ai une erreur.

Une idée ?

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
Dim picButton As IPictureDisp
Dim NouveauMenu As CommandBarControl
 
Set picButton = stdole.StdFunctions.LoadPicture(Environ("APPDATA") & "\Microsoft\Macros complémentaires\bouton_minuscule.bmp")
 
Set NouveauMenu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
 
With NouveauMenu
	.Caption = "[Outils +]"
End With
 
Set LeMenu = NouveauMenu.Controls.Add(msoControlButton)
 
With LeMenu
	.FaceId = 0
	.Caption = "Mettre le texte de la sélection en minuscule"
	.OnAction = "minuscules"
	.Picture = picButton 'Erreur sur cette ligne : Propriété ou méthode non gérée par cet objet
End With

[sabzzz]

bonjour Tenanio,

désolé je t'ai induit en erreur, la méthode que je t'avais suggéré suppose qu'on a copier auparavent l'image d'un bouton dans un fichier temporaire.

un autre solution qui rejoint ce que tu disais "copier un image sur la feuille"
mais il est possible de le faire sans le voir,

Code :

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

1
2
3
4
5
6
7
8
9
10
Sub test()
Application.ScreenUpdating = False
Dim p As Object
Set p = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\monimage.bmp")
p.CopyPicture xlScreen, xlPicture
Application.CommandBars("mabarre").Controls(1).PasteFace
p.Delete
Set p = Nothing
Application.ScreenUpdating = True
End Sub

[Tenanio]

Ce qui me gêne sur ce code c'est le fait de passer par l'intermédiaire d'une feuille...

J'aimerai, si on est vraiment obligé de passer par un copier-coller, utiliser plutôt un contrôle Image d'un Userform comme source.

Je vais essayer de voir si c'est possible avec ton dernier code.

Merci en tout cas de ton aide

[Tenanio]

Bon voici une réponse en passant par une ImageList contenue sur un Userform. Les parties de codes n°1, n°3 et n°4 sont à placer impérativement dans le même module.

1) Code à placer en entête d'un module vierge :

Code :

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

1
2
3
4
5
Private Declare Function OpenClipboard& Lib "user32" (ByVal hwnd As Long)
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData& Lib "user32" (ByVal wFormat&, ByVal hMem&)
Private Declare Function CloseClipboard& Lib "user32" ()
Private Declare Function DestroyIcon& Lib "user32" (ByVal hIcon&)

2) Code permettant l'insertion d'une image sur l'ImageList (http://silkyroad.developpez.com/VBA/ImageList/#LIII-A-1) :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub AddImagesToImageList()
 
    Dim MyPath As String
 
    UserForm1.ImageList1.ListImages.Clear
 
    MyPath = Environ("APPDATA") & "\Microsoft\Macros complémentaires\bouton_1.bmp"
    UserForm1.ImageList1.ListImages.Add , "Bouton 1", LoadPicture(MyPath)
 
    MyPath = Environ("APPDATA") & "\Microsoft\Macros complémentaires\bouton_2.bmp"
    UserForm1.ImageList1.ListImages.Add , "Bouton 2", LoadPicture(MyPath)
 
End Sub

3) Code permettant de copier l'image de l'ImageList dans le presse-papier (on ne passe pas par une feuille de calcul) (http://silkyroad.developpez.com/VBA/ImageList/#LIII-A-5) :

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
Sub AddImageToClipBoard(ImageNumber As Double)
 
    Dim iPic As StdPicture
    Dim hCopy&
 
    'Spécifie l'image cible
    Set iPic = UserForm1.ImageList1.ListImages(ImageNumber).Picture
 
    'Ouverture du presse papier
    OpenClipboard 0&: EmptyClipboard
    'Place l'image dans le presse papier
    hCopy = SetClipboardData(2, iPic.Handle)
 
    'Fermeture du presse papier
    CloseClipboard
 
    Set iPic = Nothing
 
End Sub

4) Code permettant de supprimer la copie de l'image contenue dans le presse-papier (ClipBoard) :

Code :

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

1
2
3
4
5
6
7
8
9
Sub RemoveImageFromClipBoard(ImageNumber As Double)
 
    Set iPic = UserForm1.ImageList1.ListImages(ImageNumber).Picture
 
    'Ménage
    DestroyIcon iPic.Handle
    Set iPic = Nothing
 
End Sub

5) Code principal permettant de créer un menu avec 2 sous-menu avec les images persos :

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
Sub MenuPerso()
 
    Call AddImagesToImageList
 
    Set NouveauMenu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
 
    With NouveauMenu
        .Caption = "Menu Perso"
    End With
 
    Call AddImageToClipBoard(1)
    Set LeMenu = NouveauMenu.Controls.Add(msoControlButton)
    With LeMenu
        .FaceId = 0
        .Caption = "Bouton 1"
        .OnAction = "test1"
        .PasteFace
    End With
    Call RemoveImageFromClipBoard(1)
 
    Call AddImageToClipBoard(2)
    Set LeMenu = NouveauMenu.Controls.Add(msoControlButton)
    With LeMenu
        .FaceId = 0
        .Caption = "Bouton 2"
        .OnAction = "test2"
        .PasteFace
    End With
    Call RemoveImageFromClipBoard(2)
 
End Sub