menu_lib.bas

Attribute VB_Name = "menu_library"
Option Explicit

' This file is part of the Minnesota Population Center's VBA libraries project.
' For copyright and licensing information, see the NOTICE and LICENSE files
' in this project's top-level directory, and also on-line at:
'   https://github.com/mnpopcenter/vba-libs

' Add a custom menu to the worksheet menu bar.  The definition of the menu
' is a sequence of strings; for example:
'
'     # Menu definition
'     Foo | FooMacro
'     Bar | BarMacro
'     ---------
'     Compression ==>
'         Normal      | CompressData "Normal"
'         Fast        | CompressData "Fast"
'         Best        | CompressData "Best"
'
'     -------
'     Version  |  DisplayVersion
'
' Blank lines are ignored.  A comment line has "#" as the first non-whitespace
' character.  Comment lines are also ignored.  A submenu of the custom menu is
' is denoted with a "==>" at the end of line.
'
' A menu item (for the cusotm menu or one of its submenus) has the format:
'
'     menu item caption | action
'
' The action is the value assigned to the menu item's OnAction property.  It
' is the name of the macro to execute, along with any necessary arguments.
' Menu items for the custom menu are not indented.  The items for submenus
' must be indented at least 4 spaces.
'
' A separator in a menu (custom or submenu) is represented by a line with at
' least 4 "-" (hyphens).  Extra hyphens can be used for readability.  A
' submenu separator must be indented at least 4 spaces.
'
Sub AddCustomMenu(menuName As String, definition() As String, _
                  Optional insertBefore As String = "")
    Dim helpMenu As CommandBarControl
    Dim customMenu As CommandBarControl
    Dim mainMenuBar As CommandBar
  
    Set mainMenuBar = Application.CommandBars("Worksheet Menu Bar")
    If insertBefore = "" Then
        ' By default, look up Help menu by its control id since its name
        ' is language-dependent
        Set helpMenu = mainMenuBar.FindControl(ID:=30010)
    Else
        Set helpMenu = mainMenuBar.Controls(insertBefore)
    End If
    Set customMenu = mainMenuBar.Controls.Add(Type:=msoControlPopup, _
                                              Before:=helpMenu.Index)
    customMenu.Caption = menuName

    Dim line As String
    Dim i As Long
    Dim currentSubMenu As CommandBarControl
    Dim addSeparator As Boolean
    addSeparator = False
    
    For i = LBound(definition) To UBound(definition)
        line = definition(i)
        If IsBlank(line) Or IsComment(line) Then
            ' Ignore blank lines and comment lines
        ElseIf Right(line, 3) = "==>" Then
            ' Submenu ends with "==>"
            With customMenu.Controls
                Set currentSubMenu = .Add(Type:=msoControlPopup)
            End With
            With currentSubMenu
                .Caption = Trim(Replace(line, "==>", ""))
                .BeginGroup = addSeparator
            End With
            addSeparator = False
        ElseIf Left(LTrim(line), 4) = "----" Then
            ' Add separator above the next menu item in the definition
            addSeparator = True
        Else
            ' New menu item for either current submenu or the custom menu
            Dim isSubmenuItem As Boolean
            isSubmenuItem = StartsWith(line, "    ")
            Dim menu As CommandBarControl
            Set menu = IIf(isSubmenuItem, currentSubMenu, customMenu)
            Dim menuItem As CommandBarControl
            Set menuItem = menu.Controls.Add(Type:=msoControlButton)

            ' line format =  menu item caption | action
            Dim fields() As String
            fields = Split(Trim(line), "|")
            Dim itemCaption As String
            itemCaption = Trim(fields(0))
            Dim itemAction As String
            itemAction = Trim(fields(1))
            With menuItem
                .Caption = itemCaption
                .OnAction = "'" & itemAction & "'"
                .BeginGroup = addSeparator
            End With
            addSeparator = False
        End If
    Next
End Sub

Function StartsWith(str_ As String, prefix As String) As Boolean
    StartsWith = Left(str_, Len(prefix)) = prefix
End Function

Function IsBlank(line As String) As Boolean
   IsBlank = RTrim(line) = ""
End Function

Function IsComment(line As String) As Boolean
   IsComment = Left(LTrim(line), 1) = "#"
End Function

Public Sub RemoveCustomMenu(menuName As String)
    With Application.CommandBars("Worksheet Menu Bar")
       Dim ctrl As CommandBarControl
       For Each ctrl In .Controls
           If ctrl.Caption = menuName Then
               ctrl.Delete
           End If
       Next ctrl
    End With
End Sub