Custom menus in Excel5/95

With macros it's possible to create your own custom menu. In Excel-versions previous to Excel97 it's also possible to create menus with a built-in menu editor, but this option doesn't exist in Excel97. So why not learn a method that works in both versions? The example below shows how you can create and delete custom menus. The method works in Excel97 too, but if your workbook only is to be used in Excel97 or newer you ought to take a look at the Excel97 example instead.

Const MyMenuCaption As String = "&TestMenu"

Sub CreateCustomMenus()
' creates custom menus on different menubars
' may be automatically executed from an Auto_Open macro
    CreateOneMenu 3, MyMenuCaption 
    ' creates a new menu on the menubar for no open workbooks
    CreateOneMenu 7, MyMenuCaption 
    ' creates a new menu on the menubar for worksheets
End Sub

Sub DeleteAllCustomMenus()
' deletes the custom menu MyMenuCaption from the given menubars
' may be automatically executed from an Auto_Close macro
    DeleteOneMenu 3, MyMenuCaption ' the menubar for no open workbooks
    DeleteOneMenu 7, MyMenuCaption ' the menubar for worksheets
End Sub

Sub CreateOneMenu(myLine As Variant, myCaption As String)
' creates the custom menu myCaption on the menubar myLine
Dim mm As Menu, i As Integer
    DeleteOneMenu myLine, myCaption ' deletes the menu if it already exits
    Set mm = Application.MenuBars(myLine).Menus.Add(myCaption) 
    ' creates the menu myCaption on the menubar myLine
    With mm.MenuItems
        .Add "&Menuline 1", "Example1"
        .Add "Menu&line 2", "Example2"
        .Add "Menuline &3", "Example3"
        .Add "-" ' add a separator line in the menu
        .Add "Remove the custom menus", "DeleteAllCustomMenus"
    End With
    Set mm = Nothing
End Sub

Sub DeleteOneMenu(myLine As Variant, myCaption As String)
' deletes the menu myCaption from the menubar myLine
Dim ml As MenuBar, m As Menu, tempCaption As String
    myCaption = TextOnly(myCaption, 2) 
    ' returns the menuname in CAPS without any special characters
    Set ml = Application.MenuBars(myLine)
    For Each m In ml.Menus
        tempCaption = TextOnly(m.Caption, 2)
        If myCaption = tempCaption Then m.Delete
    Next m
    Set ml = Nothing
End Sub

Function TextOnly(tString As String, tAlt As Integer) As String
' deletes special characters from a string
' tAlt=0:no change
' tAlt=1:lowercase
' tAlt=2:UPPERCASE
' tAlt=3:Proper Case
Dim tmpString As String, i As Integer, t As Boolean
    TextOnly = ""
    For i = 1 To Len(tString)
        t = True
        If Mid(tString, i, 1) = "&" Then t = False
        If t Then TextOnly = TextOnly & Mid(tString, i, 1)
    Next i
    Select Case tAlt
        Case 1: TextOnly = LCase(TextOnly)
        Case 2: TextOnly = UCase(TextOnly)
        Case 3: TextOnly = Application.Proper(TextOnly)
    End Select
End Function

Document last updated 2000-02-05 12:47:00 Printerfriendly version

User comments:

Manio from Poland wrote (2003-11-27 13:11:27 CET):

Taki Sobie
Bardzo dobry program