AJOUTER DES IMAGES DANS UN MENU

Commentaire de lionyz le 07/03/2009 11:30:03

Au 4ème essai et après quelques modifications j'ai réussi à faire fonctionner ce programme

J'ai supprimé le redimensionnement pas vraiment indispensable.
ça marche sauf pour les popupmenus; quand on décoche la case 'Visible' dans le créateur de menus les images
n'apparaissent plus dans les sou-menus
Si quelqu'un à une idée sur le sujet, merci de nous la faire partager.

Exemple de menu dans une Form qui contient les menus sous-menus et les images en non visible

Fichiers
Ouvrir
Enregistrer
Imprimer

Dans la Form

Private Sub Form_Load()

...........

'Ajouter Icons dans menus
Dim hMenu As Long
hMenu = GetMenu(Me.hWnd)

AddIconToMenu "Ouvrir" , PicOuvrir.Picture, hMenu
AddIconToMenu "Enregistrer" , PicEnregistrer.Picture, hMenu
AddIconToMenu "Imprimer" , PicImprimer.Picture, hMenu

............

End Sub

Dans un module


Option Explicit

'******************************* TYPES APIs ************************************
Private Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wid As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type


'**************************** CONSTANTES APIs **********************************
Public Const SM_CXMENUCHECK = 71
Public Const SM_CYMENUCHECK = 72

Private Const MENU_IDENTIFIER As Long = &H1
Private Const MIIM_TYPE = &H10
Private Const MIIM_SUBMENU = &H4
Private Const MIIM_STATE As Long = &H1
Private Const MIIM_ID As Long = &H2
Private Const MIIM_CHECKMARKS As Long = &H8
Private Const MIIM_DATA As Long = &H20
Private Const MF_POPUP = &H10
Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400
Private Const MF_SEPARATOR = &H800
Private Const MF_BITMAP = &H4&
Private Const MFT_STRING As Long = &H0
Private Const MFT_BITMAP = MF_BITMAP
Private Const MFT_RADIOCHECK = &H200&


'********************************  APIs ****************************************

Public Declare Function GetMenu Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Function GetSubMenu Lib "User32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuCheckMarkDimensions Lib "User32" () As Long
Private Declare Function GetMenuItemCount Lib "User32" (ByVal hMenu As Long) As Long
Private Declare Function GetMenuItemID Lib "User32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuItemInfo Lib "User32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal ByPos As Boolean, lpmii As MENUITEMINFO) As Long
Private Declare Function SetMenuItemInfo Lib "User32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal ByPos As Long, lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function ModifyMenuPic Lib "User32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Long) As Long
Public Declare Function SetMenuItemBitmaps Lib "User32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long


'****************************** FONCTION ****************************************
Public Sub AddIconToMenu(ByVal pMenuLabel As String, ByVal pMenuPicture As Long, hMenu As Long)
    Dim ret As Long, hSubMenu As Long
    Dim MenuID As Long, CurMenu As MENUITEMINFO
    Dim NbMenus As Long, NbSubMenus As Long
    Dim i As Long, j As Long
    
    'Recherche de l'ID de l'item de menu dont le libellé est passé en paramètre
    NbMenus = GetMenuItemCount(hMenu)
    For i = 0 To NbMenus
        hSubMenu = GetSubMenu(hMenu, i)
        NbSubMenus = GetMenuItemCount(hSubMenu)
        For j = 0 To NbSubMenus
            With CurMenu
                .cbSize = Len(CurMenu)
                .fMask = MIIM_TYPE
                .fType = MFT_STRING
                .dwTypeData = vbNullString
                .cch = Len(.dwTypeData)
                
                 ret = GetMenuItemInfo(hSubMenu, j, MENU_IDENTIFIER, CurMenu)
                
                .dwTypeData = Space$(.cch + 1)
                .cch = Len(.dwTypeData)
                
                ret = GetMenuItemInfo(hSubMenu, j, MENU_IDENTIFIER, CurMenu)
                If Left$(Trim$(.dwTypeData), Len(pMenuLabel)) = pMenuLabel Then MenuID = GetMenuItemID(hSubMenu, j): Exit For
                MenuID = 0
            End With
        Next
        If MenuID <> 0 Then Exit For
    Next
    
    If MenuID = 0 Then Exit Sub 'Elément de menu non trouvé
    
    'Affection au menu
    SetMenuItemBitmaps hSubMenu, MenuID, MF_BYCOMMAND, pMenuPicture, pMenuPicture

End Sub