Add custom menus and commands for Excel

The following code was written about three years ago. It seems that it was based on a large piece of code on excelhome.

Put it in the thisworkbook of the xla you need, add a "Custom Command" in your tool menu, and run the program subname when you click this menu:

Const appname as string = "Custom command"

Private sub workbook_addininstall ()
'Call createmenu to add the menu
Createmenu
Msgbox "menu generated to: tool-custom command"
End sub

Private sub workbook_addinuninstall ()
'Call deletemenu to remove the menu
Deletemenu
Msgbox "menu removed: tool-custom command"
End sub

Sub deletemenu ()
Dim xlcommandbar as string
Dim xlmenu as string
Dim xlmenuitem as string
Dim newmenuitem as string

Xlcommandbar = "worksheet menu bar"
Xlmenuitem = ""
Newmenuitem = appname &"..."

Xlmenu = application. commandbars (xlcommandbar). findcontrol (msocontrolpopup, 30007). Caption
On Error resume next
Application. commandbars (xlcommandbar). Controls (xlmenu). Controls (xlmenuitem). Controls (newmenuitem). Delete

Application. commandbars (xlcommandbar). Controls (xlmenu). Controls (newmenuitem). Delete


End sub
Sub createmenu ()

Dim newitem as commandbarbutton

Dim xlcommandbar as string
Dim xlmenu as string
Dim xlmenuitem as string
Dim newmenuitem as string

Xlcommandbar = "worksheet menu bar"
Xlmenu = application. commandbars (xlcommandbar). findcontrol (msocontrolpopup, 30007). Caption 'I am not sure that 30007 this ID is always OK
Xlmenuitem = ""
Newmenuitem = appname &"..."

On Error resume next
Application. commandbars (xlcommandbar). Controls (xlmenu). Controls (xlmenuitem). Controls (newmenuitem). Delete
Application. commandbars (xlcommandbar). Controls (xlmenu). Controls (newmenuitem). Delete

On Error goto 0
If xlmenuitem = "" then
Set newitem = application. commandbars (xlcommandbar). Controls (xlmenu). Controls. Add
Else
Set newitem = application. commandbars (xlcommandbar). Controls (xlmenu). Controls (xlmenuitem). Controls. Add
End if
With newitem
. Caption = newmenuitem
. Onaction = "subname" 'process name triggered by the new menu
. Faceid = 0
. Begingroup = true
End

Exit sub

If err <> 0 then
Msgbox "menu creation error. Please try again", vbinformation, "prompt"
End if
End sub