前回、ファイル→アカウントの画面から製品情報のバージョン(製品エディション)を取得する方法を紹介しましたが、それだけでは正確なバージョンが不明なケースがある(Office Premium)ようなので、更に｢バージョン情報｣ボタンを押して表示されるダイアログからバージョンを取得する方法も紹介します。
32bit, 64bit どちらでも動く想定です。
取得例：
Microsoft® Excel® 2016 MSO (バージョン 2407 ビルド 16.0.17830.20166) 64 ビット
Microsoft® Excel® 2019 MSO (バージョン 2407 ビルド 16.0.17830.20166) 32 ビット
【注意】WinAPIでHookを使うので、もし何かあればExcelが落ちるという可能性も0では無いので、そのあたりも含めて自己責任でお願いします。
※2024/9/4 修正(HookでWindowCloseのタイミング、検索値のConst化、バージョン情報の検索を2段階化)
プログラム：
Option Explicit
Public Enum E_WinAPI_SetWindowsHookEx_HCBT 'nCode
HCBT_Activate = 5 'ウィンドウのアクティブ化直前
HCBT_ClickSkipped = 6 'クリック
HCBT_CreateWnd = 3 'ウィンドウ作成直前
HCBT_DestroyWnd = 4 'ウィンドウ破棄直前
HCBT_KeySkipped = 7 'キー押下時
HCBT_MinMax = 1 'ウィンドウ最小化or最大化直前
HCBT_MoveSize = 0 'ウィンドウの移動orリサイズ直前
HCBT_QS = 2 'システムのメッセージキューからWS_QueueSyncメッセージが取り出された
HCBT_SetFocus = 9 'ウィンドウが入力フォーカスを受取る直前
HCBT_SysCommand = 8 'メッセージキューからシステムコマンドメッセージが取り出された
End Enum
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hhk As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As LongPtr, lpdwProcessId As Long) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassname As String, ByVal nNameLength As Long) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As Any) As Long
Private glDialogVersion As String
Private Const BTN_ACCOUNT As String = "アカウント"
Private Const BTN_OTHER As String = "その他のオプション"
Private Const BTN_VERSION As String = "Excel のバージョン情報"
Public Function GetVersion_by_UIAutomation(Optional ByRef DetailVersion As String = "") As String
DetailVersion = "" '引数の戻り値をクリア
'アプリのウィンドウハンドルを取得
Dim hWnd As LongPtr
hWnd = Application.hWnd
'【参照設定】UIAutomationClient
'UIAutomationを生成
Dim uiAuto As CUIAutomation
Set uiAuto = New CUIAutomation
'ツリー操作用のオブジェクトを取得しておく
Dim treeWalker As IUIAutomationTreeWalker
Set treeWalker = uiAuto.ControlViewWalker
'リボンのコマンドバーを取得
Dim IAccBar As CommandBar
Set IAccBar = Application.CommandBars("Ribbon")
'リボンの要素を取得
Dim ElmRbn As IUIAutomationElement
Set ElmRbn = uiAuto.ElementFromIAccessible(IAccBar, 0)
'最上位の要素を取得
Dim ElmWin As IUIAutomationElement
Dim ElmTmp As IUIAutomationElement
Set ElmTmp = ElmRbn
Do
Set ElmTmp = treeWalker.GetParentElement(ElmTmp)
If ElmTmp Is Nothing Then Exit Do
Set ElmWin = ElmTmp
Loop
'リボンの[ファイル]タブを取得
Dim ElmTab_File As IUIAutomationElement
Set ElmTab_File = uiaFindElement(uiAuto, ElmWin, "NetUIRibbonTab", "FileTabButton")
If ElmTab_File Is Nothing Then
Call MsgBox("リボンの[ファイル]タブが見つけられませんでした")
Exit Function
End If
'リボン左上の[ファイル]押下
If uiaElmClick(ElmTab_File) = False Then Exit Function
'ファイルバーの要素を取得
Dim ElmBar_File As IUIAutomationElement
Set ElmBar_File = uiaFindElement(uiAuto, ElmWin, "NetUIKeyboardTabElement", "NavBarMenu")
If ElmBar_File Is Nothing Then
Call MsgBox("[ファイル]タブバーが見つけられませんでした")
Exit Function
End If
'[アカウント]ボタンを取得]
Dim ElmAccount As IUIAutomationElement
Set ElmAccount = uiaFindElement(uiAuto, ElmBar_File, "NetUIRibbonTab", Name:=BTN_ACCOUNT, MaxTry:=1)
If ElmAccount Is Nothing Then
'見つからなかったら、その他オプションから辿って取得する
'[その他]ボタンを探す
Dim ElmOther As IUIAutomationElement
Set ElmOther = uiaFindElement(uiAuto, ElmBar_File, "NetUIStickyButton", Name:=BTN_OTHER)
If ElmOther Is Nothing Then
Call MsgBox("ファイルタブ中の[その他]ボタンが見つかりませんでした")
GoTo Terminate
End If
'[その他]ボタン押下(※一時的にメニューが表示されるので、[アカウント]クリックまで連続で処理が必要)
If uiaElmClick(ElmOther, ExpandCollapse:=True) = False Then GoTo Terminate
'[アカウント]ボタンを探す
Set ElmAccount = uiaFindElement(uiAuto, ElmBar_File, "NetUIListViewItem", Name:=BTN_ACCOUNT)
If ElmAccount Is Nothing Then
Call MsgBox("その他オプションメニューの[アカウント]ボタンが見つかりませんでした")
GoTo Terminate
End If
End If
'[アカウント]ボタン押下
If uiaElmClick(ElmAccount) = False Then GoTo Terminate
'表示画面のトップ要素を取得(子要素を全検索して探す)
Dim ElmBackStage As IUIAutomationElement
Set ElmBackStage = uiaFindElement(uiAuto, ElmWin, "NetUIScrollViewer", "BackstageView")
'ラベルの中からオフィスのバージョン(エディション)を探す
Dim VerPrd As String
VerPrd = GetVersionLabel(uiAuto, ElmBackStage, "Microsoft Office ")
If VerPrd = "" Then
VerPrd = GetVersionLabel(uiAuto, ElmBackStage, "Microsoft ") '[Office]が無いケースに対応
End If
'バージョンボタン押下で表示されるダイアログにある詳細なバージョンを取得
DetailVersion = GetVersionDetail(uiAuto, ElmBackStage)
Debug.Print DetailVersion
'※デバッグ用
' '要素のRECTを取得
' Dim elementRect As tagRECT
' elementRect = ElmBackStage.CurrentBoundingRectangle
' elementRect = ElmDetail.CurrentBoundingRectangle
' elementRect = ElmVersion.CurrentBoundingRectangle
' Dim Ver As String
' Ver = uiaElmText(ElmVersion)
If VerPrd = "" Then
Call MsgBox("バージョンのテキストが取得できませんでした")
GoTo Terminate
End If
GetVersion_by_UIAutomation = VerPrd
Terminate:
'戻るボタンでシート表示に戻る
Dim ElmReturn As IUIAutomationElement
Set ElmReturn = uiaFindElement(uiAuto, ElmBar_File, "NetUISimpleButton", "FileTabButton")
If ElmReturn Is Nothing Then
Call MsgBox("ファイルタブ中の[戻る]ボタンが見つかりませんでした")
Exit Function
End If
If uiaElmClick(ElmReturn) = False Then Exit Function
End Function
Private Function DebugPattern(Element As IUIAutomationElement)
Dim i As Long
For i = 10000 To 10000 + 30
If Element.GetCurrentPattern(i) Is Nothing = False Then
Debug.Print i; TypeName(Element.GetCurrentPattern(i))
End If
Next
End Function
Private Function uiaElmText(Element As IUIAutomationElement) As String
Const UIA_ValuePatternId = 10002
Const UIA_ScrollItemPatternId = 10017
Const UIA_LegacyIAccessiblePatternId = 10018
' Call DebugPattern(Element)
Dim valuePattern As IUIAutomationValuePattern
Set valuePattern = Element.GetCurrentPattern(UIA_ValuePatternId)
Dim Text As String
If valuePattern Is Nothing = False Then
Text = valuePattern.CurrentValue
Else
Text = Element.CurrentName
End If
If Text = "" Then Exit Function
uiaElmText = Text
End Function
Private Function uiaElmClick(Element As IUIAutomationElement, Optional ExpandCollapse As Boolean = False) As Boolean
On Error Resume Next
Element.SetFocus
On Error GoTo 0
Const UIA_InvokePatternId = 10000
If ExpandCollapse = False Then
Dim PatternId As Long
PatternId = UIA_InvokePatternId
' Call DebugPattern(Element)
'ボタン押下(通常)
Dim BtnClick As IUIAutomationInvokePattern
Set BtnClick = Element.GetCurrentPattern(PatternId)
If BtnClick Is Nothing = False Then
On Error GoTo Terminate
BtnClick.Invoke
DoEvents
Else
'もし「アカウント」ボタンが「その他オプション」ではなく、そのまま表示されていたら、そのまま選択
Const UIA_SelectionItemPatternId = 10010
Dim SelClick As IUIAutomationSelectionItemPattern
Set SelClick = Element.GetCurrentPattern(UIA_SelectionItemPatternId)
If SelClick Is Nothing = False Then
On Error GoTo Terminate
SelClick.Select
DoEvents
End If
End If
Else
'「その他オプション」メニューボタン押下
Const UIA_ExpandCollapsePatternId = 10005
PatternId = UIA_ExpandCollapsePatternId
' Call DebugPattern(Element)
Dim ExpClick As UIAutomationClient.IUIAutomationExpandCollapsePattern
Set ExpClick = Element.GetCurrentPattern(PatternId)
If ExpClick Is Nothing Then Exit Function
On Error GoTo Terminate
Call ExpClick.Expand
End If
uiaElmClick = True
Terminate:
End Function
Private Function uiaFindElement(uiAuto As UIAutomationClient.CUIAutomation, _
ElmWin As UIAutomationClient.IUIAutomationElement, _
ClassName As String, _
Optional AutomationId As String, _
Optional Name As String, _
Optional MaxTry As Long = 10) As IUIAutomationElement
'検索条件を設定
Dim Conditions(1) As IUIAutomationCondition
Set Conditions(0) = uiAuto.CreatePropertyCondition(30012, ClassName)
If AutomationId <> "" Then
Set Conditions(1) = uiAuto.CreatePropertyCondition(30011, AutomationId)
Else
Set Conditions(1) = uiAuto.CreatePropertyCondition(30005, Name)
End If
'検索条件の生成
Dim uiCnd As IUIAutomationCondition
Set uiCnd = uiAuto.CreateAndConditionFromNativeArray(Conditions(0), 2)
'要素を検索
Dim i As Long
For i = 1 To MaxTry
Dim Element As IUIAutomationElement
Set Element = ElmWin.FindFirst(TreeScope_Descendants, uiCnd)
If Element Is Nothing = False Then Exit For
DoEvents
Next
If Element Is Nothing Then Exit Function
Set uiaFindElement = Element
End Function
Private Function GetVersionLabel(uiAuto As CUIAutomation, Element As IUIAutomationElement, FindName As String) As String
'ラベルの要素を探す検索条件を生成
Dim Condition As IUIAutomationCondition
Set Condition = uiAuto.CreatePropertyCondition(UIA_ControlTypePropertyId, UIA_ControlTypeIds.UIA_TextControlTypeId)
'ラベルの要素を検索
Dim Finds As IUIAutomationElementArray
Set Finds = Element.FindAll(TreeScope_Descendants, Condition)
'ラベルの中からオフィスのバージョン(エディション)を探す
Dim i As Long
For i = 1 To Finds.Length
Dim ElmLabel As IUIAutomationElement
Set ElmLabel = Finds.GetElement(i - 1)
'製品情報とみなせる文言で始まる値が見つかったら抜ける
Dim VerPrd As String
VerPrd = uiaElmText(ElmLabel)
If VerPrd <> "" Then
If InStr(1, VerPrd, FindName) = 1 Then
Exit For
End If
End If
VerPrd = "" 'クリア
Next
If VerPrd = "" Then Exit Function
GetVersionLabel = VerPrd
End Function
Private Function GetVersionDetail(uiAuto As UIAutomationClient.CUIAutomation, _
ElmBackStage As UIAutomationClient.IUIAutomationElement) As String
'バージョンボタンを取得
Dim ElmVerDlgBtn As IUIAutomationElement
Set ElmVerDlgBtn = uiaFindElement(uiAuto, ElmBackStage, "NetUISimpleButton", Name:=BTN_VERSION)
If ElmVerDlgBtn Is Nothing Then Exit Function
'クリア
glDialogVersion = ""
'フック開始
Dim hHook As LongPtr
hHook = fHook_On()
'バージョンボタン押下
Call uiaElmClick(ElmVerDlgBtn)
'ダイアログが表示されてフックプロシージャで処理されるまで待つ
Dim i As Long
For i = 1 To 100 '多くて5回くらいでダイアログが表示されるっぽい
If glDialogVersion <> "" Then Exit For
' Debug.Print "d:" & d
DoEvents '※Sleep不要
Next
'フック終了
Call UnhookWindowsHookEx(hHook)
'取得できてなかったら終了
If glDialogVersion = "" Then Exit Function
GetVersionDetail = glDialogVersion
End Function
Private Function fHook_On() As LongPtr
Dim hWnd As LongPtr
hWnd = Application.hWnd
Dim hInstance As LongPtr
hInstance = Application.HinstancePtr
Dim hThread As Long
hThread = GetWindowThreadProcessId(hWnd, ByVal 0&)
Const WH_CBT = 5 'ウィンドウの生成・破棄・リサイズ・移動 等
fHook_On = SetWindowsHookEx(WH_CBT, AddressOf HookProc, hInstance, hThread)
End Function
Private Function fWinHnd_ClassName(hWnd As LongPtr) As String
Dim Class As String
Class = String$(255, 0)
Dim Cnt As Long
Cnt = GetClassName(hWnd, Class, Len(Class))
If Cnt = 0 Then Exit Function
fWinHnd_ClassName = Left$(Class, InStr(1, Class, vbNullChar) - 1)
End Function
Private Function fWinHnd_Close(hWnd As LongPtr)
Const WM_CLOSE = &H10
Call PostMessage(hWnd, WM_CLOSE, 0, CLng(0))
End Function
Private Function HookProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
On Error GoTo ErrorHandler
Dim HCBT_Val As E_WinAPI_SetWindowsHookEx_HCBT
HCBT_Val = nCode
Dim hWnd As LongPtr
hWnd = wParam
'ダイアログウィンドウの場合
Dim ClassName As String
ClassName = fWinHnd_ClassName(hWnd)
If ClassName = "NUIDialog" Then
Select Case HCBT_Val
Case E_WinAPI_SetWindowsHookEx_HCBT.HCBT_CreateWnd
' Debug.Print "★HCBT_CreateWnd"
Case E_WinAPI_SetWindowsHookEx_HCBT.HCBT_Activate
' Debug.Print "★HCBT_Activate"
Call fWinHnd_Close(hWnd)
Case E_WinAPI_SetWindowsHookEx_HCBT.HCBT_SetFocus
' Debug.Print "★HCBT_SetFocus"
'※ここでもまだ要素0なので、閉じる時に取得する
' Call fWinHnd_Close(hWnd) '※365環境ではSetFocusが発生しないのでActivateで処理
Case E_WinAPI_SetWindowsHookEx_HCBT.HCBT_DestroyWnd
' Debug.Print "★HCBT_DestroyWnd"
Dim uiAuto As UIAutomationClient.CUIAutomation
Set uiAuto = New UIAutomationClient.CUIAutomation
'ツリー操作用のオブジェクトを取得しておく
Dim treeWalker As IUIAutomationTreeWalker
Set treeWalker = uiAuto.ControlViewWalker
'ウィンドウハンドルからUIAに変換
Dim ElmWin As UIAutomationClient.IUIAutomationElement
Set ElmWin = uiAuto.ElementFromHandle(ByVal hWnd)
If ElmWin Is Nothing = False Then
'MicrosoftR ExcelR 2016 MSO (バージョン 2407 ビルド 16.0.17830.20166) 64 ビット
Dim Ver As String
Ver = GetVersionLabel(uiAuto, ElmWin, "Microsoft")
If Ver <> "" Then
glDialogVersion = Ver
' Debug.Print Ver
End If
End If
End Select
End If
ErrorHandler:
On Error Resume Next
HookProc = CallNextHookEx(0, nCode, wParam, lParam)
On Error GoTo 0
End Function