MENU CRÉE DYNAMIQUEMENT (SANS PASSER PAR L'ASSISTANT DE VB)

'déclaration des constantes API privées à l'objet
Private Const MIIM_ID = &H2
Private Const MIIM_TYPE = &H10
Private Const MIIM_STATE = &H1
Private Const MIIM_SUBMENU = &H4
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_RETURNCMD = &H100&
Private Const TPM_RIGHTBUTTON = &H2&
Private Const MFT_RADIOCHECK = &H200&
Private Const MFT_CHECKED = &H8&
Private Const MFT_STRING = &H0
Private Const MFS_ENABLED = &H0

'déclaration des types privés à l'objet
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

Private Type POINTAPI
    x As Long
    y As Long
End Type

'déclaration des fonctions API privées à l'objet
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function InsertMenuItem Lib "user32.dll" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Long, lpmii As MENUITEMINFO) As Long
Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal hwnd As Long, ByVal lptpm As Any) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long

Public Function AfficherMenu() As Long

'======================================================
'Permet de créer le menu, puis de l'afficher
'
'Renvoie l'ID du menu cliqué
'Renvoie -1 en cas d'erreur
'======================================================

'on active la routine de traitement d'erreur
On Error GoTo erreur0

'déclaration des variables privées
Dim pMenuInfo As MENUITEMINFO 'définit les info de l'item de menu ajouté
Dim pPositionCurseur As POINTAPI 'stocke la position actuelle du curseur
Dim lHandleMenu As Long 'stocke le handle du menu
Dim lHandleSousMenu(1) As Long 'stocke les handles des sous-menus
Dim lHandleSousSousMenu(1) As Long 'stocke les handles des sous-sous-menus

    'on définit le handle du menu popup
    Let lHandleMenu = CreatePopupMenu
    Let lHandleSousMenu(0) = CreatePopupMenu
    Let lHandleSousMenu(1) = CreatePopupMenu
    Let lHandleSousSousMenu(0) = CreatePopupMenu
    Let lHandleSousSousMenu(1) = CreatePopupMenu
    
    'on définit le nouveau sous-sous-menu  :
    With pMenuInfo
        Let .cbSize = Len(pMenuInfo)
        Let .fType = MFT_STRING
        Let .fState = MFS_ENABLED
        Let .dwTypeData = "Sous-Sous-Menu1"
        Let .cch = Len(pMenuInfo.dwTypeData)
        Let .wID = 100
        Let .fMask = MIIM_ID Or MIIM_TYPE Or MIIM_STATE
    End With
    Call InsertMenuItem(lHandleSousMenu(0), 0, True, pMenuInfo)
          
    'on définit le nouveau sous-sous-menu  :
    With pMenuInfo
        Let .cbSize = Len(pMenuInfo)
        Let .fType = MFT_STRING
        Let .fState = MFS_ENABLED
        Let .dwTypeData = "Sous-Sous-Menu2"
        Let .cch = Len(pMenuInfo.dwTypeData)
        Let .wID = 101
        Let .fMask = MIIM_ID Or MIIM_TYPE Or MIIM_STATE
    End With
    Call InsertMenuItem(lHandleSousMenu(0), 1, True, pMenuInfo)
                            
    'on insère un nouveau menu dans le menu courant :
    With pMenuInfo
        Let .cbSize = Len(pMenuInfo)
        Let .fType = MFT_STRING
        Let .fState = MFS_ENABLED
        Let .dwTypeData = "Sous-Menu1"
        Let .cch = Len(pMenuInfo.dwTypeData)
        Let .wID = 0
        Let .fMask = MIIM_ID Or MIIM_TYPE Or MIIM_STATE Or MIIM_SUBMENU
        Let .hSubMenu = lHandleSousMenu(0)
    End With
    Call InsertMenuItem(lHandleMenu, 0, True, pMenuInfo)
      
    'on définit le nouveau sous-sous-menu  :
    With pMenuInfo
        Let .cbSize = Len(pMenuInfo)
        Let .fType = MFT_STRING
        Let .fState = MFS_ENABLED
        Let .dwTypeData = "Sous-Sous-Menu1"
        Let .cch = Len(pMenuInfo.dwTypeData)
        Let .wID = 102
        Let .fMask = MIIM_ID Or MIIM_TYPE Or MIIM_STATE
    End With
    Call InsertMenuItem(lHandleSousMenu(1), 0, True, pMenuInfo)
          
    'on définit le nouveau sous-sous-menu  :
    With pMenuInfo
        Let .cbSize = Len(pMenuInfo)
        Let .fType = MFT_STRING
        Let .fState = MFS_ENABLED
        Let .dwTypeData = "Sous-Sous-Menu2"
        Let .cch = Len(pMenuInfo.dwTypeData)
        Let .wID = 103
        Let .fMask = MIIM_ID Or MIIM_TYPE Or MIIM_STATE
    End With
    Call InsertMenuItem(lHandleSousMenu(1), 1, True, pMenuInfo)

    'on insère un nouveau menu dans le menu courant :
    With pMenuInfo
        Let .cbSize = Len(pMenuInfo)
        Let .fType = MFT_STRING
        Let .fState = MFS_ENABLED
        Let .dwTypeData = "Sous-Menu2"
        Let .cch = Len(pMenuInfo.dwTypeData)
        Let .wID = 1
        Let .fMask = MIIM_ID Or MIIM_TYPE Or MIIM_STATE Or MIIM_SUBMENU
        Let .hSubMenu = lHandleSousMenu(1)
    End With
    Call InsertMenuItem(lHandleMenu, 1, True, pMenuInfo)

    'on affiche le menu crée
    Call GetCursorPos(pPositionCurseur)
    Let AfficherMenu = TrackPopupMenuEx(lHandleMenu, TPM_LEFTALIGN Or TPM_RIGHTBUTTON Or TPM_RETURNCMD, pPositionCurseur.x, pPositionCurseur.y, Me.hwnd, ByVal 0&)
    Call DestroyMenu(lHandleMenu)
    Call DestroyMenu(lHandleSousMenu(0))
    Call DestroyMenu(lHandleSousMenu(1))
    Call DestroyMenu(lHandleSousSousMenu(0))
    Call DestroyMenu(lHandleSousSousMenu(1))
      
'la fonction a réussie
Exit Function

'routine de traitement d'erreur
erreur0:
'Problème : On n'a pas pu afficher le menu ou on ne connaît pas l'ID du menu sélectionné
'Solution : On renvoie une valeur d'erreur : -1

Let AfficherMenu = -1

End Function

Private Sub Form_Click()

    Select Case AfficherMenu
    
        Case 100
        
            MsgBox "Vous avez cliquez sur le sous-sous menu 1 du sous-menu 1"
        
        Case 101

            MsgBox "Vous avez cliquez sur le sous-sous menu 2 du sous-menu 1"

        Case 102
        
            MsgBox "Vous avez cliquez sur le sous-sous menu 1 du sous-menu 2"
        
        Case 103
    
            MsgBox "Vous avez cliquez sur le sous-sous menu 2 du sous-menu 2"
    
    End Select

End Sub

Télécharger le zip