[VBA] UIAutomation の階層を列挙する

UserForm1.frm

Option Explicit
'
' Excel VBA 向けのサンプル
' 下記の参照設定が必要です
'   Microsoft Scripting Runtime   (scrrun.dll)
'   UIAutomationClient            (UIAutomationCore.dll)
'
' UserForm1 に、下記のコントロールが必要です
'   CommandButton1
'   OptionButton1 , OptionButton2 , OptionButton3
'   TreeView1
'   ListView1
'
Private m_UA As CUIAutomation8
Private m_Root As IUIAutomationElement9
Private m_walker As IUIAutomationTreeWalker

Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As LongPtr, ByRef lpdwProcessId As Long) As Long

Private m_dicControls As Scripting.Dictionary
Private m_dicWalker As Scripting.Dictionary
Private m_expanding As Boolean

Private Sub UserForm_Initialize()
    InitializeDictionary
    m_expanding = False

    Set m_UA = New CUIAutomation8

    OptionButton1.Caption = "Raw"
    OptionButton2.Caption = "Control"
    OptionButton3.Caption = "Content"

    CommandButton1.Caption = "Refresh"

    TreeView1.Nodes.Clear
    TreeView1.LabelEdit = tvwManual
    TreeView1.Indentation = 14
    TreeView1.LineStyle = tvwRootLines
    TreeView1.Style = tvwTreelinesPlusMinusText
    TreeView1.SingleSel = True

    ListView1.LabelEdit = lvwManual
    ListView1.View = lvwReport
    ListView1.FullRowSelect = True
    ListView1.Gridlines = True
    ListView1.ColumnHeaders.Add , "Property", "Property"
    ListView1.ColumnHeaders.Add , "Type", "Type"
    ListView1.ColumnHeaders.Add , "Value", "Value"
End Sub

Private Sub OptionButton1_Click()
    InitializeTreeWalker True
End Sub
Private Sub OptionButton2_Click()
    InitializeTreeWalker True
End Sub
Private Sub OptionButton3_Click()
    InitializeTreeWalker True
End Sub

Private Sub CommandButton1_Click()
    Application.Cursor = xlWait
    Select Case True
        Case OptionButton1.Value
        Case OptionButton2.Value
        Case OptionButton3.Value
        Case Else
            OptionButton1.Value = True
    End Select
    InitializeElementTree
    Application.Cursor = xlDefault
End Sub

Private Sub TreeView1_Expand(ByVal Node As MSComctlLib.Node)
    If Not m_expanding And Not Node.Child Is Nothing Then
        m_expanding = True

        Dim pCur As XlMousePointer
        pCur = Application.Cursor
        Application.Cursor = xlWait
        If Node.Child.Text = "<dummy>" Then
            TreeView1.Nodes.Remove Node.Child.Index
            If m_dicWalker.Exists(Node) Then
                Dim oNode As Node
                Dim oElement As IUIAutomationElement9
                Set oElement = m_walker.GetFirstChildElement(m_dicWalker(Node))
                Do Until oElement Is Nothing
                    Set oNode = TreeView1.Nodes.Add(Node.Key, tvwChild, GetKey(oElement), GetCaption(oElement))
                    m_dicWalker.Add oNode, oElement
                    If Not m_walker.GetFirstChildElement(oElement) Is Nothing Then
                        TreeView1.Nodes.Add oNode.Key, tvwChild, oNode.Key & "+", "<dummy>"
                    End If
                    oNode.Expanded = False
                    Set oElement = m_walker.GetNextSiblingElement(oElement)
                Loop
            End If
        End If
        m_expanding = False
        Application.Cursor = pCur
        DoEvents
    End If
End Sub

Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
    ViewProperty Node
End Sub

