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

patricktoulon

XLDnaute Barbatruc
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 ?
VB:
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
 

Pièces jointes

  • mettre une image mso en tant qu'icon dans la barre de titre du userform.xlsm
    20.8 KB · Affichages: 19
Solution
moi je suis en 2007
VB:
 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

Eric 45

XLDnaute Occasionnel
Bonsoir à tous
Bonsoir Patrick

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


VB:
‘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

XLDnaute Barbatruc
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

VB:
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
 

patricktoulon

XLDnaute Barbatruc
ok
je viens d'essayer avec extracticon sur l'exe de excel ca ne fonctionne pas non plus
VB:
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

XLDnaute Accro
chez moi ça fonctionne!
VB:
  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

XLDnaute Barbatruc
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
VB:
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

XLDnaute Accro
moi je suis en 2007
VB:
 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

XLDnaute Barbatruc
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

VB:
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 ;)
 

Discussions similaires

Statistiques des forums

Discussions
312 861
Messages
2 092 962
Membres
105 571
dernier inscrit
MAT30190