XL 2013 icon avec une image Mso dans la barre de titre du UserForm

[patricktoulon]

bonjour à tous
je me creuse la tête depuis toute à l' heure
j'essaie de mettre une icon dans la barre de titre du Userform
alors ca me met un icon (type unknow)mais l'icon que je souhaite
quelqu'un a une idée ?

Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Const WM_SETICON As Long = &H80
Private Sub CommandButton1_Click()

    Dim hwnd As LongPtr, hIcon As LongPtr

    'on met une image MSO dans le control image dans la feuille
    With ActiveWorkbook.Sheets("Feuil1").pict
        .Picture = Application.CommandBars.GetImageMso("ChartDataLabel", 20, 20)
        hIcon = .Picture.Handle    'on récupère le handle du picture
    End With
    Label1 = "handle du picture : " & hIcon
    hwnd = FindWindowA(vbNullString, Me.Caption)    'determine la fenêtre

    SendMessageA hwnd, WM_SETICON, 0, hIcon  'on met le petit icon

    SendMessageA hwnd, WM_SETICON, 1, hIcon  'on met le gros icon

    DrawMenuBar hwnd
End Sub

 

[Eric 45]

Bonsoir à tous
Bonsoir Patrick

J'ai trouvé ce code au fond de mon ordi, c'est ce que tu cherches ?

‘Attribute VB_Name = "IconePersoSurUserform"

'mettre une icone de son choix dans la barre de titre d'un Userform
'(le fichier icône peut être un fichier.ico ou
'un exécutable contenant une ou plusieurs icônes)
'Michel Pierron, mpfe

