ホーム > ライブラリ > UIAutomation > Officeのバージョン(エディション)取得

ライブラリ

Officeのバージョン(エディション)取得

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

UIAutomation   2024/08/28   shono

この記事へのコメント

コメントを送る

 
※ メールは公開されません
Loading...
 画像の文字を入力してください