自作アドイン用メニューの作成

以下をThisWorkBook内に記載する。

・参考
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_080.html ツールバーの動的追加
http://officetanaka.net/excel/vba/tips/tips83.htm FaceIDの一覧

Option Explicit

' ツールバーの生成と、メニューへの項目追加

Private Const C_ToolBarName As String = "XlsDevMenu"
Private Const C_TopMenuName As String = "開発サポート(&1)"
Private Const C_TopMenuBar As String = "Worksheet Menu Bar"

Private mlMenuCmdBarCtl As CommandBarControl ' メニュー

'ツールバーが存在する場合True
Private Function hasToolBar(sName As String) As Boolean
    Dim oObj As Object
    For Each oObj In Application.CommandBars
        If oObj.Name = C_ToolBarName Then
            hasToolBar = True
            Exit Function
        End If
    Next
    hasToolBar = False
    Exit Function
End Function

' アイコンの追加
Private Sub createMenu( _
    sCaption As String, _
    sMacroName As String, _
    nFaceId As Long, _
    Optional ByVal sShortCutKey As String = "" _
)
    ' ツールバーへの登録
    With Application.CommandBars(C_ToolBarName).Controls.Add(msoControlButton)
        If Len(sShortCutKey) > 0 Then
            .Caption = "&" & sShortCutKey ' ショートカットキー
        End If
        .OnAction = ThisWorkbook.Name & "!" & sMacroName
        .Style = msoButtonIconAndCaption ' イメージとテキストを表示
        .FaceId = nFaceId
    End With

    ' メニューへの登録
    With mlMenuCmdBarCtl.Controls.Add(msoControlButton)
        .Caption = sCaption
        .OnAction = ThisWorkbook.Name & "!" & sMacroName
        .FaceId = nFaceId
    End With
End Sub

' メニュー追加
Private Sub Workbook_Open()
    On Error GoTo ErrHand
    Dim oObj As Object
    
    ' ツールバーの作成
    If Not hasToolBar(C_ToolBarName) Then
        Application.CommandBars.Add(C_ToolBarName).Visible = True
    End If
    ' ツールバーに登録済のメニューを全削除
    With Application.CommandBars(C_ToolBarName)
        For Each oObj In .Controls
            oObj.Delete
        Next
    End With
        
    ' 同名のメニューが既に存在するなら削除
    For Each oObj In Application.CommandBars(C_TopMenuBar).Controls
        If oObj.Caption = C_TopMenuName Then
            Set mlMenuCmdBarCtl = oObj
            Exit For
        End If
    Next
    ' メニュー配下のアイテムを消去
    If mlMenuCmdBarCtl Is Nothing Then
        Set mlMenuCmdBarCtl = Application.CommandBars(C_TopMenuBar).Controls.Add(msoControlPopup)
    End If
    With mlMenuCmdBarCtl
        .Caption = C_TopMenuName
        For Each oObj In .Controls
            oObj.Delete
        Next
    End With

    ' 機能追加 (メニュー表示用名称, マクロ名, アイコンID, ショートカットキー)
    Call createMenu("Accessからの貼付け(&q)", "MacroPaste", 279, "q")
    Call createMenu("ドラッグ＆ドロップ編集切替(&x)", "setCellDragAndDrop", 705, "x")
    Call createMenu("ヘッダ・フッタの一括設定(&.)", "setHeadFoot", 278, ".")
    
    Exit Sub
ErrHand:
    MsgBox Err.Description
End Sub

' 動作確認用
Public Sub openTest()
    Call Workbook_Open
End Sub