Menu Maker

See also

• Menu Bar Maker
• Examples

Introduction & Benefits

Menus can be the main navigational aid to an Excel application. I designed this piece of code to create a menu system from a layout described in a spreadsheet. For the developer this gives you a way to keep menus up-to-date without the need to constantly revise the code behind them. Even moving an item from one place to another becomes a simple exercise in spreadsheet manipulation rather than code contortions.

Sample Menu

Sample Layout

Each sub menu has a dark background.
Each menu item consists of up to four cells.
The grey cells are blank.

1. (Required) The item name.
2. (Required) The linked macro.
3. (Optional) Indicates whether the item begins a group.
4. (Optional) An icon number identifying a face-id.

How many levels?

Some words of warning:

1. Every menu item should have a macro name attached to it. I use the "BygMsg" macro as a place holder.
2. When you get over towards column IV, remember that each menu item can have up to four pieces of information, so you have to allow for that.

The Code

Option Explicit

Public Const gConByg_Wmb = "Worksheet Menu Bar"
Public Const gConByg_Menu = "BygMenu"
Public Const gConByg_BygSoftware = "www.BygSoftware.com: MenuMaker"

Dim mArrByg()
Dim mLngByg_Index As Long

'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'' Purpose  : Test sub for BygMakeAMenuFromARange
'' Written  : 21-Aug-2006 by Andy Wiggins, BygSoftware.com
''
Sub TEST_BygMakeAMenuFromARange()
    BygMakeAMenuFromARange gConByg_Menu
End Sub

'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'' Purpose  : Create a menu from a range
'' Written  : 18-Aug-2006 by Andy Wiggins, BygSoftware.com
''
Sub BygMakeAMenuFromARange(pStr_MenuName As String)
''
Dim lLng_Rows As Long
Dim lLng_Cols As Long
Dim lLng_Counter As Long
Dim lLng_Counter2 As Long
Dim lRng_CR As Range
Dim lLng_Items As Long
Dim lRng_Cell As Range

    ThisWorkbook.Activate

    '' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    Set lRng_CR = Worksheets(pStr_MenuName).Cells(1, 1).CurrentRegion
    
    '' Collect range dimension details
    With lRng_CR
        lLng_Rows = .Rows.Count
        lLng_Cols = .Columns.Count
    End With

    '' Create an array of the right size
    ReDim Preserve mArrByg(lLng_Cols)
    
    '' Test
    If lLng_Rows <= 1 Then
        MsgBox "Not enough rows", vbOKOnly + vbCritical, gConByg_BygSoftware
        End
    End If

    '' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    '' Begin menu making

    '' Set the index variable
    mLngByg_Index = 0

    '' If this item exists on the worksheet menubar, then remove it
    '' This ensures that any existing version on the menu bar is deleted
    DeleteCommandBarControl pStr_MenuName
    
    '' Create the menu
    Set mArrByg(mLngByg_Index) = CommandBars(gConByg_Wmb)
    mArrByg(mLngByg_Index).Controls.Add(Type:=msoControlPopup).Caption = pStr_MenuName
    
    '' Increment the index variable after creating the main menu
    mLngByg_Index = 1
    
    BygAddSubMenu pStr_MenuName
                
    '' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    '' Now add things
    For lLng_Counter = 1 To lLng_Rows
        lLng_Items = Application.WorksheetFunction.CountA(lRng_CR.Rows(lLng_Counter))
        
        Select Case lLng_Items
            Case 1
                '' Menu
                For lLng_Counter2 = 1 To lLng_Cols
                
                    If Len(lRng_CR.Cells(lLng_Counter, lLng_Counter2).Value) > 0 Then
                        mLngByg_Index = lLng_Counter2 + 1
                        BygAddSubMenu lRng_CR.Cells(lLng_Counter, lLng_Counter2).Value
                        Exit For
                    End If
                Next

            Case Else
                '' Menu Item
                lLng_Counter2 = 1

                For lLng_Counter2 = 1 To lLng_Cols
                    If Len(lRng_CR.Cells(lLng_Counter, lLng_Counter2).Value) > 0 Then
                        mLngByg_Index = lLng_Counter2 + 1
                        With lRng_CR
                            AddMenuItem mArrByg(mLngByg_Index - 1), _
                                    CStr(.Cells(lLng_Counter, lLng_Counter2).Value), _
                                    .Cells(lLng_Counter, lLng_Counter2 + 1).Value, _
                                    .Cells(lLng_Counter, lLng_Counter2 + 2).Value, _
                                    .Cells(lLng_Counter, lLng_Counter2 + 3).Value
                        End With
                        Exit For
                    End If
                Next

        End Select

    Next

End Sub

'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'' Purpose  : Adds a menu item to the menu being built
'' Written  : 18-Aug-2006 by Andy Wiggins, BygSoftware.com
''
Sub AddMenuItem(pObj_Menu, pStr_Caption As String, _
                pStr_MacroName As String, _
                Optional pBoo_BG As Boolean, _
                Optional pLng_FaceId As Long)

    With pObj_Menu
        .Controls.Add(Type:=msoControlButton).Caption = pStr_Caption
        With .Controls(pStr_Caption)
            .OnAction = pStr_MacroName
            .BeginGroup = pBoo_BG
            .FaceId = pLng_FaceId
        End With
    End With

End Sub

'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'' Purpose  : Add a sub menu
'' Written  : 18-Aug-2006 by Andy Wiggins, BygSoftware.com
''
Function BygAddSubMenu(pArg)
    If mLngByg_Index > 1 Then mArrByg(mLngByg_Index - 1).Controls.Add(Type:=msoControlPopup).Caption = pArg
    Set mArrByg(mLngByg_Index) = mArrByg(mLngByg_Index - 1).Controls(pArg)
End Function

'' ***************************************************************************
'' Purpose  : Delete a named command bar control
''          : Cycle through all existing names - if our one exists, delete it
'' Written  : 28-Mar-2001 by Andy Wiggins, Byg Software Limited
''
Sub DeleteCommandBarControl(menuItem)
Dim mb
    For Each mb In CommandBars(gConByg_Wmb).Controls
        If mb.Caption = menuItem Then
            mb.Delete
        End If
    Next
End Sub

'' ***************************************************************************
'' Purpose  : Dummy message - demo only
'' Written  : 13-Apr-2003 by Andy Wiggins, Byg Software Limited
''
Sub DummyMessage()
    MsgBox "Menu item selected", vbInformation, gConByg_BygSoftware
End Sub