Menu API For SubMenus

[Yesca]

Using VB6, given an existing menu structure setup in the design environment, how would one, using the caption of an existing menu item, locate the handle to the menu, then dynamically create a sub-menu using the Menu API?

 

[StewartJ]

This code might give you some ideas. It's designed to delete menu items supplied in an array.

'Menu constants

Const MIIM_STATE As Long = &H1
Const MIIM_ID As Long = &H2
Const MIIM_SUBMENU As Long = &H4
Const MIIM_CHECKMARKS As Long = &H8
Const MIIM_TYPE As Long = &H10
Const MIIM_DATA As Long = &H20

Const MFT_STRING As Long = &H0
Const MFT_BITMAP As Long = &H4
Const MFT_MENUBARBREAK As Long = &H20
Const MFT_MENUBREAK As Long = &H40
Const MFT_OWNERDRAW As Long = &H100
Const MFT_RADIOCHECK As Long = &H200
Const MFT_RIGHTJUSTIFY As Long = &H4000
Const MFT_RIGHTORDER As Long = &H2000
Const MFT_SEPARATOR As Long = &H800

Const MFS_CHECKED As Long = &H8
Const MFS_DEFAULT As Long = &H1000
Const MFS_DISABLED As Long = &H2
Const MFS_ENABLED As Long = &H0
Const MFS_GRAYED As Long = &H1
Const MFS_HILITE As Long = &H80
Const MFS_UNCHECKED As Long = &H0
Const MFS_UNHILITE As Long = &H0

Const RGB_STARTNEWCOLUMNWITHVERTBAR As Long = &H20
Const RGB_STARTNEWCOLUMN As Long = &H40
Const RGB_EMPTY As Long = &H100
Const RGB_VERTICALBARBREAK As Long = &H160
Const RGB_SEPARATOR As Long = &H800

Private Declare Function DeleteMenu Lib "user32" _
(ByVal hMenu As Long, _
ByVal nPosition As Long, _
ByVal wFlags As Integer) As Long

Private Declare Function GetSystemMenu Lib "user32" _
(ByVal hwnd As Long, _
ByVal bRevert As Long) As Long

Private Declare Function GetMenu Lib "user32" _
(ByVal hwnd As Long) As Long

Private Declare Function GetMenuItemCount Lib "user32" _
(ByVal hMenu As Long) As Long

Private Declare Function GetSubMenu 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 un As Long, _
ByVal b As Boolean, _
lpmii As MENUITEMINFO) As Long

Private Declare Function SetMenuItemInfo Lib "user32" _
Alias "SetMenuItemInfoA" _
(ByVal hMenu As Long, _
ByVal uItem As Long, _
ByVal fByPosition As Long, _
lpmii As MENUITEMINFO) As Long

Public Sub DeleteMenuItems(WindowHandle As Long, TargetList() As Variant)

Dim l_lMainMenuHandle As Long
Dim l_lSubMenuHandle As Long
Dim l_lMenuItemCount As Long
Dim l_lSubMenuItemCount As Long
Dim l_lMenuItemIndex As Long
Dim l_lSubMenuItemIndex As Long
Dim l_uMenuInfo As MENUITEMINFO
Dim l_lReturnValue As Long
Dim l_cMenuItemString As String
Dim l_lTargetItem As Long

l_lMainMenuHandle = GetMenu(ByVal WindowHandle)
l_lMenuItemCount = GetMenuItemCount(l_lMainMenuHandle)

For l_lMenuItemIndex = 0 To l_lMenuItemCount - 1

l_uMenuInfo.fMask = MIIM_TYPE And MIIM_ID
l_uMenuInfo.fType = MFT_STRING
l_uMenuInfo.dwTypeData = vbNullString
l_uMenuInfo.cch = 0
l_uMenuInfo.cbSize = Len(l_uMenuInfo)
l_lReturnValue = GetMenuItemInfo(l_lMainMenuHandle, l_lMenuItemIndex, True, l_uMenuInfo)
l_lSubMenuHandle = GetSubMenu(l_lMainMenuHandle, l_lMenuItemIndex)

If Not IsNull(l_lSubMenuHandle) Then ' This item triggers a submenu or popup menu
ProcessSubMenu l_lSubMenuHandle, TargetList()
End If

