ツールバーを動的に追加する

ワークブックの立ち上げ時に専用のツールバーを追加し、そのツールバーには「登録」「更新」「削除」のボタンを追加します。ワークブックを閉じると専用ツールバーも削除されます。
「ツールバー」という用語はなくなったのですが....   Office2007以降では「ツールバー」に変わって「リボン」が採用されました。
ですがVBA上では「ツールバー(CommandBar)」は存続しており、 「ツールバー(CommandBar)」を操作する在来マクロは問題なく動作しています。 「ツールバー(CommandBar)」自体はリボンの「アドイン」タブ内のメンバとして表示されます。



では「今後」としてはどうなのかで「リボン」に移行するのかを考えた場合、「リボン」では動的操作に向かない問題が残ります。
ここでは従来の「ツールバー」を利用する上での説明となりますが、従来の「ツールバー」がリボンの「アドイン」タブに格納されるため、 この「アドイン」タブを選択状態にする対応を追加させています。
サンプルを見てみましょう。

ツールバーをブックの立ち上げ時に追加させます。
アドインタブのツールバーの表示
(画像をクリックすると、このサンプルがダウンロードできます)
この画像は追加されたツールバーの「登録」ボタンをクリックしてメッセージが表示されたところのものです。
このように従来型のツールバーは「アドイン」タブの中に表示され、従来同様に使用できます。
リボンのタブとして追加するような方法もXMLを書き込む方法で可能なようですが、 XMLには判断記述がないので動的操作に不向きであると思われ、 このサンプルの方法ではワークブックを閉じた時にツールバーを削除していますが、 この操作がリボンのタブで実装してしまうと難しいように見えます。 さらには「アドイン動作のサンプル」のような実装を考えるとリボンのタブでの実装は困難だと思われます。
(これは「食わず嫌い」な意見でもあります。リボンのタブの追加は試していません。)

ツールバーでの問題なのはそのブックを開いた時に即座に追加したツールバーが表示されないことだったので、 今回、他のサイトを参考にさせていただき改善しながら「アドイン」タブを初期選択させる動作を追加しました。

リボンのショートカットキーにも対応しています。
アドインタブのツールバーの表示
Alt+Xでアドインタブが選択され、アドインタブ内のショートカットキー設定がこのように表示されるので、そのキーを押すとマウスクリックと同じ動作になります。 タイトル「ツールバーテスト」も実際にはボタンなのでショートカットキーが割り当てられますが何も動作しません。

それではソースコードです。

'***************************************************************************************************
'   ツールバーテスト                                                Module1(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・UIAutomationClient
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 19/06/16(1.0.0)新規作成
' 19/12/03(1.0.1)「アドイン」タブ選択にTrimを追加(末尾に空白あり)
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle = "ツールバーテスト"

'***************************************************************************************************
'   ■■■ 起動・終了 ■■■
'***************************************************************************************************
'* 処理名 :Auto_Open
'* 機能  :立ち上げ時自動実行処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年06月16日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub Auto_Open()
    '-----------------------------------------------------------------------------------------------
    Dim xlAPP As Application                                        ' Excel.Application
    Dim objBar As CommandBar                                        ' CommandBar
    Dim objCont As CommandBarControl                                ' CommandBarControl
    Dim objBtn As CommandBarButton                                  ' CommandBarButton
    Dim vntCaption As Variant                                       ' ボタンタイトル
    Dim vntTipText As Variant                                       ' ボタンToolTip
    Dim vntOnAction As Variant                                      ' ボタン起動マクロ
    Dim intIx As Integer                                            ' テーブルINDEX
    Set xlAPP = Application
    '-----------------------------------------------------------------------------------------------
    ' ボタンのタイトルを設定(3個の配列)
    vntCaption = Array("[ 登録 ](&A)", "[ 更新 ](&U)", "[ 削除 ](&X)")  ' ①
    ' ボタンにマウスを当てた時に表示されるテキストを設定(3個の配列)
    vntTipText = Array("登録を行ないます", "更新を行ないます", "削除を行ないます")
    ' ボタンの動作マクロを指定(3個の配列)
    vntOnAction = Array("BTN_TOUROKU", "BTN_KOUSHIN", "BTN_SAKUJO")
    '-----------------------------------------------------------------------------------------------
    ' ツールバーを追加する                                              ' ②
    Set objBar = xlAPP.CommandBars.Add(Name:=g_cnsTitle, Position:=msoBarTop)
    ' 先頭にツールバー名をラベル的に表示(実態はButton)
    Set objCont = objBar.Controls.Add(Type:=msoControlButton)
    Set objBtn = objCont
    objBtn.Style = msoButtonWrapCaption
    objBtn.Caption = g_cnsTitle
    objBtn.TooltipText = ""
    ' ボタンを3つ追加する
    For intIx = 0 To 2
        ' まずボタンを指定してコントロールを追加
        Set objCont = objBar.Controls.Add(Type:=msoControlButton)       ' ③
        ' ボタンの境界を設定
        objCont.BeginGroup = True                                       ' ④
        ' CommandBarButtonオブジェクトの参照を取得
        Set objBtn = objCont                                            ' ⑤
        objBtn.Style = msoButtonCaption             ' ボタン名を表示    ' ⑥
        objBtn.Caption = vntCaption(intIx)          ' 表示名を設定
        objBtn.TooltipText = vntTipText(intIx)      ' マウスを当てた時のツールチップテキスト
        objBtn.OnAction = vntOnAction(intIx)        ' 動作マクロを設定
    Next intIx
    '-----------------------------------------------------------------------------------------------
    ' ツールバーを表示する
    objBar.Visible = True                                               ' ⑦
    ' ツールバーを非表示にできなくする
    objBar.Protection = msoBarNoChangeVisible                           ' ⑧
    '-----------------------------------------------------------------------------------------------
    ' 1秒後にアドインタブを選択する
    xlAPP.OnTime Now + TimeValue("00:00:01"), "GP_ChangeAddinTab"       ' ⑨
    ' オブジェクトの参照を廃棄
    Set objBtn = Nothing
    Set objCont = Nothing
    Set objBar = Nothing