Private Sub ViewProperty(ByVal Node As MSComctlLib.Node)
    ListView1.ListItems.Clear
    If Node Is Nothing Then
        Exit Sub
    End If
    If Not m_dicWalker.Exists(Node) Then
        Exit Sub
    End If

    Dim s As String
    Dim eNode As IUIAutomationElement9
    Set eNode = m_dicWalker(Node)

    Dim lvi As MSComctlLib.ListItem
    Set lvi = ListView1.ListItems.Add(, "RuntimeId", "RuntimeId")
    lvi.ListSubItems.Add , "Type", "Long()"
    lvi.ListSubItems.Add , "Value", GetKey(eNode)
    Set lvi = ListView1.ListItems.Add(, "AutomationId", "AutomationId")
    lvi.ListSubItems.Add , "Type", "String"
    lvi.ListSubItems.Add , "Value", eNode.CurrentAutomationId
    Set lvi = ListView1.ListItems.Add(, "ClassName", "ClassName")
    lvi.ListSubItems.Add , "Type", "String"
    lvi.ListSubItems.Add , "Value", eNode.CurrentClassName
    Set lvi = ListView1.ListItems.Add(, "ControlType", "ControlType")
    lvi.ListSubItems.Add , "Type", "Long"
    s = "(0x" & Hex(eNode.CurrentControlType) & ")"
    If m_dicControls.Exists(eNode.CurrentControlType) Then
        s = m_dicControls(eNode.CurrentControlType) & s
    End If
    lvi.ListSubItems.Add , "Value", s
    Set lvi = ListView1.ListItems.Add(, "FrameworkId", "FrameworkId")
    lvi.ListSubItems.Add , "Type", "FrameworkId"
    lvi.ListSubItems.Add , "Value", eNode.CurrentFrameworkId
    Set lvi = ListView1.ListItems.Add(, "ProcessId", "ProcessId")
    lvi.ListSubItems.Add , "Type", "Long"
    lvi.ListSubItems.Add , "Value", eNode.CurrentProcessId
    Set lvi = ListView1.ListItems.Add(, "hWnd", "hWnd")
    lvi.ListSubItems.Add , "Type", "Long"
    'lvi.ListSubItems.Add , "Value", eNode.CurrentNativeWindowHandle
    lvi.ListSubItems.Add , "Value", eNode.GetCurrentPropertyValue(UIA_NativeWindowHandlePropertyId)
    Set lvi = ListView1.ListItems.Add(, "Name", "Name")
    lvi.ListSubItems.Add , "Type", "String"
    lvi.ListSubItems.Add , "Value", eNode.CurrentName
    Set lvi = ListView1.ListItems.Add(, "ProviderDescription", "ProviderDescription")
    lvi.ListSubItems.Add , "Type", "String"
    lvi.ListSubItems.Add , "Value", eNode.CurrentProviderDescription
    Set lvi = ListView1.ListItems.Add(, "BoundingRectangle", "BoundingRectangle")
    lvi.ListSubItems.Add , "Type", "RECT"
    With eNode.CurrentBoundingRectangle
        s = "(" & CStr(.Left) & ", " & CStr(.Top)
        s = s & ")-(" & CStr(.Right) & ", " & CStr(.bottom) & ")"
    End With
    lvi.ListSubItems.Add , "Value", s
    Set lvi = ListView1.ListItems.Add(, "IsOffscreen", "IsOffscreen")
    lvi.ListSubItems.Add , "Type", "Boolean"
    lvi.ListSubItems.Add , "Value", IIf(eNode.CurrentIsOffscreen = 0&, "False", "True")
    Set lvi = ListView1.ListItems.Add(, "IsEnabled", "IsEnabled")
    lvi.ListSubItems.Add , "Type", "Boolean"
    lvi.ListSubItems.Add , "Value", IIf(eNode.CurrentIsEnabled = 0&, "False", "True")
    Set lvi = ListView1.ListItems.Add(, "IsKeyboardFocusable", "IsKeyboardFocusable")
    lvi.ListSubItems.Add , "Type", "Boolean"
    lvi.ListSubItems.Add , "Value", IIf(eNode.CurrentIsKeyboardFocusable = 0&, "False", "True")
    Set lvi = ListView1.ListItems.Add(, "IsInvokePatternAvailable", "InvokePattern")
    lvi.ListSubItems.Add , "Type", "IsAvailable"
    lvi.ListSubItems.Add , "Value", IIf(eNode.GetCurrentPropertyValue(UIA_IsInvokePatternAvailablePropertyId) = 0&, "False", "True")
    Set lvi = ListView1.ListItems.Add(, "IsLegacyIAccessiblePatternAvailable", "LegacyIAccessiblePattern")
    lvi.ListSubItems.Add , "Type", "IsAvailable"
    lvi.ListSubItems.Add , "Value", IIf(eNode.GetCurrentPropertyValue(UIA_IsLegacyIAccessiblePatternAvailablePropertyId) = 0&, "False", "True")
    Set lvi = ListView1.ListItems.Add(, "IsValuePatternAvailable", "ValuePattern")
    lvi.ListSubItems.Add , "Type", "IsAvailable"
    lvi.ListSubItems.Add , "Value", IIf(eNode.GetCurrentPropertyValue(UIA_IsValuePatternAvailablePropertyId) = 0&, "False", "True")
End Sub

Private Sub InitializeTreeWalker(Optional force As Boolean = False)
    If m_walker Is Nothing Or force Then
        Dim pid As Long
        GetWindowThreadProcessId Application.hWnd, pid
   
        Dim cndTree As IUIAutomationCondition
        If OptionButton2.Value Then
            Set cndTree = m_UA.ControlViewCondition
        ElseIf OptionButton3.Value Then
            Set cndTree = m_UA.ContentViewCondition
        Else
            Set cndTree = m_UA.RawViewCondition
        End If
        Set cndTree = m_UA.CreateAndCondition(cndTree, _
            m_UA.CreateNotCondition( _
            m_UA.CreatePropertyCondition( _
            UIA_ProcessIdPropertyId, pid)))

        Set m_walker = m_UA.CreateTreeWalker(cndTree)
        Set m_dicWalker = New Dictionary
    End If
