'***************************************************************************************************
' ツールバーテスト 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 >>----------------------------------------
このサンプルでは「