Modifier l'image d'un bouton de barre d'outils en VBA

[papyjac]

Bonjour,

Après plusieurs heures de recherche je sèche lamentablement

j'ai crée le code suivant après avoir trouver plusieurs exemples similaires sous Visual Basic

Public Declare Function GetPixel Lib "GDI32.DLL" (ByVal hDC As Long, ByVal XPos As Long, ByVal nYPos As Long) As Long
Sub Test()
'_Afficher les pixels
Dim U_Objet1 As IPictureDisp ' Objet image
Dim X As Long
Dim Y As Long
'-
Set U_Objet1 = stdole.StdFunctions.LoadPicture("C:\Test.bmp")
With U_Objet1
For X = 0 To .Height - 1
For Y = 0 To .Width - 1
If Y < 256 Then
Cells(X + 1, Y + 1) = GetPixel(.Handle, X, Y)
End If
Next
Next
End With
End Sub

Il s'agit d'une fonction de test
A ce stade, la fonction Getpixel renvoie toujours -1, je suppose qu'il s'agit de FAUX
dès que je trouverais un résultat, je souhaite modifier la birmap avec Setpixel avant de l'afficher dans le bouton avec l'instruction .picture = U_Objet

J'ai surfer plusieurs heures dans les GetObjectAPI, Pset... mais je pense que je n'ai pas compris la manière de prendre le problème, simple à priori.

Je n'ai rien trouvé de similaire sous le VBA Excel pour l'instant

Merci de votre contribution

 

[BERRACHED said]

Re : Modifier l'image d'un bouton de barre d'outils en VBA

Salut,papyjac

il existe aussi ça :

coller sur un bouton de barre d'outils une image perso
'stockée dans une feuille du classeur (utile avec .xla)

Public Const nomBO = "EssaiBO"

Sub CreateBO()
Dim bo As CommandBar, wbk As Workbook
  On Error Resume Next
  deleteBO 'en cas de plantage intempestif d'Excel :-)
  
  Set bo = Application.CommandBars.Add(nomBO)
  
  'copie du bitmap stocké en feuille 1
  On Error GoTo Fin
  ThisWorkbook.Sheets("Feuil1").Shapes("Image 2").Copy
  
  With bo.Controls.Add(msoControlButton)
    .Caption = "LanceMacro1"
    .Style = msoButtonIconAndCaption
    ' coller l'icone personnalisée
    .PasteFace
    .OnAction = "Macro1" 'tu lui affecte une macro
  End With
  bo.Visible = True
  Exit Sub
Fin:
  MsgBox "L'image à copier n'existe pas..."
  deleteBO
End Sub

Sub Macro1()
  MsgBox "Et voilà le Boulot !"
  deleteBO
End Sub

Cordialement

 

[papyjac]

Re : Modifier l'image d'un bouton de barre d'outils en VBA

Bonjour Said

Et merci.
Je connais bien cette pratique, mais je voulais bricoler quelques Pixels de mon image avant de la copier dans le bouton.

Je sais aussi que je peux le faire sous PAINT

En fait, ça me fatique maintenant, j'ai une centaine d'images de bouton à bricoler. Et j'ai vu qu'on pouvait utiliser les fonctions GETPIXEL et SETPIXEL mais je n'ai pas encore résussi à les utiliser

Encore Merci

Papyjac

 

[PMO2]

Re : Modifier l'image d'un bouton de barre d'outils en VBA

Bonjour,

Une piste avec le code suivant

*************
Sub BoutonBitmap()
Dim MonBitMap As stdole.StdPicture
On Error Resume Next
CommandBars("PMO").Delete
With CommandBars.Add(Name:="PMO", Position:=msoBarRight, Temporary:=True)
With .Controls.Add(Type:=msoControlButton)
.OnAction = "PMO_Macro"
.TooltipText = "Test.bmp"
Set MonBitMap = stdole.StdFunctions.LoadPicture("c:\Test.bmp")
.Picture = MonBitMap
End With
.Visible = True
End With
End Sub

Sub PMO_Macro(Optional dummy As Byte)
MsgBox "Coucou"
End Sub
*************

Cordialement.

PMO
Patrick Morange

 

[papyjac]

Re : Modifier l'image d'un bouton de barre d'outils en VBA

Bonjour PMO2,

Je suis d'accord avec ton code, dans lequel je souhaite modifier quelques Pixel de la Bitmap => ICI dans ton code. Mais GETPixel me renvoie toujours -1


*************
Sub BoutonBitmap()
Dim MonBitMap As stdole.StdPicture
On Error Resume Next
CommandBars("PMO").Delete
With CommandBars.Add(Name:="PMO", Position:=msoBarRight, Temporary:=True)
With .Controls.Add(Type:=msoControlButton)
.OnAction = "PMO_Macro"
.TooltipText = "Test.bmp"
Set MonBitMap = stdole.StdFunctions.LoadPicture("c:\Test.bmp")

ICI, je souhaite modifier quelques pixel avec l'instruction
With monbitmap
For I = 0 to .height -1
For J = 0 .width -1
msgbox Getpixel(.handle, I, J)
next
next

.Picture = MonBitMap
End With
.Visible = True
End With
End Sub

Sub PMO_Macro(Optional dummy As Byte)
MsgBox "Coucou"
End Sub
*************

Cordialement.

PMO
Patrick Morange