为excel添加自定义菜单及其命令

下面的代码大概是3年前写的，好像是借鉴excelhome上一位大大的代码。

把它放到你需要的xla的thisworkbook中，他在你的工具菜单中添加一项 "自定义命令"，并在你点选此菜单时运行程序subname：

Const APPNAME As String = "自定义命令"

Private Sub Workbook_AddinInstall()
'调用CreateMenu添加菜单
   CreateMenu
   MsgBox "已经生成菜单至:工具--自定义命令"
End Sub

Private Sub Workbook_AddinUninstall()
'调用DeleteMenu移除菜单
    DeleteMenu
    MsgBox "已经移除菜单:工具--自定义命令"
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 '我不敢确定30007这个ID总是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"  '新菜单触发的过程名
        .FaceId = 0
        .BeginGroup = True
    End With
   
    Exit Sub

    If Err <> 0 Then
        MsgBox "菜单创建错误,请重新尝试", vbInformation, "提示"
    End If
End Sub