I have been using the following code for many years to create custom menus
Sub CreateMenu()
Dim MenuSheet As Worksheet
Dim MenuObject As CommandBarPopup
Dim MenuItem As Object
Dim SubMenuItem As CommandBarButton
Dim row As Integer
Dim MenuLevel, NextLevel, PositionOrMacro, Caption, Divider, FaceId
Set MenuSheet = ThisWorkbook.Sheets("menu")
Call DeleteMenu
row = 2
Stop
Do Until IsEmpty(MenuSheet.Cells(row, 1))
With MenuSheet
MenuLevel = .Cells(row, 1)
Caption = .Cells(row, 2)
PositionOrMacro = .Cells(row, 3)
Divider = .Cells(row, 4)
FaceId = .Cells(row, 5)
NextLevel = .Cells(row + 1, 1)
End With
Select Case MenuLevel
Case 1 ' A Menu
Set MenuObject = Application.CommandBars(1). _
Controls.Add(Type:=msoControlPopup, _
before:=PositionOrMacro, _
Temporary:=True)
MenuObject.Caption = Caption
Case 2 ' A Menu Item
If NextLevel = 3 Then
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)
Else
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
MenuItem.OnAction = PositionOrMacro
End If
MenuItem.Caption = Caption
If FaceId <> "" Then MenuItem.FaceId = FaceId
If Divider Then MenuItem.BeginGroup = True
Case 3 ' A SubMenu Item
Set SubMenuItem = MenuItem.Controls.Add(Type:=msoControlButton)
SubMenuItem.Caption = Caption
SubMenuItem.OnAction = PositionOrMacro
If FaceId <> "" Then SubMenuItem.FaceId = FaceId
If Divider Then SubMenuItem.BeginGroup = True
End Select
row = row + 1
Loop
End Sub
after "upgrading" to excel 2013 from 2007 (I skipped 2010) all my files that use that code fail on the line
Set MenuObject = Application.CommandBars(1). _
Controls.Add(Type:=msoControlPopup, _
before:=PositionOrMacro, _
Temporary:=True)
MenuObject.Caption = Caption
with the error message "subscript out of range".
What happened? It seems like it should still work.
Thanks
Ken
Sub CreateMenu()
Dim MenuSheet As Worksheet
Dim MenuObject As CommandBarPopup
Dim MenuItem As Object
Dim SubMenuItem As CommandBarButton
Dim row As Integer
Dim MenuLevel, NextLevel, PositionOrMacro, Caption, Divider, FaceId
Set MenuSheet = ThisWorkbook.Sheets("menu")
Call DeleteMenu
row = 2
Stop
Do Until IsEmpty(MenuSheet.Cells(row, 1))
With MenuSheet
MenuLevel = .Cells(row, 1)
Caption = .Cells(row, 2)
PositionOrMacro = .Cells(row, 3)
Divider = .Cells(row, 4)
FaceId = .Cells(row, 5)
NextLevel = .Cells(row + 1, 1)
End With
Select Case MenuLevel
Case 1 ' A Menu
Set MenuObject = Application.CommandBars(1). _
Controls.Add(Type:=msoControlPopup, _
before:=PositionOrMacro, _
Temporary:=True)
MenuObject.Caption = Caption
Case 2 ' A Menu Item
If NextLevel = 3 Then
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)
Else
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
MenuItem.OnAction = PositionOrMacro
End If
MenuItem.Caption = Caption
If FaceId <> "" Then MenuItem.FaceId = FaceId
If Divider Then MenuItem.BeginGroup = True
Case 3 ' A SubMenu Item
Set SubMenuItem = MenuItem.Controls.Add(Type:=msoControlButton)
SubMenuItem.Caption = Caption
SubMenuItem.OnAction = PositionOrMacro
If FaceId <> "" Then SubMenuItem.FaceId = FaceId
If Divider Then SubMenuItem.BeginGroup = True
End Select
row = row + 1
Loop
End Sub
after "upgrading" to excel 2013 from 2007 (I skipped 2010) all my files that use that code fail on the line
Set MenuObject = Application.CommandBars(1). _
Controls.Add(Type:=msoControlPopup, _
before:=PositionOrMacro, _
Temporary:=True)
MenuObject.Caption = Caption
with the error message "subscript out of range".
What happened? It seems like it should still work.
Thanks
Ken