'***************************************************************************************************
' アドインの動作テスト(ワークブックイベント記述) ThisWorkbook(Class)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
' ・Microsoft Scripting Runtime
'***************************************************************************************************
' 変更日付 Rev 変更履歴内容---------------------------------------------------------------------->
' 04/11/13(1.0.0)新規作成
' 19/06/16(1.1.0)*.xlam版アドイン用に再作成
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsADDIN = "ADDIN_TEST.xlam" ' アドインファイル名
Private Const g_cnsSETTEI = "設定" ' 設定シート名
Private Const g_cnsPASS = "password" ' PW
Private g_swCLOSE As Boolean ' CLOSE判定
'***************************************************************************************************
' ■■■ ワークブックイベント ■■■
'***************************************************************************************************
'* 処理名 :Workbook_BeforeClose
'* 機能 :ブックClose前イベント
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = Cancel(Boolean) ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:ツールバー削除の処理を呼び、必要ならアドインを閉じる
'* 注意事項:
'***************************************************************************************************
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'-----------------------------------------------------------------------------------------------
Const cnsTitle As String = "終了処理"
Dim xlAPP As Application ' Excel.Application
Dim objWBK As Workbook ' 本ブック
Dim objSH_SETTEI As Worksheet ' 設定シート
Set xlAPP = Application
Set objWBK = ThisWorkbook
Set objSH_SETTEI = objWBK.Worksheets(g_cnsSETTEI)
'-----------------------------------------------------------------------------------------------
' アドインが開かれていない場合は処理なし
If objSH_SETTEI.Cells(1, 1).Value <> g_cnsADDIN Then Exit Sub
'-----------------------------------------------------------------------------------------------
' 非保存の確認
If Not objWBK.ReadOnly Then
Select Case MsgBox("このブックは保存されていません。" & vbCr & _
"保存して終了しますか?", vbYesNoCancel, cnsTitle)
Case vbYes
xlAPP.StatusBar = False
objWBK.Save ' 上書き保存
Case vbCancel
Cancel = True ' Closeをキャンセル
Exit Sub
End Select
End If
'-----------------------------------------------------------------------------------------------
' ツールバー削除の処理を呼ぶ(引数は本ブック名) ※アドイン削除指示が返る
If xlAPP.Run("'" & g_cnsADDIN & "'!ToolBarDelete", objWBK.Name) Then
' アドイン削除指示の時はアドインをCLOSE
On Error Resume Next
xlAPP.Workbooks(g_cnsADDIN).Close False
End If
xlAPP.StatusBar = False
g_swCLOSE = True
objWBK.Saved = True ' 保存済みにする
End Sub
'***************************************************************************************************
'* 処理名 :Workbook_Open
'* 機能 :ワークブックOpen時イベント
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:アドインを開き、初期処理マクロを起動する
'* 注意事項:
'***************************************************************************************************
Private Sub Workbook_Open()
'-----------------------------------------------------------------------------------------------
Dim objFso As FileSystemObject ' FileSystemObject
Dim xlAPP As Application ' Excel.Application
Dim objWBK As Workbook ' 本ブック
Dim objSH_SETTEI As Worksheet ' 設定シート
Dim strFilename As String ' ファイル名
Set objFso = New FileSystemObject
Set xlAPP = Application
Set objWBK = ThisWorkbook
Set objSH_SETTEI = objWBK.Worksheets(g_cnsSETTEI)
' アドインが開いたかの判定スイッチをクリア
objSH_SETTEI.Cells(1, 1).Value = "" ' アドインファイル名
objSH_SETTEI.Cells(2, 1).Value = "" ' ツールバー名
'-----------------------------------------------------------------------------------------------
strFilename = objFso.BuildPath(objWBK.Path, g_cnsADDIN)
' アドインの存在確認(このサンプルではワークブックと同じフォルダ)
' ⇒多くのユーザーで共用する場合はそのアドインは共通フォルダに配置すべきです
If Not objFso.FileExists(strFilename) Then
' 指定場所にアドインが存在しない
' ここでエラーにするか、そのままExitさせるかでアドインがない時の処置が違う
' 他の場所からアドインを開くという場合もある
' このサンプルでは設定シートのアドイン有無をクリアしているのでそのまま抜ける
GoTo Open_AddinEXIT
End If
'-----------------------------------------------------------------------------------------------
On Error GoTo Open_AddinError
' アドイン側の初期処理マクロの起動(引数は本ブック名)
Call xlAPP.Run("'" & g_cnsADDIN & "'!InitialProc", objWBK.Name)
GoTo Open_AddinEXIT
'===================================================================================================
' アドインが開かれていない時の処理
Open_AddinError:
' アドインを開く
xlAPP.Workbooks.Open Filename:=strFilename, ReadOnly:=True, Password:=g_cnsPASS
On Error GoTo 0
' 自ブックをアクティブに戻す
objWBK.Activate
Resume
'===================================================================================================
' 終了
Open_AddinEXIT:
Set objFso = Nothing
End Sub
'***************************************************************************************************
'* 処理名 :Workbook_SheetActivate
'* 機能 :シート切替時イベント(Activate)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = 対象シート(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2004年11月13日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
'-----------------------------------------------------------------------------------------------
' ツールバー状態制御
Call Workbook_ToolBarEnable
End Sub
'***************************************************************************************************
'* 処理名 :Workbook_WindowActivate
'* 機能 :Window切替時イベント(Activate)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = 対象Window(Window)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2004年11月13日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub Workbook_WindowActivate(ByVal Wn As Window)
'-----------------------------------------------------------------------------------------------
' ツールバー状態制御
Call Workbook_ToolBarEnable
End Sub
'***************************************************************************************************
'* 処理名 :Workbook_WindowDeactivate
'* 機能 :Window切替時イベント(Deactivate)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = 対象Window(Window)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2004年11月13日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
'-----------------------------------------------------------------------------------------------
' Close時は処理なし(削除したツールバーが再度表示されてしまうため)
If g_swCLOSE = True Then Exit Sub
' ツールバー状態制御
Call Workbook_ToolBarEnable
End Sub
'***************************************************************************************************
' ■■■ 共通サブ処理 ■■■
'***************************************************************************************************
'* 処理名 :Workbook_ToolBarEnable
'* 機能 :ツールバー状態制御
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub Workbook_ToolBarEnable()
'-----------------------------------------------------------------------------------------------
Dim objWBK As Workbook ' 本ブック
Dim objSH_SETTEI As Worksheet ' 設定シート
Set objWBK = ThisWorkbook
Set objSH_SETTEI = objWBK.Worksheets(g_cnsSETTEI)
'-----------------------------------------------------------------------------------------------
' アドインが開かれていない場合は処理なし
If objSH_SETTEI.Cells(1, 1).Value <> g_cnsADDIN Then Exit Sub
'-----------------------------------------------------------------------------------------------
' ツールバー状態制御
On Error Resume Next
Call Application.Run("'" & g_cnsADDIN & "'!ToolBarEnable", objWBK.Name)
End Sub
'------------------------------------------<< End of Source >>--------------------------------------
ワークシート切り替え、ウィンドウ切り替えの各イベント処理で全く同じ記述が発生するので、「
'***************************************************************************************************
' アドインの動作テスト(アドイン側マクロ) Module1(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
' ・Microsoft Scripting Runtime
' ・UIAutomationClient
'***************************************************************************************************
' 変更日付 Rev 変更履歴内容---------------------------------------------------------------------->
' 04/11/13(1.0.0)新規作成
' 19/06/16(1.1.0)*.xlam版アドインとして再作成
' 19/12/28(1.1.1)GP_ChangeAddinTabでタブ名取得時にTrimを追加する対応
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTITLE As String = "アドインテスト"
'---------------------------------------------------------------------------------------------------
Private Const g_cnsVERSION As String = "1.1.1" ' バージョン
Private Const g_cnsUPDATE_DATE As Date = #12/28/2019# ' バージョン更新日
'---------------------------------------------------------------------------------------------------
Private Const g_cnsSH1 As String = "Sheet1"
Private Const g_cnsSH2 As String = "Sheet2"
Private Const g_cnsSH3 As String = "設定"
Private Const g_cnsXLA As String = "ADDIN_TEST.xlam"
'---------------------------------------------------------------------------------------------------
' GP_SetObjectで確保される変数
Private g_xlAPP As Application ' Excel.Application
Private g_WBK As Workbook ' ワークブック
Private g_ADN As Workbook ' 本アドイン
Private g_SH1 As Worksheet ' Sheet1(ブック側)
Private g_SH2 As Worksheet ' Sheet2(ブック側)
Private g_SH3 As Worksheet ' 設定(ブック側)
Private g_strWbkName As String ' ワークブック名
'***************************************************************************************************
' ■■■ ブック側からのイベント起動処理 ■■■
'***************************************************************************************************
'* 処理名 :InitialProc
'* 機能 :初期処理(ブック側Openイベント起動)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = ブック名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub InitialProc(ByVal strBookName As String)
'-----------------------------------------------------------------------------------------------
' Object取得
Call GP_SetObject(strBookName)
' 画面描画停止
Call GP_StopScreen
'-----------------------------------------------------------------------------------------------
' TODO: 初期処理でシート保護やマスタテーブルの読み込み等必要な処理を行なう
'-----------------------------------------------------------------------------------------------
' アドインが開いたかの判定項目にアドイン名をセット
g_SH3.Cells(1, 1).Value = g_cnsXLA
' 保存されているワークブックのバージョンが最新でない場合はバージョン更新を行なう
If ((g_SH3.Cells(3, 1).Value < g_cnsVERSION) Or _
(g_SH3.Cells(4, 1).Value < g_cnsUPDATE_DATE)) Then
' バージョン更新処理
Call GP_VersionUP
End If
'-----------------------------------------------------------------------------------------------
' Sheet1を選択(これは例です)
g_SH1.Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Cells(1, 1).Select
'-----------------------------------------------------------------------------------------------
' ツールバー作成
Call GP_ToolBarEnable(strBookName)
' 1秒後にアドインタブを選択する
g_xlAPP.OnTime Now + TimeValue("00:00:01"), "GP_ChangeAddinTab"
End Sub
'***************************************************************************************************
'* 処理名 :ToolBarDelete
'* 機能 :終了処理(ブック側BeforeCloseイベント起動)
'---------------------------------------------------------------------------------------------------
'* 返り値 :アドイン削除指示(Boolean)
'* 引数 :Arg1 = ブック名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Function ToolBarDelete(ByVal strBookName As String) As Boolean
'-----------------------------------------------------------------------------------------------
Dim objWBK As Workbook ' WORK
Dim blnDel As Boolean ' アドイン削除判定
'-----------------------------------------------------------------------------------------------
' Object取得
Call GP_SetObject(strBookName)
'-----------------------------------------------------------------------------------------------
blnDel = True
' 開いている他ブックが本アドインを使用しているか確認
For Each objWBK In g_xlAPP.Workbooks
' 本ブックではなく、同じシート数である
If ((objWBK.Name <> strBookName) And _
(objWBK.Worksheets.Count = 3)) Then
' 3番目のシート名が「設定」でA1セルにアドイン名が登録されている
If ((objWBK.Worksheets(3).Name = g_cnsSH3) And _
(objWBK.Worksheets(3).Cells(1, 1).Value = g_cnsXLA)) Then
blnDel = False
Exit For
End If
End If
Next objWBK
'-----------------------------------------------------------------------------------------------
If blnDel Then
' ホームタブを選択(アドイン削除の場合)
Call GP_SelectRibbonTab("ホーム")
End If
'-----------------------------------------------------------------------------------------------
' ツールバー撤去
Call GP_ToolBarDelete
' アドイン削除判定を返す
ToolBarDelete = blnDel
End Function
'***************************************************************************************************
'* 処理名 :ToolBarEnable
'* 機能 :ツールバー状態制御処理(ブック側イベント起動)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = ブック名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub ToolBarEnable(strBookName As String)
'-----------------------------------------------------------------------------------------------
' Object取得
Call GP_SetObject(strBookName)
' 画面描画停止
Call GP_StopScreen
' ツールバー状態制御
Call GP_ToolBarEnable(strBookName)
End Sub
'***************************************************************************************************
' ■■■ カスタムツールバーからの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :CB_BUTTON1
'* 機能 :「処理1」ボタンの処理(カスタムツールバー起動)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub CB_BUTTON1()
'-----------------------------------------------------------------------------------------------
' Object取得(実行時エラー等の対応のため再取得する)
Call GP_SetObject
'-----------------------------------------------------------------------------------------------
' ここで処理1がクリックされた時点の処理を記述する(ここではメッセージ表示のみ)
MsgBox "「処理1」がクリックされました。" & vbCr & _
"処理ブック=" & g_WBK.Name & vbCr & _
"処理シート=" & ActiveSheet.Name, vbInformation, g_cnsTITLE
End Sub
'***************************************************************************************************
'* 処理名 :CB_BUTTON2
'* 機能 :「処理2」ボタンの処理(カスタムツールバー起動)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub CB_BUTTON2()
'-----------------------------------------------------------------------------------------------
' Object取得(実行時エラー等の対応のため再取得する)
Call GP_SetObject
'-----------------------------------------------------------------------------------------------
' ここで処理2がクリックされた時点の処理を記述する(ここではメッセージ表示のみ)
MsgBox "「処理2」がクリックされました。" & vbCr & _
"処理ブック=" & g_WBK.Name & vbCr & _
"処理シート=" & ActiveSheet.Name, vbInformation, g_cnsTITLE
End Sub
'***************************************************************************************************
'* 処理名 :CB_BUTTON3
'* 機能 :「処理3」ボタンの処理(カスタムツールバー起動)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub CB_BUTTON3()
'-----------------------------------------------------------------------------------------------
' Object取得(実行時エラー等の対応のため再取得する)
Call GP_SetObject
'-----------------------------------------------------------------------------------------------
' ここで処理3がクリックされた時点の処理を記述する(ここではメッセージ表示のみ)
MsgBox "「処理3」がクリックされました。" & vbCr & _
"処理ブック=" & g_WBK.Name & vbCr & _
"処理シート=" & ActiveSheet.Name, vbInformation, g_cnsTITLE
End Sub
'***************************************************************************************************
'* 処理名 :CB_BUTTON4
'* 機能 :「処理4」ボタンの処理(カスタムツールバー起動)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub CB_BUTTON4()
'-----------------------------------------------------------------------------------------------
' Object取得(実行時エラー等の対応のため再取得する)
Call GP_SetObject
'-----------------------------------------------------------------------------------------------
' ここで処理4がクリックされた時点の処理を記述する(ここではメッセージ表示のみ)
MsgBox "「処理4」がクリックされました。" & vbCr & _
"処理ブック=" & g_WBK.Name & vbCr & _
"処理シート=" & ActiveSheet.Name, vbInformation, g_cnsTITLE
End Sub
'***************************************************************************************************
' ■■■ サブ処理 ■■■
'***************************************************************************************************
'* 処理名 :GP_SetObject
'* 機能 :Bookオブジェクト取得
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = ブック名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月17日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_SetObject(Optional ByVal strBookName As String)
'-----------------------------------------------------------------------------------------------
' ブック名確保済みなら処理無し
If ((strBookName <> "") And (strBookName = g_strWbkName)) Then Exit Sub
Set g_xlAPP = Application ' Excel.Application
' ブック名が指定されているか
If strBookName <> "" Then
Set g_WBK = g_xlAPP.Workbooks(strBookName) ' 処理ワークブック
Else
Set g_WBK = ActiveWorkbook
End If
g_strWbkName = g_WBK.Name ' 処理ワークブック名
Set g_ADN = ThisWorkbook ' 本アドイン
Set g_SH1 = g_WBK.Worksheets(g_cnsSH1) ' Sheet1シート(ブック側)
Set g_SH2 = g_WBK.Worksheets(g_cnsSH2) ' Sheet2シート(ブック側)
Set g_SH3 = g_WBK.Worksheets(g_cnsSH3) ' 設定シート(ブック側)
End Sub
'***************************************************************************************************
'* 処理名 :GP_ToolBarEnable
'* 機能 :カスタムツールバーの状態制御
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = ブック名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_ToolBarEnable(Optional ByVal strBookName As String)
'-----------------------------------------------------------------------------------------------
Dim objCBar As CommandBar ' カスタムツールバー
Dim objButton As CommandBarButton ' ボタン
Dim objSh As Worksheet ' 対象シート
Dim intIx As Integer ' テーブルINDEX
'-----------------------------------------------------------------------------------------------
' ツールバー取得
On Error GoTo ToolBarEnable_ERROR
Set objCBar = g_xlAPP.CommandBars(g_SH3.Cells(2, 1).Value)
' ツールバーを非表示にできなくする
objCBar.Protection = msoBarNoChangeVisible
On Error GoTo 0
'-----------------------------------------------------------------------------------------------
' ツールバー上のボタン制御(例)
With objCBar
' 現在ブックが異なるか
If ActiveWorkbook.Name <> strBookName Then
' 自ブックがアクティブでない場合は全ボタンをFalseにする
For intIx = 1 To 4
.Controls(intIx).Enabled = False
Next intIx
' ツールバーを非表示にする
.Visible = False
Else
' 自ブックがアクティブの時はSelectedシートによりボタンを制御
Select Case ActiveSheet.Name
Case g_cnsSH1 ' Sheet1
' [例]処理1と処理3を有効にする
.Controls(1).Enabled = True ' 処理1
.Controls(2).Enabled = False ' 処理2
.Controls(3).Enabled = True ' 処理3
.Controls(4).Enabled = False ' 処理4
Case g_cnsSH2 ' Sheet2
' [例]処理2と処理4を有効にする
.Controls(1).Enabled = False ' 処理1
.Controls(2).Enabled = True ' 処理2
.Controls(3).Enabled = False ' 処理3
.Controls(4).Enabled = True ' 処理4
Case Else ' その他
' Sheet1,Sheet2以外は全ボタンをFalseにする
For intIx = 1 To 4
.Controls(intIx).Enabled = False
Next intIx
End Select
.Controls(5).Enabled = False ' ツールバー名
.Visible = True
End If
End With
GoTo ToolBarEnable_EXIT
'===================================================================================================
' エラー処理
ToolBarEnable_ERROR:
' ツールバー作成
Call GP_SetToolbar(strBookName)
Resume
'===================================================================================================
' 終了
ToolBarEnable_EXIT:
Set objCBar = Nothing
' 画面描画再開
If g_xlAPP.ScreenUpdating <> True Then Call GP_StartScreen
On Error GoTo 0
End Sub
'***************************************************************************************************
'* 処理名 :GP_SetToolbar
'* 機能 :カスタムツールバーの作成
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = ブック名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2019年06月16日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_SetToolbar(Optional ByVal strBookName As String)
'-----------------------------------------------------------------------------------------------
Dim objCBar As CommandBar ' カスタムツールバー
Dim lngPos As Long ' 文字位置Work
Dim strBarName As String ' カスタムツールバー名
'-----------------------------------------------------------------------------------------------
' カスタムツールバーの名称を編集(名称はブック名の拡張子抜き)
If strBookName <> "" Then
lngPos = InStrRev(strBookName, ".")
strBarName = Left(strBookName, lngPos - 1)
' 同一ブック再OPEN対応
On Error Resume Next
Set objCBar = g_xlAPP.CommandBars(strBarName)
' 当該ツールバーが既に存在する場合はこのまま終了
If Err.Number = 0 Then
g_SH3.Cells(2, 1).Value = strBarName
GoTo GET_SetToolBar_EXIT
End If
Else
lngPos = InStrRev(g_WBK.Name, ".")
strBarName = Left(g_WBK.Name, lngPos - 1)
End If
'-----------------------------------------------------------------------------------------------
On Error GoTo GET_SetToolBar_ERROR
' カスタムツールバーを追加
Set objCBar = g_xlAPP.CommandBars.Add(strBarName, msoBarTop, False, True)
g_SH3.Cells(2, 1).Value = strBarName
On Error GoTo 0
'-----------------------------------------------------------------------------------------------
' 処理1(Index=1)
Call GP_SetButton(objCBar, "[ 処理1 ](&1)", _
"[処理1]はSheet1が選択中のみクリックできます。", "CB_BUTTON1", False)
' 処理2(Index=2)
Call GP_SetButton(objCBar, "[ 処理2 ](&2)", _
"[処理2]はSheet2が選択中のみクリックできます。", "CB_BUTTON2", True)
' 処理3(Index=3)
Call GP_SetButton(objCBar, "[ 処理3 ](&3)", _
"[処理3]はSheet1が選択中のみクリックできます。", "CB_BUTTON3", True)
' 処理4(Index=4)
Call GP_SetButton(objCBar, "[ 処理4 ](&4)", _
"[処理4]はSheet2が選択中のみクリックできます。", "CB_BUTTON4", True)
' Dummy(Index=5:ツールバー名の表示)
Call GP_SetButton(objCBar, "BarName=" & strBarName, _
"これが現在のツールバー名です。", "", True)
GoTo GET_SetToolBar_EXIT
'===================================================================================================
GET_SetToolBar_ERROR:
' ツールバーが存在する場合は削除して作り直す
Call GP_ToolBarDelete
Resume
'===================================================================================================
GET_SetToolBar_EXIT:
Set objCBar = Nothing
On Error GoTo 0
End Sub
'***************************************************************************************************
'* 処理名 :GP_SetButton
'* 機能 :カスタムツールバー上のボタンセット
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = カスタムツールバー(Object)
'* Arg2 = ボタン表示名(String)
'* Arg3 = TooltipText(String)
'* Arg4 = 実行プロシージャ(String)
'* Arg5 = グループの始まり(Boolean)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2004年11月13日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_SetButton(ByRef objCBar As CommandBar, _
ByVal strCaption As String, _
ByVal strTipText As String, _
ByVal strOnAction As String, _
ByVal blnTrue As Boolean)
'-----------------------------------------------------------------------------------------------
Dim objCont As CommandBarControl ' CommandBarControl
Dim objButton As CommandBarButton ' CommandBarButton
'-----------------------------------------------------------------------------------------------
' ツールバー上にボタンを追加
Set objCont = objCBar.Controls.Add(Type:=msoControlButton, Temporary:=True)
' グループの始まり
objCont.BeginGroup = blnTrue
'-----------------------------------------------------------------------------------------------
Set objButton = objCont
' ボタン上の設定
With objButton
.Style = msoButtonCaption ' ボタン名を表示
.Caption = strCaption ' ボタン表示名
.TooltipText = strTipText ' ツールチップテキスト
.OnAction = strOnAction ' クリック時のプロシージャ名
End With
Set objButton = Nothing
Set objCont = Nothing
End Sub
'***************************************************************************************************
'* 処理名 :GP_ToolBarDelete
'* 機能 :カスタムツールバーの削除
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2004年11月13日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_ToolBarDelete()
'-----------------------------------------------------------------------------------------------
Dim objCBar As CommandBar ' カスタムツールバー
On Error GoTo ToolBarDelete_EXIT
Set objCBar = g_xlAPP.CommandBars(g_SH3.Cells(2, 1).Value)
' ツールバーを削除
objCBar.Delete
'===================================================================================================
ToolBarDelete_EXIT:
' ツールバー名を消去
g_SH3.Cells(2, 1).Value = ""
' ツールバーがない場合は無視
Set objCBar = Nothing
On Error GoTo 0
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月28日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:[参照設定]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
'***************************************************************************************************
'* 処理名 :GP_StopScreen
'* 機能 :画面描画停止
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2004年11月13日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_StopScreen()
'-----------------------------------------------------------------------------------------------
With g_xlAPP
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
' .EnableCancelKey = xlDisabled ' テスト中はコメントアウト
End With
End Sub
'***************************************************************************************************
'* 処理名 :GP_StartScreen
'* 機能 :画面描画再開
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2004年11月13日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_StartScreen()
'-----------------------------------------------------------------------------------------------
With g_xlAPP
.EnableCancelKey = xlInterrupt
If .Calculation <> xlCalculationAutomatic Then
.Calculation = xlCalculationAutomatic
End If
.StatusBar = False
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
'***************************************************************************************************
'* 処理名 :GP_VersionUP
'* 機能 :バージョン更新処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2004年11月13日
'* 作成者 :井上 治
'* 更新日 :2004年11月13日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_VersionUP()
'-----------------------------------------------------------------------------------------------
' バージョンによってワークブックを更新する必要がある場合はここに低い方から記述する
'If g_SH3.Cells(3, 1).Value < "1.01" Then
'-----------------------------------------------------------------------------------------------
' 新しいバージョンの登録
g_SH3.Cells(3, 1).Value = g_cnsVERSION ' バージョン
g_SH3.Cells(4, 1).Value = g_cnsUPDATE_DATE ' バージョン更新日
End Sub
'------------------------------------------<< End of Source >>--------------------------------------