Office2016以降、VBAでバージョンを取得するのが難しく、
そんな中、UIAutomationを使って取得する方法を模索してみました!!
(当初はレジストリを探索するも、PC環境によってバラバラだったりで挫折し...
Office(Excel)の左上の｢ファイル｣→｢その他オプション｣→｢アカウント｣を表示させ、
表示されているバージョン(エディション)を取得します。
32bit, 64bit どちらでも動く想定です。
参照設定で｢UIAutomation Client｣を選択してください。
(要素の検索条件に一部日本語を使ってます。日本語環境以外の場合は調整してください)
取得例：
Microsoft Office Home and Business 2016
Microsoft Office Home and Business 2019
Microsoft 365 Apps for enterprise
プログラム：※Wordでも動くよう調整ました
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Function GetVersion_by_UIAutomation() As String
'【参照設定】UIAutomationClient
'UIAutomationを生成
Dim uiAuto As UIAutomationClient.CUIAutomation
Set uiAuto = New UIAutomationClient.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, ElmRbn, "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:="アカウント", MaxTry:=1)
If ElmAccount Is Nothing Then
'見つからなかったら、その他オプションから辿って取得する
'[その他]ボタンを探す
Dim ElmOther As IUIAutomationElement
Set ElmOther = uiaFindElement(uiAuto, ElmBar_File, "NetUIStickyButton", Name:="その他のオプション")
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:="アカウント")
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 ElmProduct As IUIAutomationElement
Set ElmProduct = uiaFindElement(uiAuto, ElmWin, "NetUISlabContainer", "GroupOfficeBranding")
'アカウント製品
Set ElmProduct = treeWalker.GetNextSiblingElement(ElmProduct)
Dim ElmDetail As IUIAutomationElement
Set ElmDetail = uiaFindElement(uiAuto, ElmProduct, "NetUIElement", Name:="詳細情報")
If ElmDetail Is Nothing Then
Call MsgBox("アカウントの詳細情報(バージョン)が見つかりませんでした")
GoTo Terminate
End If
'最初の子要素(Officeの製品名)を取得
Dim ElmVersion As IUIAutomationElement
Set ElmVersion = treeWalker.GetFirstChildElement(ElmDetail)
If ElmVersion Is Nothing Then
Call MsgBox("アカウントのバージョンが見つかりませんでした")
GoTo Terminate
End If
'※デバッグ用
' '要素のRECTを取得
' Dim elementRect As tagRECT
' elementRect = ElmBackStage.CurrentBoundingRectangle
' elementRect = ElmDetail.CurrentBoundingRectangle
' elementRect = ElmVersion.CurrentBoundingRectangle
Dim Ver As String
Ver = uiaElmText(ElmVersion)
If Ver = "" Then
Call MsgBox("バージョンのテキストが取得できませんでした")
GoTo Terminate
End If
GetVersion_by_UIAutomation = Ver
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
Call Sleep(50)
Next
If Element Is Nothing Then Exit Function
Set uiaFindElement = Element
End Function