Menu creater - Jacob Skaria

[Hennie Neuhoff]

I copied the code from the article you suggested, however Case 4
gives an error - Method or data member not found (Error 461) in the line
SubMenuItem.Controls.Add(Type:=msoControlButton)

Any suggestions ?


This is the code for Case 4:
Case 4 ' A SubSubMenu Item
Set SubSubMenuItem =
SubMenuItem.Controls.Add(Type:=msoControlButton)
SubSubMenuItem.Caption = Caption
SubSubMenuItem.OnAction = PositionOrMacro
If FaceId <> "" Then SubSubMenuItem.FaceId = FaceId
If Divider Then SubSubMenuItem.BeginGroup = True
End Select
Row = Row + 1
Loop

 

[Jacob Skaria]

Will definitely look into. Please let us know which version of Excel you are
using.

If this post helps click Yes

 

[Hennie Neuhoff]

I use excel 2003
Tkank you much appreciated!

 

[Jacob Skaria]

I got a chance to look into this only this morning...OK Shall we try this 5
level...You can add more as your requirement....

The below procedure looks into a table which will have details of the menus
to be build. Currently it is targetted to the ActiveSheet. Please make
necessary changes to that. The table format is as below with Row1 containing
headers Unique menu ID, Menu Caption, Control Type (1 for button and 10 for
popup) and Parent menu id. If parent menu id is 0 that menu will be created
in level 1. The below table range is from A116. Please try and feedback....

UID Caption Ctrl type Parent UID
1 Level1A 1 0
2 Level1B 10 0
3 Level1C 1 0
4 Level2A 1 2
5 Level2B 10 2
6 Level2C 1 2
7 Level3a 1 5
8 Level3b 10 5
9 Level3c 1 5
10 Level4a 1 8
11 Level4b 10 8
12 Level4c 1 8
13 Level5a 1 11
14 Level5b 1 11
15 Level5c 1 11



Sub AddMenus()

Dim lngRow As Long
Dim iHelpMenu As Integer
Dim varMenuType As Variant
Dim intMenuParent As Integer
Dim strMacroName As String
Dim strMainMenu As String
Dim strMenuCaption As String
Dim cbMainMenuBar As CommandBar
Dim cbcCustomMenu As CommandBarControl
Dim arrCustomMenu() As CommandBarControl

lngRow = 2
strMainMenu = "MyMenu"

On Error Resume Next
Application.CommandBars("Worksheet Menu Bar").Controls(strMainMenu).Delete
On Error GoTo 0
Set cbMainMenuBar = Application.CommandBars("Worksheet Menu Bar")
iHelpMenu = cbMainMenuBar.Controls("Help").Index
Set cbcCustomMenu = cbMainMenuBar.Controls.Add(Type:=msoControlPopup,
Before:=iHelpMenu)
cbcCustomMenu.Caption = strMainMenu


Do While ActiveSheet.Range("A" & lngRow) <> ""
ReDim Preserve arrCustomMenu(lngRow)
strMenuCaption = Range("B" & lngRow)
varMenuType = Range("C" & lngRow)
intMenuParent = Range("D" & lngRow)
strMacroName = Range("E" & lngRow)

If intMenuParent = 0 Then
Set arrCustomMenu(lngRow) = cbcCustomMenu.Controls.Add(Type:=varMenuType)
arrCustomMenu(lngRow).Caption = strMenuCaption
Else
Set arrCustomMenu(lngRow) =
arrCustomMenu(intMenuParent).Controls.Add(Type:=varMenuType)
arrCustomMenu(lngRow).Caption = strMenuCaption
arrCustomMenu(lngRow).OnAction = strMacroName
End If

lngRow = lngRow + 1
Loop

End Sub


If this post helps click Yes

 

[Jacob Skaria]

Oops...I have added the table headers just for your reference....The table
range should be in A115 with no headers.....

Also the starting row needs to be changed from 2 to 1 in code
lngRow = 1

Please try and feedback.....

If this post helps click Yes

 

[Jacob Skaria]

I have revised the code and added more comments. CreateMenu is a separate
procedure which can be called from code like below. Two arguments to be
passed are the menu name and the worksheet in which you have the
details...The main menu will be created just before the help menu. The macro
name is to be in the 5th column of the worksheet.


CreateMenu "MyNewMenu",Activeworkbook.Sheets("Sheet1")



Sub CreateMenu(strMainMenu As String, wsMenu As Worksheet)

'Procedure to create an Excel Menu and multiple levels of sub menus
'-------------------Arguments-----------------------------
'strMainMenu - The Main menu caption to be passed
'wsMenu - Worksheet in which menu details are stored(5 fields)
'Unique MenuID, Caption, Menu type,Parent Menu ID, Macro

Dim lngRow As Long 'Start Row
Dim intMenuID As Integer 'Unique menu ID
Dim intMenuPID As Integer 'Parent menu ID
Dim intHelpMenu As Integer 'Help menu index
Dim varMenuType As Variant 'Menu type (1,10)
Dim strMacroName As String 'Macro to be assigned
Dim strMenuCaption As String 'Menu captions
Dim cbMainMenuBar As CommandBar 'Command Bar
Dim arrCBC() As CommandBarControl 'Command Bar control Array

lngRow = 2
ReDim arrCBC(0)
'Remove if the menu already exists
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar").Controls(strMainMenu).Delete
On Error GoTo 0
'Identify menu location just before Help menu
Set cbMainMenuBar = Application.CommandBars("Worksheet Menu Bar")
intHelpMenu = cbMainMenuBar.Controls("Help").Index
'Create main menu
Set arrCBC(0) = cbMainMenuBar.Controls.Add(Type:=10, Before:=intHelpMenu)
arrCBC(0).Caption = strMainMenu

'Create sub menus
Do While wsMenu.Range("A" & lngRow) <> ""
intMenuID = wsMenu.Range("A" & lngRow)
ReDim Preserve arrCBC(intMenuID)
strMenuCaption = wsMenu.Range("B" & lngRow)
varMenuType = wsMenu.Range("C" & lngRow)
intMenuPID = wsMenu.Range("D" & lngRow)
strMacroName = wsMenu.Range("E" & lngRow)

Set arrCBC(intMenuID) = arrCBC(intMenuPID).Controls.Add(Type:=varMenuType)
arrCBC(intMenuID).Caption = strMenuCaption
If intMenuPID > 0 Then
arrCBC(intMenuID).OnAction = strMacroName
End If

lngRow = lngRow + 1
Loop

End Sub


If this post helps click Yes

 

[Hennie Neuhoff]

Jacob, Thank you very much, it works perfectly!. By the way - I posed the
question to the author (John Weilbach) who said its not worth the trouble!

 

[Jacob Skaria]

Dear Hennie

Thanks for the feedback. Your query was something very interesting to work
with..

If this post helps click Yes