If l_uMenuInfo.cch > 0 Then ' This is a text menu item (eg not a separator or bitmap)

l_uMenuInfo.cch = l_uMenuInfo.cch + 1
l_uMenuInfo.dwTypeData = Space$(l_uMenuInfo.cch + 1)
l_uMenuInfo.cbSize = Len(l_uMenuInfo)
l_lReturnValue = GetMenuItemInfo(l_lMainMenuHandle, l_lMenuItemIndex, True, l_uMenuInfo)

' Make menu string uppercase and strip out & characters
l_cMenuItemString = ""
For l_lTargetItem = 1 To Len(l_uMenuInfo.dwTypeData)
If Not Mid(l_uMenuInfo.dwTypeData, l_lTargetItem, 1) = "&" Then
l_cMenuItemString = l_cMenuItemString _
& UCase(Mid(l_uMenuInfo.dwTypeData, l_lTargetItem, 1))
End If
Next

For l_lTargetItem = LBound(TargetList) To UBound(TargetList)
If Left(l_cMenuItemString, Len(TargetList(l_lTargetItem))) = UCase(TargetList(l_lTargetItem)) Then
l_lReturnValue = DeleteMenu(WindowHandle, l_uMenuInfo.wID, MF_BYCOMMAND)
Exit For
End If
Next

End If

Next

Exit Sub

End Sub
Friend Sub ProcessSubMenu(SubMenuHandle, TargetList() As Variant)

Dim l_lMenuItemCount As Long
Dim l_lMenuItemIndex As Long
Dim l_uMenuInfo As MENUITEMINFO
Dim l_lSubMenuHandle As Long
Dim l_lReturnValue As Long
Dim l_oFormHandler As FormHandler
Dim l_lTargetCount As Long
Dim l_lTargetItem As Long
Dim l_cMenuItemString As String

l_lTargetCount = UBound(TargetList) - LBound(TargetList)

l_lMenuItemCount = GetMenuItemCount(SubMenuHandle)

For l_lMenuItemIndex = 0 To l_lMenuItemCount - 1

l_uMenuInfo.fMask = MIIM_TYPE Or MIIM_ID
l_uMenuInfo.fType = MFT_STRING
l_uMenuInfo.dwTypeData = vbNullString
l_uMenuInfo.cch = 0
l_uMenuInfo.cbSize = Len(l_uMenuInfo)
l_lReturnValue = GetMenuItemInfo(SubMenuHandle, l_lMenuItemIndex, True, l_uMenuInfo)
l_lSubMenuHandle = GetSubMenu(SubMenuHandle, l_lMenuItemIndex)

If Not IsNull(l_lSubMenuHandle) Then ' This item triggers a submenu or popup menu
Set l_oFormHandler = New FormHandler ' Make recursive call to process the submenu or popup menu
l_oFormHandler.ProcessSubMenu l_lSubMenuHandle, TargetList()
Set l_oFormHandler = Nothing
End If

If l_uMenuInfo.cch > 0 Then ' This is a text menu item (eg not a separator or bitmap)
l_uMenuInfo.cch = l_uMenuInfo.cch + 1
l_uMenuInfo.dwTypeData = Space$(l_uMenuInfo.cch + 1)
l_uMenuInfo.cbSize = Len(l_uMenuInfo)
l_lReturnValue = GetMenuItemInfo(SubMenuHandle, l_lMenuItemIndex, True, l_uMenuInfo)

' Make menu string uppercase and strip out & characters
l_cMenuItemString = ""
For l_lTargetItem = 1 To Len(l_uMenuInfo.dwTypeData)
If Not Mid(l_uMenuInfo.dwTypeData, l_lTargetItem, 1) = "&" Then
l_cMenuItemString = l_cMenuItemString _
& UCase(Mid(l_uMenuInfo.dwTypeData, l_lTargetItem, 1))
End If
Next

For l_lTargetItem = LBound(TargetList) To UBound(TargetList)
If Left(l_cMenuItemString, Len(TargetList(l_lTargetItem))) = UCase(TargetList(l_lTargetItem)) Then
l_lReturnValue = DeleteMenu(SubMenuHandle, l_uMenuInfo.wID, MF_BYCOMMAND)
Exit For
End If
Next

End If

Next

End Sub