furyutei · September 3, 2024 12:25
diff --git a/0.README.md b/0.README.md
diff --git a/Mod_GetVersion_by_UIAutomation.vba b/Mod_GetVersion_by_UIAutomation.vba
 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 = "アカウント|Account"
 Private Const BTN_OTHER   As String = "その他のオプション|More options"
 Private Const BTN_VERSION As String = "Excel のバージョン情報|Word のバージョン情報|About Excel|About Word"

 Public Function GetVersion_by_UIAutomation(Optional ByRef DetailVersion As String = "") As String
    
    DetailVersion = "" '引数の戻り値をクリア
    
    'アプリのウィンドウハンドルを取得
    Dim hWnd As LongPtr
    hWnd = App_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
    On Error Resume Next
    Set ElmRbn = uiAuto.ElementFromIAccessible(IAccBar, 0)
    '[備忘] 既に[ファイル]タブを開いている場合にはオートメーションエラーになってしまう
    On Error GoTo 0
    
    '最上位の要素を取得
    Dim ElmWin  As IUIAutomationElement
 '    Dim ElmTmp  As IUIAutomationElement
 ''    Set ElmTmp = ElmRbn
 '    Set ElmTmp = uiAuto.ElementFromHandle(ByVal hWnd) ' アプリのウィンドウハンドルを元に取得（リボンが取得できない場合があるため）
 '    Do
 '        If ElmTmp.CurrentClassName = "#32769" Then
 '            ' [備忘] CurrentClassNameが#32769(デスクトップ)になるまで遡ってしまうと、複数のOfficeアプリが存在した場合に誤動作してしまう
 '            Exit Do
 '        End If
 '        Set ElmWin = ElmTmp
 '        Set ElmTmp = treeWalker.GetParentElement(ElmTmp)
 '        If ElmTmp Is Nothing Then Exit Do
 '    Loop
    Set ElmWin = uiAuto.ElementFromHandle(ByVal hWnd) ' アプリのウィンドウハンドルを元に取得（リボンが取得できない場合があるため）
    
    If Not ElmRbn Is Nothing Then
        'リボンの[ファイル]タブを取得
        Dim ElmTab_File As IUIAutomationElement
 '        Set ElmTab_File = uiaFindElement(uiAuto, ElmWin, "NetUIRibbonTab", "FileTabButton")
        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
    End If
    
    'ファイルバーの要素を取得
    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, _
                                Optional NameDelimiter As String = "|") As IUIAutomationElement
    
    '検索条件を設定
    Dim Conditions(1)   As IUIAutomationCondition
    Set Conditions(0) = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, ClassName)
    
    If AutomationId <> "" Then
        Set Conditions(1) = uiAuto.CreatePropertyCondition(UIA_AutomationIdPropertyId, AutomationId)
    Else
        Dim OrNameArray As Variant: OrNameArray = VBA.Split(Name, NameDelimiter)
        Dim OrNameCount As Long: OrNameCount = UBound(OrNameArray) - LBound(OrNameArray) + 1
        Dim OrConditions() As IUIAutomationCondition
        ReDim OrConditions(0 To OrNameCount - 1)
        Dim Index As Long
        Dim WorkName As Variant
        For Each WorkName In OrNameArray
            Set OrConditions(Index) = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, WorkName)
            Index = Index + 1
        Next
        Set Conditions(1) = uiAuto.CreateOrConditionFromNativeArray(OrConditions(0), OrNameCount)
    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 = App_hWnd
    
    Dim hInstance   As LongPtr
 '    hInstance = Application.HinstancePtr
    On Error Resume Next
    hInstance = CallByName(Application, "HinstancePtr", VbGet) ' [備忘] WordではApplication.HinstancePtrは未定義
    If Err.Number <> 0 Then hInstance = 0
    On Error GoTo 0
    
    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


 Private Property Get App_hWnd(Optional TargetApplication) As LongPtr
    Dim hWnd As LongPtr
    If IsEmpty(TargetApplication) Then Set TargetApplication = Application
    On Error Resume Next
    hWnd = CallByName(TargetApplication, "hWnd", VbGet)
    If Err.Number <> 0 Then hWnd = Application.Windows(1).hWnd ' [備忘] WordではApplication.Hwnd未定義
    On Error GoTo 0
    App_hWnd = hWnd
 End Property