End Sub

Private Sub InitializeElementTree()
    InitializeTreeWalker
    m_dicWalker.RemoveAll
    TreeView1.Nodes.Clear
    ListView1.ListItems.Clear
    If m_Root Is Nothing Then
        Set m_Root = m_UA.GetRootElement()
    End If
    CreateTopNodes
End Sub

Private Function GetKey(ByVal e As IUIAutomationElement) As String
    Dim s As String, rid As Variant
    s = ""
    For Each rid In e.GetRuntimeId()
        s = s & "," & Hex(rid)
    Next
    s = "[" & Mid(s, 2) & "]"
    GetKey = s
End Function

Private Function GetCaption(ByVal e As IUIAutomationElement) As String
    Dim sCtrl As String
    If m_dicControls.Exists(e.CurrentControlType) Then
        sCtrl = m_dicControls(e.CurrentControlType)
    Else
        sCtrl = "0x" & Hex(e.CurrentControlType)
    End If
    GetCaption = sCtrl & "|" & e.CurrentAutomationId & "|" & e.CurrentClassName & "|""" & e.CurrentName & """"
End Function

Private Sub CreateTopNodes()
    Dim nRoot As Node
    Set nRoot = TreeView1.Nodes.Add(, tvwFirst, GetKey(m_Root), GetCaption(m_Root))
    m_dicWalker.Add nRoot, m_Root

    If Not m_walker.GetFirstChildElement(m_Root) Is Nothing Then
        Dim nDummy As Node
        Set nDummy = TreeView1.Nodes.Add(nRoot.Key, TreeRelationshipConstants.tvwChild, nRoot.Key & "+", "<dummy>")
        nRoot.Expanded = False
    End If
    ViewProperty nRoot
End Sub

Private Sub CreateChildrenNode(ByVal Node As MSComctlLib.Node)
    Dim nRoot As Node
    Set nRoot = TreeView1.Nodes.Add("", tvwFirst, GetKey(m_Root), GetCaption(m_Root))
    Set nRoot.Tag = m_Root

    If Not m_walker.GetFirstChildElement(e) Is Nothing Then
        Dim nDummy As Node
        Set nDummy = TreeView1.Nodes.Add(nRoot.Key, TreeRelationshipConstants.tvwChild, nRoot.Key & "+", "<dummy>")
        nRoot.Expanded = False
    End If
End Sub

Private Sub InitializeDictionary()
    'UIA_ControlTypeIds
    Set m_dicControls = New Scripting.Dictionary
    m_dicControls.Add 50000, "Button"
    m_dicControls.Add 50001, "Calendar"
    m_dicControls.Add 50002, "CheckBox"
    m_dicControls.Add 50003, "ComboBox"
    m_dicControls.Add 50004, "Edit"
    m_dicControls.Add 50005, "Hyperlink"
    m_dicControls.Add 50006, "Image"
    m_dicControls.Add 50007, "ListItem"
    m_dicControls.Add 50008, "List"
    m_dicControls.Add 50009, "Menu"
    m_dicControls.Add 50010, "MenuBar"
    m_dicControls.Add 50011, "MenuItem"
    m_dicControls.Add 50012, "ProgressBar"
    m_dicControls.Add 50013, "RadioButton"
    m_dicControls.Add 50014, "ScrollBar"
    m_dicControls.Add 50015, "Slider"
    m_dicControls.Add 50016, "Spinner"
    m_dicControls.Add 50017, "StatusBar"
    m_dicControls.Add 50018, "Tab"
    m_dicControls.Add 50019, "TabItem"
    m_dicControls.Add 50020, "Text"
    m_dicControls.Add 50021, "ToolBar"
    m_dicControls.Add 50022, "ToolTip"
    m_dicControls.Add 50023, "Tree"
    m_dicControls.Add 50024, "TreeItem"
    m_dicControls.Add 50025, "Custom"
    m_dicControls.Add 50026, "Group"
    m_dicControls.Add 50027, "Thumb"
    m_dicControls.Add 50028, "DataGrid"
    m_dicControls.Add 50029, "DataItem"
    m_dicControls.Add 50030, "Document"
    m_dicControls.Add 50031, "SplitButton"
    m_dicControls.Add 50032, "Window"
    m_dicControls.Add 50033, "Pane"
    m_dicControls.Add 50034, "Header"
    m_dicControls.Add 50035, "HeaderItem"
    m_dicControls.Add 50036, "Table"
    m_dicControls.Add 50037, "TitleBar"
    m_dicControls.Add 50038, "Separator"
    m_dicControls.Add 50039, "SemanticZoom"
    m_dicControls.Add 50040, "AppBar"
End Sub