|
begin process at 2008 05 17 03:03:40
Derniers logiciels
|
Trouver une ressource
Vous ne trouvez pas de réponse à votre problème ? Alors posez la question dans le forum.
Souvenez-vous qu'il n'y a jamais de question bête, mais rester dans l'ignorance parce que l'on n'ose pas poser une question, ça c'est une erreur !
CONTROLE MENU => RENDRE INVISIBLE LES MENUS ET SOUS MENUS
Information sur la source
Description
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
- 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
-
-
-
-
-
-
-
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
Sources de la même categorie
Commentaires
Discussions en rapport avec ce code source
|
Téléchargements
Logiciels à télécharger sur le même thème :
|
|