Well, I just realized I posted my FoundRange function as part of an earlier post (maybe my Burst function). That isn't exactly fair to you now is it. So here is what I put in my ThisWorkbook object for any add-in I write (non-office2007) to create menus/submenus. The comments in the code should be enough for you, but if you have any questions about it please post a comment!
Option Explicit
'I use this as a basis for the code in ThisWorkbook of most add-ins that I make
' -MenuCaption is the menu in the worksheet menu bar to add to. Feel free to create
' your own menu, or use an existing menu (using the & symbol for the alt-key shortcut)
' For example, to add your new option(s) to the 'Tools' menu, use &Tools
' -MenuOption1 and MenuOption1MacroName are used for the individual menu options
' For additional options, follow the same guideline as MenuOption1, and make sure to
' reference your new Const'ants in the Workbook_Open and RemoveMenuOption subroutines
Private Const MenuCaption As String = "&New Menu"
Private Const MenuOption1 As String = "&Menu Option"
Private Const MenuOption1MacroName As String = "MacroName"
Private Sub Workbook_Open()
Dim CmdBar As Object, NewMenu As Object, NewSubMenu As Object
RemoveMenuOption
On Error Resume Next
Set CmdBar = Application.CommandBars("Worksheet Menu Bar")
Set NewMenu = AddMenu(CmdBar, MenuCaption)
''Use syntax like this for a sub-menu
' Set NewSubMenu = AddMenu(NewMenu, MenuName1)
' AddControl NewSubMenu, MenuOption1_1, MenuOption1_1MacroName
' AddControl NewSubMenu, MenuOption1_2, MenuOption1_2MacroName
'Otherwise use this syntax
AddControl NewMenu, MenuOption1, MenuOption1MacroName
End Sub
Private Function AddMenu(ByRef ParentMenu As Object, ByVal NewMenuName As String) As Object
Dim vNewMenu As Object
On Error Resume Next
Set vNewMenu = ParentMenu.Control(Replace(NewMenuName, "&", ""))
If vNewMenu Is Nothing Then
Set vNewMenu = ParentMenu.Controls.Add(Type:=10, Before:=ParentMenu.Controls.Count + 1 _
, Temporary:=True) '10=msoControlPopup
vNewMenu.Caption = NewMenuName
End If
Set AddMenu = vNewMenu
End Function
Private Function AddControl(ByRef NewMenu As Object, ByVal vOption As String, _
ByVal vOptionMacro As String, Optional ByVal vBeginGroup As Boolean = False) As Boolean
With NewMenu.Controls.Add
.Caption = vOption
.BeginGroup = vBeginGroup
.OnAction = "'" & ThisWorkbook.Name & "'!" & vOptionMacro
.Tag = Replace(vOption, "&", "")
End With
End Function
Private Sub Workbook_AddinUninstall()
RemoveMenuOption
If Not ThisWorkbook.Saved Then ThisWorkbook.Save
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not ThisWorkbook.Saved Then ThisWorkbook.Save
End Sub
Private Sub RemoveMenuOption()
Dim cBc2 As Object, cBc As Object
On Error Resume Next
For Each cBc In Application.CommandBars("Worksheet Menu Bar").Controls
If Replace(cBc.Caption, "&", "") = Replace(MenuCaption, "&", "") Then
For Each cBc2 In cBc.Controls
Select Case LCase(Replace(cBc2.Caption, "&", ""))
Case LCase(Replace(MenuOption1, "&", "")): cBc2.Delete
'add more additional Case statements here as you add more MenuOptions
End Select
Next
If cBc.Controls.Count = 0 Then cBc.Delete
Exit For
End If
Next cBc
End Sub
