通过VBA在Excel中添加菜单和菜单项按钮（Excel启动时候添加）

将以下代码保存到.xlam或.xla(Excel97-2003)文件。

在ThisWorkBook对象中，添加Workbook_Open事件，调用启动菜单过程。
Private Sub Workbook_Open()
    Call MenuSetup(True)
End Sub

'-----------------------------------------------
'在Excel中添加菜单和菜单项按钮（Excel启动时候添加）
'-----------------------------------------------
Public Function MenuSetup(blSetUp As Boolean)
    Dim myMenu As CommandBarPopup
    Dim mycontrol As CommandBarControl
    Dim i As Integer
    Dim sMenuItemName As String     '菜单项的名称
    Dim sMenuItemFunc As String     '菜单项的调用的函数名称
    Dim strM As String              '菜单名称
    Dim strMenuItem() As String     '菜单项名称

    On Error Resume Next

    '初始化菜单项
    ReDim strMenuItem(3, 2)    'VBA数组下界从1开始
    '菜单项1
    strMenuItem(1, 1) = "菜单项1"
    strMenuItem(1, 2) = "菜单1运行的过程名"
    '菜单项2
    strMenuItem(2, 1) = "菜单项2"
    strMenuItem(2, 2) = "菜单2运行的过程名"

    Application.ScreenUpdating = False

    '---添加菜单1
    strM = "EBS配套工具"
    Set myMenu = Application.CommandBars(1).Controls(strM)       '判断我的菜单是

否存在？
    If Err Then
        Err.Clear
        Set myMenu = Application.CommandBars(1).Controls.Add

(Type:=msoControlPopup, temporary:=True)
        myMenu.Caption = strM
    End If

    If blSetUp Then
            '---添加菜单项目1
            For i = 1 To UBound(strMenuItem)      '数组第一维的大小
                sMenuItemName = strMenuItem(i, 1)
                sMenuItemFunc = strMenuItem(i, 2)

                Set mycontrol = myMenu.Controls(sMenuItemName)   '判断子程序是否

存在
                If Err Then
                    Err.Clear
                    Set mycontrol = myMenu.Controls.Add(Type:=msoControlButton, 

temporary:=True) '在菜栏最后位置增加一个按钮
                    With mycontrol
                        .Caption = sMenuItemName                    '菜单项显示名

称
                        .OnAction = sMenuItemFunc                   '左键单击该菜

单项按钮便运行的过程
                        .Style = msoButtonCaption                   '只显示文字
                    End With
                End If
            Next
    Else
        Application.CommandBars(1).Controls(strT).Delete

    End If

    Application.ScreenUpdating = True
    If Err Then Err.Clear
End Function

Public Sub start_App()
 frmSetFileSheet.Show 0
End Sub