CONTROLE MENU => RENDRE INVISIBLE LES MENUS ET SOUS MENUS

Option Explicit
'Declaration des Api de gestion des menus
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" ( _
                        ByVal hMenu As Long, ByVal un As Long, ByVal b As Boolean, _
                        lpmii As MENUITEMINFO) As Long

Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, _
                                            ByVal nPos As Long) As Long

Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long

' Menu flags for Add/Check/EnableMenuItem()
Private Const MF_INSERT = &H0&
Private Const MF_CHANGE = &H80&
Private Const MF_APPEND = &H100&
Private Const MF_DELETE = &H200&
Private Const MF_REMOVE = &H1000&

Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400&

Private Const MF_SEPARATOR = &H800&

Private Const MF_ENABLED = &H0&
Private Const MF_GRAYED = &H1&
Private Const MF_DISABLED = &H3&

Private Const MF_UNCHECKED = &H0&
Private Const MF_CHECKED = &H8&
Private Const MF_USECHECKBITMAPS = &H200&


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 Const MIIM_STATE = &H1
Private Const MIIM_ID = &H2
Private Const MIIM_TYPE = &H10
Private Const MIIM_SUBMENU = &H4
Private Const MFS_DEFAULT = &H1000
Private Const MFS_DISABLED = &H3

Private Const MF_STRING = &H0&

Private rsMenu As Recordset



Public Function InvisibleMenu(mdiFrm As MDIForm) As Boolean
' Parcours les menus de la fenêtre donnée en paramètre
On Error GoTo errInvisibleMenu

Dim hMenu         As Long           'Handle du menu de la form
Dim hSubMenu      As Long           'Handle d'un sous menu
Dim lNbMenu       As Long           'Nb menu
Dim lgRet         As Long           'Code retour API
Dim i             As Integer        'Variable de boucle
Dim stBuffer      As String * 80    'Buffer de récupération du nom du menu
Dim lpItemInfo    As MENUITEMINFO   'Structure contenant les infos sur le menu
Dim lNbSousMenu   As Long           'Nombre de sous menu
Dim rsSousMenu    As Recordset      'Recorset clone du RSMenu

'Construction du recordset
Set rsMenu = Nothing
Set rsMenu = New Recordset
   
With rsMenu
   .Fields.Append "MenuName", adVarChar, 50                    'Nom du menu
   .Fields.Append "MenuNiveau", adBigInt                       'Niveau du menu
   .Fields.Append "flgInactif", adBoolean                      'menu Inactif
   .Fields.Append "MenuParent", adVarChar, 50, adFldIsNullable 'Nom du menu parent
   .Fields.Append "IDParent", adInteger, , adFldIsNullable     'Id du parent
   .Fields.Append "IDMenu", adInteger                          'Id du menu
   .Fields.Append "Position", adInteger                        'Position du menu dans la liste
   .Fields.Append "hHandle", adBigInt                          'Handle du menu parent
   .Fields.Append "nbSousMenu", adInteger                      'Nombre de sous menu
   .Open
End With

'Récupère un pointeur vers le menu courant
hMenu = GetMenu(mdiFrm.hwnd)

'Récupère le nombre d'élément de premier niveau
lNbMenu = GetMenuItemCount(hMenu)

'Parcours les éléments de premier niveau
For i = 0 To lNbMenu - 1
    ' Initialisation de la structure
    lpItemInfo.cbSize = 44
    lpItemInfo.dwTypeData = stBuffer & Chr$(0)
    lpItemInfo.fType = MF_STRING
    lpItemInfo.cch = 80
    lpItemInfo.fState = MFS_DEFAULT
    lpItemInfo.fMask = MIIM_ID Or MIIM_STATE Or MIIM_TYPE Or MIIM_SUBMENU
    'Récupère le contenu du menu
    lgRet = GetMenuItemInfo(hMenu, i, True, lpItemInfo)
    lpItemInfo.dwTypeData = Replace(lpItemInfo.dwTypeData, Chr$(0), vbNullString)
    
    'Récupère le nb de sous menu du menu courant pour insertion ensuite dans le RS
    lNbSousMenu = ExamSubMenu(hMenu, i, 2, lpItemInfo.dwTypeData, lpItemInfo.wID)
    'Ajout d'un élément dans le RS
    With rsMenu
      .AddNew
      .Fields!MenuName.Value = lpItemInfo.dwTypeData
      .Fields!menuniveau.Value = 1
      .Fields!flgInactif = lpItemInfo.fState = MF_DISABLED
      .Fields!MenuParent = ""
      .Fields!IDMenu = lpItemInfo.wID
      .Fields!Position = i
      .Fields!hHandle = hMenu
      .Fields!NbSousMenu = lNbSousMenu
      .Update
    End With
