I can't ever see attached images, so I don't know if that's your problem or mine. Here's the full code, with a submenu added and one item under it.
Option Explicit
Dim MenuObject As CommandBarControl, SubMenuObject As CommandBarControl, MenuItem As Object
Private Sub Workbook_Activate()
Call CreateMenu
End Sub
Private Sub Workbook_Deactivate()
Call DeleteMenu
End Sub
Sub CreateMenu()
Call DeleteMenu ' Make sure the menu is not already there
Set MenuObject = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _
Before:=9, Temporary:=True)
MenuObject.Caption = "Menu 1"
Call AddMenuItem("M1 Item 1", "Item11Subroutine")
Call AddMenuItem("M1 Item 2", "Item12Subroutine")
Call AddMenuItem("M1 Item 3", "Item13Subroutine")
Set MenuObject = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _
Before:=9, Temporary:=True)
MenuObject.Caption = "Menu 2"
Call AddMenuItem("M2 Item 1", "Item21Subroutine")
Call AddMenuItem("M2 Item 2", "Item22Subroutine")
' Create sub menu under Menu 2
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)
MenuItem.Caption = "My Submenu"
' Add an item to the sub menu
Set SubMenuObject = MenuItem.Controls.Add(Type:=msoControlButton)
SubMenuObject.OnAction = "MySubmenuSubroutine1"
SubMenuObject.Caption = "Submenu Item1"
End Sub
Sub AddMenuItem(ItemName As String, MacroName As String)
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
MenuItem.OnAction = MacroName
MenuItem.Caption = ItemName
End Sub
Sub DeleteMenu()
On Error Resume Next
Application.CommandBars(1).Controls("Menu 1").Delete
Application.CommandBars(1).Controls("Menu 2").Delete
On Error GoTo 0
End Sub
Bookmarks