End Sub

'***************************************************************************************************
'* 処理名 :Auto_Close
'* 機能  :閉じる時の自動実行処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年06月16日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub Auto_Close()
    '-----------------------------------------------------------------------------------------------
    Dim xlAPP As Application                                        ' Excel.Application
    Dim objBar As CommandBar                                        ' CommandBar
    Set xlAPP = Application
    ' ホームタブを選択
    Call GP_SelectRibbonTab("ホーム")
    ' ツールバーオブジェクトを取得する
    Set objBar = xlAPP.CommandBars(g_cnsTitle)
    ' ツールバーを削除する
    objBar.Delete
    ' オブジェクトの参照を廃棄
    Set objBar = Nothing
End Sub

'***************************************************************************************************
'   ■■■ ツールバー上のボタンクリック処理 ■■■
'***************************************************************************************************
'* 処理名 :BTN_TOUROKU
'* 機能  :「登録」ボタンがクリックされた時の処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年06月16日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub BTN_TOUROKU()
    '-----------------------------------------------------------------------------------------------
    MsgBox "「登録」が押されました", vbInformation, g_cnsTitle
End Sub

'***************************************************************************************************
'* 処理名 :BTN_KOUSHIN
'* 機能  :「更新」ボタンがクリックされた時の処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年06月16日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub BTN_KOUSHIN()
    '-----------------------------------------------------------------------------------------------
    MsgBox "「更新」が押されました", vbInformation, g_cnsTitle
End Sub

'***************************************************************************************************
'* 処理名 :BTN_KOUSHIN
'* 機能  :「削除」ボタンがクリックされた時の処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年06月16日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub BTN_SAKUJO()
    '-----------------------------------------------------------------------------------------------
    MsgBox "「削除」が押されました", vbInformation, g_cnsTitle
End Sub

'***************************************************************************************************
'   ■■■ サブ処理 ■■■
'***************************************************************************************************
'* 処理名 :GP_ChangeAddinTab
'* 機能  :アドインタブの選択(Application.OnTime起動)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年06月16日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_ChangeAddinTab()
    '-----------------------------------------------------------------------------------------------
    ' アドインタブを選択
    Call GP_SelectRibbonTab("アドイン")
End Sub