Next

'Création du clone de RS menu
Set rsSousMenu = rsMenu.Clone
'Si on a au moins un menu
If rsMenu.RecordCount > 0 Then
   'Tri par Niveau
   rsMenu.Sort = "MenuNiveau Desc"
   rsMenu.MoveFirst
   While Not rsMenu.EOF
         Debug.Print rsMenu.Fields!MenuName & "-" & CStr(rsMenu.Fields!menuniveau)
         'Examen des sous menus que pour les menus actifs
         rsSousMenu.Filter = "IDParent = " & rsMenu.Fields!IDMenu.Value & " and flginactif = false and MenuName <> 'SEPARATOR'"
         
         If rsSousMenu.EOF Then
            'pas de sous menu ou aucun actif donc on le vire si besoin
            If rsMenu.Fields!NbSousMenu > 0 Or rsMenu.Fields!flgInactif = True Then
               If rsMenu.Fields!MenuName <> "SEPARATOR" Then
                  rsMenu.Fields!flgInactif = True
                  RemoveMenu rsMenu.Fields!hHandle, rsMenu.Fields!Position, MF_BYPOSITION
               End If
            End If
         Else
            'il y a au moins un sous menu actif mais le menu courant est peut etre inactif
            If rsMenu.Fields!flgInactif = True Then
               RemoveMenu rsMenu.Fields!hHandle, rsMenu.Fields!Position, MF_BYPOSITION
            End If
         End If
         rsMenu.MoveNext
   Wend
End If
Set rsSousMenu = Nothing
Set rsMenu = Nothing

'API qui redessine le menu qui vient d'être traité
DrawMenuBar hMenu
InvisibleMenu = True
Exit Function
errInvisibleMenu:
'Gestion erreur
InvisibleMenu = False
MsgBox "Erreur pendant la gestion des menus " & vbCrLf & Err.Number & " - " & Err.Description, vbCritical, "ERREUR"
End Function

'Fonction récursive pour l'examen des sous menus (renvoi le nombre de sous menu du menu passé en paramètre)
Private Function ExamSubMenu(hMenu As Long, i As Integer, niveau As Integer, NomParent As String, IDParent As Long) As Long
Dim hSubMenu         As Long              'Handle d'un sous menu
Dim lNbMenu          As Long              'Nb menu
Dim lNbSousMenu      As Long              'Nombre de sous menu
Dim lgRet            As Long              'Code retour API
Dim j                As Integer           'Variable de boucle
Dim stBuffer         As String * 80       'Buffer de récupération du nom du menu
Dim lpItemInfo       As MENUITEMINFO      'Structure contenant les infos sur le menu
 
' Récupère un pointeur vers le sous-menu
hSubMenu = GetSubMenu(hMenu, i)
' Récupère le nombre de sous-menus
lNbMenu = GetMenuItemCount(hSubMenu)
' Parcours des éléments de second niveau
If lNbMenu > 0 Then
   For j = 0 To lNbMenu - 1
      ' Mise à niveau de la structure
      lpItemInfo.cbSize = 44
      lpItemInfo.dwTypeData = stBuffer & Chr$(0)
      lpItemInfo.fType = MF_STRING
      lpItemInfo.cch = 80
      lpItemInfo.fState = MFS_DEFAULT
      lpItemInfo.fMask = MIIM_ID Or MIIM_STATE Or MIIM_TYPE Or MIIM_SUBMENU
      ' Récupère le contenu du sous-menu
      lgRet = GetMenuItemInfo(hSubMenu, j, True, lpItemInfo)
      lpItemInfo.dwTypeData = Replace(lpItemInfo.dwTypeData, Chr$(0), vbNullString)
      'Récupération du nb de sous menu pour le menu courant + examen des sous menus (appel récursif)
      lNbSousMenu = ExamSubMenu(hSubMenu, j, niveau + 1, lpItemInfo.dwTypeData, lpItemInfo.wID)
      With rsMenu
         .AddNew
         If lpItemInfo.fType = MF_SEPARATOR Then
            .Fields!MenuName.Value = "SEPARATOR"
         Else
            .Fields!MenuName.Value = lpItemInfo.dwTypeData
         End If
         .Fields!menuniveau.Value = niveau
         .Fields!flgInactif = lpItemInfo.fState = MFS_DISABLED
         .Fields!MenuParent = NomParent
         .Fields!IDParent = IDParent
         .Fields!IDMenu = lpItemInfo.wID
         .Fields!Position = j
         .Fields!hHandle = hSubMenu
         .Fields!NbSousMenu = lNbSousMenu
         .Update
      End With
   Next
   ExamSubMenu = lNbMenu
Else
   ExamSubMenu = 0
End If

End Function