Creating a SubMenu

[Rockee052]

Hi Ya'll

I have created a custom menu and I am having trouble creating a submen
for one of the menu items... I have spent some time searching o
google, I am getting close just not close enough.
I get a run-time error '438' in the submenu part of the code.

Thanks for any help

Sub PartsMenu()
Dim HelpMenu As CommandBarControl
Dim MainMenu As CommandBarPopup
Dim MenuItem As CommandBarControl
Dim Submenuitem As CommandBarButton

' Deletes menu if it exits
Call DeleteMenu

' Find the help menu
Set HelpMenu = CommandBars(1).FindControl(ID:=30010)


If HelpMenu Is Nothing Then
' Add the menu to the end
Set MainMenu = CommandBars(1).Controls _
.Add(Type:=msoControlPopup, temporary:=True)
Else
' Add menu before help
Set MainMenu = CommandBars(1).Controls _
.Add(Type:=msoControlPopup, before:=HelpMenu.Index, _
temporary:=True)
End If

' Add caption
MainMenu.Caption = "&Parts Utility"

' Searching for parts
Set MenuItem = MainMenu.Controls.Add _
(Type:=msoControlButton)
With MenuItem
.Caption = "&Search Parts..."
.FaceId = 48
.ShortcutText = "Ctrl+Shift+S"
.OnAction = "SetupSearch"
End With

' LO / Remaining printout
Set MenuItem = MainMenu.Controls.Add _
(Type:=msoControlButton)
With MenuItem
.Caption = "&Generate Parts Review..."
.FaceId = 285
.ShortcutText = "Ctrl+Shift+D"
.OnAction = "LORemaining"
End With

' View summary sheet
Set MenuItem = MainMenu.Controls.Add _
(Type:=msoControlButton)
With MenuItem
.Caption = "&View Summary..."
.FaceId = 592
.OnAction = "Summary"
End With

' Error is here
' Print summary sheet
Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With MenuItem
.Caption = "Print Summary"
.FaceId = 364
.OnAction = "PrintSummary"
End With
End Sub

Rockee
Excel 200

 

[Bob Phillips]

Rockee,

When creating a sub-menu, you first have to create a control of type
msoControlPopup. Here is some amended code to show you how

Sub PartsMenu()
Dim HelpMenu As CommandBarControl
Dim MainMenu As CommandBarPopup
Dim MenuItem As CommandBarControl
Dim Submenuitem As CommandBarButton

' Deletes menu if it exits
Call DeleteMenu

' Find the help menu
Set HelpMenu = CommandBars(1).FindControl(ID:=30010)


If HelpMenu Is Nothing Then
' Add the menu to the end
Set MainMenu = CommandBars(1).Controls. _
Add(Type:=msoControlPopup, temporary:=True)
Else
' Add menu before help
Set MainMenu = CommandBars(1).Controls. _
Add(Type:=msoControlPopup, before:=HelpMenu.Index, _
temporary:=True)
End If

' Add caption
MainMenu.Caption = "&Parts Utility"

' Searching for parts
Set MenuItem = MainMenu.Controls.Add _
(Type:=msoControlButton)
With MenuItem
.Caption = "&Search Parts..."
.FaceId = 48
.ShortcutText = "Ctrl+Shift+S"
.OnAction = "SetupSearch"
End With

' LO / Remaining printout
Set MenuItem = MainMenu.Controls.Add _
(Type:=msoControlButton)
With MenuItem
.Caption = "&Generate Parts Review..."
.FaceId = 285
.ShortcutText = "Ctrl+Shift+D"
.OnAction = "LORemaining"
End With

' View summary sheet
Set MenuItem = MainMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
.Caption = "Sub menu"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
.Caption = "&View Summary..."
.FaceId = 592
.OnAction = "Summary"
End With

' Error is here
' Print summary sheet
Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
.Caption = "Print Summary"
' .Application = 364
.OnAction = "PrintSummary"
End With
End Sub


--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Rockee052]

Bob,

Thanks for your help

Rocke

 

[Rob van Gelder]

Check my website for an example of CommandBars

 

[Hammer_757]

In the code below, the line: "Call DeleteMenu"
returns "Compile Error: Sub or Function not defined"

is this because in the the sample code, is calling a missing piece o
code?

 

[Bob Phillips]

Hi Rockee,

Yes that is why.

Here is a procedure that should suffice.

Sub DeleteMenu()

On Error Resume Next
Application.CommandBars("Parts Utility").Delete
On Error GoTo 0

End Sub

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Hammer_757]

Thanks Bob