tout le monde connait la propriété visible d'un controle menu. mais VB 6 a un souci, on ne peut pas rendre invisible tous les sous menus d'un menu. lors de la tentative de rendre invisible le dernier de la liste, on a une erreur 387.
ce petit module permet de contourner ce probleme.
dans le code il suffit de mettre la propriété enabled à false pour chaque menu à supprimer
puis d'appeler la fonction "InvisibleMenu" en passant en param l'objet MDI hébergeant le menu à traiter.
la fonction supprime tous les menus "disable" et supprime le menu parent si celui ci n'a plus d'enfant.
Source / Exemple :
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
Conclusion :
A vos remarques, suggestions, critiques
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.