diff --git a/Mod_Test.vba b/Mod_Test.vba
 Option Explicit

 Sub TestVersion()
    Dim Version As String
    Dim DetailVersion As String
    Version = GetVersion_by_UIAutomation(DetailVersion)
    Debug.Print "[Version] " & Version
    Debug.Print " <Detail> " & DetailVersion
 End Sub
	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 = "アカウント\|Account"
	Private Const BTN_OTHER As String = "その他のオプション\|More options"
	Private Const BTN_VERSION As String = "Excel のバージョン情報\|Word のバージョン情報\|About Excel\|About Word"

	Public Function GetVersion_by_UIAutomation(Optional ByRef DetailVersion As String = "") As String

	DetailVersion = "" '引数の戻り値をクリア

	'アプリのウィンドウハンドルを取得
	Dim hWnd As LongPtr
	hWnd = App_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
	On Error Resume Next
	Set ElmRbn = uiAuto.ElementFromIAccessible(IAccBar, 0)
	'[備忘] 既に[ファイル]タブを開いている場合にはオートメーションエラーになってしまう
	On Error GoTo 0

	'最上位の要素を取得
	Dim ElmWin As IUIAutomationElement
	' Dim ElmTmp As IUIAutomationElement
	'' Set ElmTmp = ElmRbn
	' Set ElmTmp = uiAuto.ElementFromHandle(ByVal hWnd) ' アプリのウィンドウハンドルを元に取得（リボンが取得できない場合があるため）
	' Do
	' If ElmTmp.CurrentClassName = "#32769" Then
	' ' [備忘] CurrentClassNameが#32769(デスクトップ)になるまで遡ってしまうと、複数のOfficeアプリが存在した場合に誤動作してしまう
	' Exit Do
	' End If
	' Set ElmWin = ElmTmp
	' Set ElmTmp = treeWalker.GetParentElement(ElmTmp)
	' If ElmTmp Is Nothing Then Exit Do
	' Loop
	Set ElmWin = uiAuto.ElementFromHandle(ByVal hWnd) ' アプリのウィンドウハンドルを元に取得（リボンが取得できない場合があるため）

	If Not ElmRbn Is Nothing Then
	'リボンの[ファイル]タブを取得
	Dim ElmTab_File As IUIAutomationElement
	' Set ElmTab_File = uiaFindElement(uiAuto, ElmWin, "NetUIRibbonTab", "FileTabButton")
	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
	End If

	'ファイルバーの要素を取得
	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, _
	Optional NameDelimiter As String = "\|") As IUIAutomationElement

	'検索条件を設定
	Dim Conditions(1) As IUIAutomationCondition
	Set Conditions(0) = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, ClassName)

	If AutomationId <> "" Then
	Set Conditions(1) = uiAuto.CreatePropertyCondition(UIA_AutomationIdPropertyId, AutomationId)
	Else
	Dim OrNameArray As Variant: OrNameArray = VBA.Split(Name, NameDelimiter)
	Dim OrNameCount As Long: OrNameCount = UBound(OrNameArray) - LBound(OrNameArray) + 1
	Dim OrConditions() As IUIAutomationCondition
	ReDim OrConditions(0 To OrNameCount - 1)
	Dim Index As Long
	Dim WorkName As Variant
	For Each WorkName In OrNameArray
	Set OrConditions(Index) = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, WorkName)
	Index = Index + 1
	Next
	Set Conditions(1) = uiAuto.CreateOrConditionFromNativeArray(OrConditions(0), OrNameCount)
	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 = App_hWnd

	Dim hInstance As LongPtr
	' hInstance = Application.HinstancePtr
	On Error Resume Next
	hInstance = CallByName(Application, "HinstancePtr", VbGet) ' [備忘] WordではApplication.HinstancePtrは未定義
	If Err.Number <> 0 Then hInstance = 0
	On Error GoTo 0

	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


	Private Property Get App_hWnd(Optional TargetApplication) As LongPtr
	Dim hWnd As LongPtr
	If IsEmpty(TargetApplication) Then Set TargetApplication = Application
	On Error Resume Next
	hWnd = CallByName(TargetApplication, "hWnd", VbGet)
	If Err.Number <> 0 Then hWnd = Application.Windows(1).hWnd ' [備忘] WordではApplication.Hwnd未定義
	On Error GoTo 0
	App_hWnd = hWnd
	End Property
	Option Explicit

	Sub TestVersion()
	Dim Version As String
	Dim DetailVersion As String
	Version = GetVersion_by_UIAutomation(DetailVersion)
	Debug.Print "[Version] " & Version
	Debug.Print " <Detail> " & DetailVersion
	End Sub