'le code est à recopier dans le module de code d'un Userform

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
      (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SendMessageA Lib "user32" _
      (ByVal hwnd As Long, ByVal wMsg As Long, _
      ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Declare Function ExtractIconA Lib "shell32.dll" _
      (ByVal hInst As Long, ByVal lpszExeFileName As String, _
      ByVal nIconIndex As Long) As Long

Private Sub UserForm_Initialize()
Const IcoPath As String = "D:\Cheni2001\Icones\bebox\Clock.ico"
Dim hIcon As Long

  hIcon = Len(Dir(IcoPath))

  If hIcon = 0 Then Exit Sub
  hIcon = ExtractIconA(0, IcoPath, 0)
  SendMessageA FindWindow(vbNullString, Me.Caption), &H80, False, hIcon
End Sub

C'est de Frédéric Sigoneau

A+

Eric

 

[patricktoulon]

Bonsoir @Eric 45
merci du retour mais non ce n'est pas ça
ton exemple extrait l'icon d'un fichier (ça j'ai)
moi je veux extraire l'image d'un control par son handle

le pire c'est que je n'ai aucune erreur relevée

 

[dysorthographie]

Bonjour Patrick,
Ici c'est une image pas une icone c'est pas compatible!

lngIcon = Application.CommandBars.GetImageMso("ChartDataLabel", 20, 20).Handle

fais la comparaison entre un Gif et un ICO!

lngIcon = ExtractIcon(0, strIconPath, 0)

 

[patricktoulon]

bonsoir robert
c'est pas le handle de la mso que je prends mais celui du control image sur une feuille
j'ai essayé avec un gif jpeg ca ne fonctionne pas pourtant je l'ai pas inventé ce truc

Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Const WM_SETICON As Long = &H80
Private Sub CommandButton1_Click()

    Dim hwnd As LongPtr, hIcon As LongPtr
    MsgBox "handle mso : " & Application.CommandBars.GetImageMso("ChartDataLabel", 20, 20).Handle
    'on met une image MSO dans le control image dans la feuille
    With ActiveWorkbook.Sheets("Feuil1").pict
        .Picture = Application.CommandBars.GetImageMso("ChartDataLabel", 20, 20)
        hIcon = .Picture.Handle    'on récupère le handle du picture
        MsgBox "handle controls image : " & hIcon
    End With
    Label1 = "handle du picture : " & hIcon
    hwnd = FindWindowA(vbNullString, Me.Caption)    'determine la fenêtre

    SendMessageA hwnd, WM_SETICON, 0, hIcon  'on met le petit icon

    SendMessageA hwnd, WM_SETICON, 1, hIcon  'on met le gros icon

    DrawMenuBar hwnd
End Sub

 

[dysorthographie]

Le userform n'accepte que des *.Ico

Le picture n'acepte pas des *.ici.

 

[patricktoulon]

ok
je viens d'essayer avec extracticon sur l'exe de excel ca ne fonctionne pas non plus

Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function ExtractIconA Lib "shell32.dll" (ByVal hInst As LongPtr, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As LongPtr
Const WM_SETICON As Long = &H80
Private Sub CommandButton1_Click()

    Dim hwnd As LongPtr, hIcon As LongPtr
    
    hIcon = ExtractIconA(0, "C:\Program Files (x86)\Microsoft Office\Office15\EXCEL.EXE", 0)
  
   hwnd = FindWindowA(vbNullString, Me.Caption)    'determine la fenêtre

    SendMessageA hwnd, WM_SETICON, 0, hIcon  'on met le petit icon

    SendMessageA hwnd, WM_SETICON, 1, hIcon  'on met le gros icon

    DrawMenuBar hwnd
End Sub

j'ai toujours l'icon unknowfile

 

[dysorthographie]

chez moi ça fonctionne!

  lngIcon = ExtractIcon(0, "C:\Program Files (x86)\Microsoft Office\Office12\EXCEL.EXE", 0)
    'lngIcon = Application.CommandBars.GetImageMso("ChartDataLabel", 20, 20).Handle
     lnghWnd = FindWindow(vbNullString, UserForm1.Caption)
     SendMessage lnghWnd, WM_SETICON, True, lngIcon
     SendMessage lnghWnd, WM_SETICON, False, lngIcon

 

[patricktoulon]

bon ben il me parait évident que c'est les déclarations qui vont pas puisqu'avec ma méthode macro4 ça marche
donc qu'est ce qui ne va pas dans ces déclarations ????
tout du moins pour vba7 32 bits

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function ExtractIconA Lib "shell32.dll" (ByVal hInst As LongPtr, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As LongPtr
#Else
    Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function SendMessageA Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ExtractIconA Lib "shell32.dll" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
#End If
Const WM_SETICON As Long = &H80
Private Sub CommandButton1_Click()
'marche pas
    Dim hwnd As LongPtr, hIcon As LongPtr

    hIcon = ExtractIconA(0, "C:\Program Files (x86)\Microsoft Office\Office15\EXCEL.EXE", 1)

    hwnd = FindWindowA(vbNullString, Me.Caption)    'determine la fenêtre

    SendMessageA hwnd, WM_SETICON, True, hIcon  'on met le petit icon

    SendMessageA hwnd, WM_SETICON, False, hIcon  'on met le gros icon

    DrawMenuBar hwnd
End Sub

Private Sub CommandButton2_Click()
    'ca marche
    Dim fichier
    fichier = "C:\Program Files (x86)\Microsoft Office\Office15\EXCEL.EXE"

    hwnd& = ExecuteExcel4Macro("CALL(""user32"",""GetActiveWindow"",""JCC"")")         'api GetActiveWindow

    hIcon = ExecuteExcel4Macro("CALL(""shell32"",""ExtractIconA"",""JJCJ""," & 0 & ",""" & fichier & """," & 0 & ")")

    ExecuteExcel4Macro "CALL(""user32"",""SendMessageA"",""JJJJJ""," & hwnd & "," & &H80 & "," & 0 & "," & hIcon & ")"

    ExecuteExcel4Macro "CALL(""user32"",""SendMessageA"",""JJJJJ""," & hwnd & "," & &H80 & "," & 1 & "," & hIcon & ")"

End Sub

 

[dysorthographie]

moi je suis en 2007

 Private Declare Function FindWindow _
     Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, _
     ByVal lpWindowName As String) As Long

 Private Declare Function ExtractIcon _
     Lib "shell32.dll" Alias "ExtractIconA" _
    (ByVal hInst As Long, _
     ByVal lpszExeFileName As String, _
     ByVal nIconIndex As Long) As Long

 Private Declare Function SendMessage _
     Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, _
     ByVal wMsg As Long, _
     ByVal wParam As Integer, _
     ByVal lParam As Long) As Long

 

[patricktoulon]

bon ca se presise
c'est sendmessage qui ne fonctionne pas donc la déclaration n'est pas bonne

la bonne déclaration vba7(c'etait le integer et le long pour wparam et lparam a la place de long et Any

Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hWnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As Integer, ByVal lParam As LongPtr) As LongPtr

bon maintenant je vais pouvoir tester

merci robert