Custom menus in Excel 5/95
2000-02-05 Commandbars 0 227
With macros it's possible to create your own custom menu. In Excel-versions previous to Excel97 it is 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