'***************************************************************************************************
'* 処理名 :GP_SelectRibbonTab
'* 機能  :リボンの指定名タブを選択
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :Arg1 = タブ名(String)
'*      Arg2 = リボン最小化時も実行(Boolean)           ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日 :2019年06月16日
'* 作成者 :井上 治
'* 更新日 :2019年12月03日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:[参照設定]UIAutomationClient、Excelが起動していない状態からの直接起動では働かない
'***************************************************************************************************
Private Sub GP_SelectRibbonTab(ByVal strTabname As String, _
                               Optional ByVal blnEnableWhenMinimum As Boolean = False)
    '-----------------------------------------------------------------------------------------------
    Dim objCuiAuto As UIAutomationClient.CUIAutomation                          ' CUIAutomation
    Dim objRibbon As UIAutomationClient.IUIAutomationElement                    ' リボン
    Dim objRibbonTab As UIAutomationClient.IUIAutomationElement                 ' リボンタブ
    Dim objUiCondition As UIAutomationClient.IUIAutomationCondition             ' UiCondition
    Dim tblRibbonTab As UIAutomationClient.IUIAutomationElementArray            ' タブテーブル
    Dim objAccPtn As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern   ' AccessiblePattern
    Dim objIAccessible As Office.IAccessible                                    ' IAccessible
    Dim lngIx As Long                                                           ' テーブルINDEX
    Dim lngIxMax As Long                                                        ' テーブルINDEX上限
    '-----------------------------------------------------------------------------------------------
    ' リボンが最小化していたら何もしない(最小化が解除されてしまうため)
    If Not blnEnableWhenMinimum And Application.CommandBars.GetPressedMso("MinimizeRibbon") Then
        Exit Sub
    End If
    '-----------------------------------------------------------------------------------------------
    ' リボンの取得
    Set objCuiAuto = New UIAutomationClient.CUIAutomation
    Set objIAccessible = Application.CommandBars("Ribbon")
    Set objRibbon = objCuiAuto.ElementFromIAccessible(objIAccessible, 0)
    ' リボンタブの取得(配列)
    Set objUiCondition = objCuiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "NetUIRibbonTab")
    Set tblRibbonTab = objRibbon.FindAll(TreeScope_Subtree, objUiCondition)
    lngIxMax = tblRibbonTab.Length - 1
    '-----------------------------------------------------------------------------------------------
    ' タブを巡回
    Do While lngIx <= lngIxMax
        ' 指定タブ名か
        If Trim(tblRibbonTab.GetElement(lngIx).CurrentName) = strTabname Then Exit Do
        ' 次へ
        lngIx = lngIx + 1
    Loop
    ' 指定タブ名がなければ終了
    If lngIx > lngIxMax Then Exit Sub
    '-----------------------------------------------------------------------------------------------
    ' 指定タブを選択
    Set objRibbonTab = tblRibbonTab.GetElement(lngIx)
    Set objAccPtn = objRibbonTab.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
    objAccPtn.DoDefaultAction
End Sub

'----------------------------------------<< End of Source >>----------------------------------------
このサンプルでは「Auto_Open」で記述していますが、ThisWorkbookの「Workbook_Open」に記述しても同じです。以下に記述の説明をいたします。



はツールバーに作成する3つのボタンをテーブル記述で処理するため、Variant型変数にテーブルとして表示名、ツールチップテキスト、プロシージャ名の配列を作成しています。
はツールバーを追加する記述です。Positionの指定でExcelウィンドウの上下左右やフローティングの指定ができます。
このすぐ下でタイトルラベルに模したボタンを配置しています。
Forのループ内で3回ボタンをツールバー上に追加します。Typeでボタンを指定していますが、この指定によってコンボボックスやサブメニューも選択できます。
ツールバー上のコントロール間に境界線を入れるかどうかの指定です。
「ボタン」としてのプロパティを設定するため、ボタンのオブジェクトに取得し直します。
「ボタン」の形式や表示名、ツールチップテキスト、プロシージャ名を設定します。
ツールバーを表示させます。
ツールバーをマウスでフローティング引き出したり右クリックした時に「閉じる」の操作ができないようにします。
ここで「アドイン」タブを選択しますが、実際に「アドイン」タブを選択する動作は一番下の「GP_SelectRibbonTab」なのです。
ですが、「GP_SelectRibbonTab」を直接呼び出すように記述すると、先にExcelが起動している時は「アドイン」タブが選択されますが、 Excelが起動していない状態からエクスプローラ等からこのワークブックを開いた場合は「アドイン」タブは選択されません。
これはどうやらこのワークブックを開く動作と、Excel側のリボン形成が並行して行なわれるためのようなので、 単に「GP_SelectRibbonTab」を呼び出すプロシージャを別に作成(GP_ChangeAddinTab)し、 ここでは1秒後にそのプロシージャが起動されるように仕掛けます。
このワークブックを閉じる際は「Auto_Close」が動作します。
ここではリボンの選択タブを「ホーム」に戻して、追加したツールバーを削除しています。