VBA - Accessibility Meta Code

So I had some code to generate an illustrative tree of Excel window handles as a by-product for some code to get a pointer to Excel via its window handle using the Accessibility API. On StackOverflow, a questioner wanted something similar for Word. One can also imagine a future question wanted similar for PowerPoint. Code to reach all those three applications via their windows handles are in the previous post. However, I wanted to share the meta code because yet another use case may turn up in the future.

Option Explicit
Option Private Module

'******************************************************************************************************
'* Windows API function to traverse windows and grab attributes
'******************************************************************************************************
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hwnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

'******************************************************************************************************
'* Windows API function to get IDispatch COM pointer via Accessibility interface
'******************************************************************************************************
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc.dll" ( _
  ByVal hwnd As LongPtr, ByVal dwId As Long, ByRef riid As Any, ByRef ppvObject As Object) As Long

'******************************************************************************************************
'* Entry Points
'******************************************************************************************************
Private Sub TestGetAccessibleOfficeObjects()
    Dim shtExcelReport As Excel.Worksheet
    Set shtExcelReport = ThisWorkbook.Worksheets.Item("Sheet2")
    Dim shtWordReport As Excel.Worksheet
    Set shtWordReport = ThisWorkbook.Worksheets.Item("Sheet3")
    
    Dim shtPowerPointReport As Excel.Worksheet
    Set shtPowerPointReport = ThisWorkbook.Worksheets.Item("Sheet4")
    
    'Dim shtOneNoteReport As Excel.Worksheet
    'Set shtOneNoteReport = ThisWorkbook.Worksheets.Item("Sheet5")
    
    
    GetAccessibleOfficeObjects shtExcelReport, "Excel"
    GetAccessibleOfficeObjects shtWordReport, "Word"
    GetAccessibleOfficeObjects shtPowerPointReport, "PowerPoint"
    'OneNote not accessible GetAccessibleOfficeObjects shtOneNoteReport, "OneNote"

End Sub

'******************************************************************************************************
'******************************************************************************************************
'* Main Controlling code
'******************************************************************************************************
'******************************************************************************************************
Private Function GetAccessibleOfficeObjects(ByVal shOutputSheet As Excel.Worksheet, ByVal sApplication As String)

    Dim sApplicationRootClass As String
    
    sApplicationRootClass = VBA.IIf(sApplication = "Excel", "XLMAIN", VBA.IIf(sApplication = "Word", "OpusApp", "Not yet implemented"))
    sApplicationRootClass = VBA.Switch(sApplication = "Excel", "XLMAIN", sApplication = "Word", "OpusApp", _
                sApplication = "PowerPoint", "PPTFrameClass", sApplication = "OneNote", "Framework::CFrame")
    
    Dim xmlHandlesReport As MSXML2.DOMDocument60
    Set xmlHandlesReport = GetWindows(sApplicationRootClass, True, shOutputSheet)
    
    WriteToSheetStart shOutputSheet, xmlHandlesReport.DocumentElement
    
    QueryInterfaceForAccessibility xmlHandlesReport
    
    UpdateCastableHandles xmlHandlesReport
     
    WriteCodeToGetAppObject xmlHandlesReport, sApplication, sApplicationRootClass
End Function

Private Function WriteCodeToGetAppObject(ByVal xmlHandlesReport As MSXML2.DOMDocument60, _
            ByVal sApplication As String, ByVal sApplicationRootClass As String)

    Dim xmlAppNode As MSXML2.IXMLDOMElement
    Set xmlAppNode = xmlHandlesReport.SelectSingleNode("//*[@obj_Application_Name]")
        
    '******************************************************************************************************
    '* Traverse up the tree to the root node, recording the window class
    '******************************************************************************************************
    Dim dicPathUp As Scripting.Dictionary
    Set dicPathUp = New Scripting.Dictionary
    
    Dim xmlTraverser As MSXML2.IXMLDOMElement
    Set xmlTraverser = xmlAppNode
    
    While Not xmlTraverser Is xmlHandlesReport.DocumentElement
        dicPathUp.Add xmlTraverser.getAttribute("class"), 0
        Set xmlTraverser = xmlTraverser.ParentNode
    Wend
    
    '******************************************************************************************************
    '* Reverse the path
    '******************************************************************************************************
    Dim dicPathDown As Scripting.Dictionary
    Set dicPathDown = New Scripting.Dictionary
    Dim lLoop As Long, lLoop2 As Long
    For lLoop = dicPathUp.Count - 1 To 0 Step -1
        
        dicPathDown.Add dicPathUp.Keys()(lLoop), 0
    Next lLoop
    
    '******************************************************************************************************
    '* Now write the code
    '******************************************************************************************************
    Dim dicCode As Scripting.Dictionary
    Set dicCode = New Scripting.Dictionary
    
    Dim sFuncName As String
    sFuncName = "Get" & sApplication & "AppObjectByIAccessible"
    
    dicCode.Add dicCode.Count, "Private Declare PtrSafe Function AccessibleObjectFromWindow Lib ""oleacc.dll"" ( _"
    dicCode.Add dicCode.Count, "    ByVal hwnd As LongPtr, ByVal dwId As Long, ByRef riid As Any, ByRef ppvObject As Object) As Long" & vbNewLine

    dicCode.Add dicCode.Count, "Private Declare Function FindWindowEx Lib ""user32"" Alias ""FindWindowExA"" _"
    dicCode.Add dicCode.Count, "    (ByVal hWnd1 As Long, ByVal hwnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long" & vbNewLine
    
    dicCode.Add dicCode.Count, "Public Function " & sFuncName & "() As Object"
    dicCode.Add dicCode.Count, "    Dim guid(0 To 3) As Long, acc As Object"
    dicCode.Add dicCode.Count, "    guid(0) = &H20400: guid(1) = &H0: guid(2) = &HC0: guid(3) = &H46000000"
    dicCode.Add dicCode.Count, ""
    dicCode.Add dicCode.Count, "    Dim alHandles(0 to " & dicPathUp.Count & ") As Long"
    
    dicCode.Add dicCode.Count, "    alHandles(0) = FindWindowEx(0, 0, """ & sApplicationRootClass & """, vbNullString)"
    For lLoop = 0 To dicPathDown.Count - 1
        Dim sInputHandle As String
        If lLoop = 0 Then sInputHandle = "lTopHandle" Else sInputHandle = "alHandles(" & lLoop & ")"
        sInputHandle = "alHandles(" & lLoop & ")"
        
        Dim sClass As String
        sClass = dicPathDown.Keys()(lLoop)
        dicCode.Add dicCode.Count, "    alHandles(" & lLoop + 1 & ") = FindWindowEx(" & sInputHandle & ",0,""" & sClass & """,vbNullString) "
    Next
    
    dicCode.Add dicCode.Count, "    If AccessibleObjectFromWindow(alHandles(" & dicPathDown.Count & "), -16&, guid(0), acc) = 0 Then"
    dicCode.Add dicCode.Count, "        Set " & sFuncName & " = acc.Application"
    dicCode.Add dicCode.Count, "    End If"
    dicCode.Add dicCode.Count, "End Function " & vbNewLine
    dicCode.Add dicCode.Count, "Sub Test" & sFuncName
    dicCode.Add dicCode.Count, "    Dim obj As Object"
    dicCode.Add dicCode.Count, "    Set obj = " & sFuncName & "()"
    dicCode.Add dicCode.Count, "    Debug.Print obj.Name"
    dicCode.Add dicCode.Count, "End Sub "
    
    Debug.Print VBA.Join(dicCode.Items, vbNewLine)
End Function

'******************************************************************************************************
'* Global functions
'******************************************************************************************************
Public Function PadHex(ByVal l32Bit As Long) As String
    PadHex = Right$("00000000" & Hex$(l32Bit), 8)
End Function

'******************************************************************************************************
'******************************************************************************************************
'* Windows Recursion Code
'******************************************************************************************************
'******************************************************************************************************
Private Function GetWindows(ByVal sRootClass As String, ByVal bWriteToSheet As Boolean, ByVal ws As Excel.Worksheet) As MSXML2.DOMDocument60
    Debug.Assert Not ws Is Nothing
    
    Dim xmlDocument As MSXML2.DOMDocument60
    Set xmlDocument = New MSXML2.DOMDocument60
    xmlDocument.LoadXML ""
    Debug.Assert xmlDocument.parseError = 0
    
    Dim xmlRoot As MSXML2.IXMLDOMElement
    Set xmlRoot = xmlDocument.DocumentElement
     
    Dim hwnd As Long
    hwnd = FindWindowEx(0, 0, sRootClass, vbNullString)
    
    AdornAttributes hwnd, xmlRoot
    GetWinInfo hwnd&, xmlRoot
    
    Set GetWindows = xmlDocument
End Function

Private Function AdornAttributes(ByVal hwnd As Long, xmlEle As MSXML2.IXMLDOMElement)
    If Not xmlEle Is Nothing Then
        Call xmlEle.setAttribute("hWndHex", PadHex(hwnd))
        Call xmlEle.setAttribute("hWnd", hwnd)
        Call xmlEle.setAttribute("title", GetTitle(hwnd))
        Call xmlEle.setAttribute("class", GetClassName2(hwnd))
    End If
End Function

Private Sub GetWinInfo(hParent As Long, ByVal xmlEle As MSXML2.IXMLDOMElement)
    '* Sub to recursively obtain window handles, classes and text
    '* given a parent window to search
    '* Based on code written by Mark Rowlinson - www.markrowlinson.co.uk - The Programming Emporium
    '* modified to write to Xml document instead of a worksheet
    Dim hwnd As Long
    
    hwnd = FindWindowEx(hParent, 0&, vbNullString, vbNullString)
    While hwnd <> 0
        
        Dim xmlChild As MSXML2.IXMLDOMElement
        Set xmlChild = xmlEle.OwnerDocument.createElement("Window")
        xmlEle.appendChild xmlChild
        
        AdornAttributes hwnd, xmlChild
        
        GetWinInfo hwnd, xmlChild
        
        hwnd = FindWindowEx(hParent, hwnd, vbNullString, vbNullString)
    Wend
End Sub

Private Function GetTitle(ByVal hwnd As Long, Optional ByVal bReportNa As Boolean) As String
    Dim lngRet As Long
    Dim strText As String
    
    strText = String$(100, Chr$(0))
    lngRet = GetWindowText(hwnd, strText, 100)
    If lngRet > 0 Then
        GetTitle = Left$(strText, lngRet)
    Else
        If bReportNa Then
            GetTitle = "N/A"
        End If
    End If
End Function

Private Function GetClassName2(ByVal hwnd As Long)
    Dim lngRet As Long
    Dim strText As String
    
    strText = String$(100, Chr$(0))
    lngRet = GetClassName(hwnd, strText, 100)
    GetClassName2 = Left$(strText, lngRet)
End Function

'******************************************************************************************************
'******************************************************************************************************
'* Write Report To Worksheet code
'******************************************************************************************************
'******************************************************************************************************
Private Function WriteToSheetStart(ByVal ws As Excel.Worksheet, ByVal xmlEle As MSXML2.IXMLDOMElement)
    ws.Cells.Clear
    ws.Activate
    ws.Cells(1, 1).Activate
    WriteToSheet ws, 1, 1, xmlEle
End Function

Private Function WriteToSheet(ByVal ws As Excel.Worksheet, ByVal lRow As Long, ByVal lColumn As Long, ByVal xmlEle As MSXML2.IXMLDOMElement) As Long
    
    Dim hwnd As Long
    hwnd = xmlEle.getAttribute("hWnd")
    
    
    Call xmlEle.setAttribute("rangeAnchor", "'" & ws.Name & "'!" & ws.Cells(lRow, lColumn).AddressLocal)
    Dim rngTest As Excel.Range
    Set rngTest = Application.Range(xmlEle.getAttribute("rangeAnchor"))
    Debug.Assert Not rngTest Is Nothing
    
    
    ws.Cells(lRow, lColumn).Formula = "'" & PadHex(hwnd) & " (" & CStr(hwnd) & ")"
    ws.Cells(lRow, lColumn + 1).Value = xmlEle.getAttribute("title")
    ws.Cells(lRow, lColumn + 2).Value = xmlEle.getAttribute("class")
    
    If xmlEle.ChildNodes.Length > 0 Then
    
        Dim xmlChildWindows As MSXML2.IXMLDOMNodeList
        Set xmlChildWindows = xmlEle.ChildNodes
        
        Dim lLength As Long
        lLength = xmlEle.ChildNodes.Length
        
        Dim lLoop As Long
        For lLoop = 0 To lLength - 1
            
            Dim xmlChild As MSXML2.IXMLDOMElement
            Set xmlChild = xmlEle.ChildNodes.Item(lLoop)
    
            lRow = WriteToSheet(ws, lRow + 1, lColumn + 3, xmlChild)
            
        Next lLoop
    End If
    
    WriteToSheet = lRow
End Function

Private Sub UpdateCastableHandles(ByVal xmlHandlesReport As MSXML2.DOMDocument60)
    Dim rngCastable As Excel.Range
    
    Dim xmlCastable As MSXML2.IXMLDOMNodeList
    Set xmlCastable = xmlHandlesReport.SelectNodes("//*[@ComInterface]")
    Debug.Assert xmlCastable.Length > 0
    
    Dim xmlCastableLoop As MSXML2.IXMLDOMElement
    For Each xmlCastableLoop In xmlCastable
        Set rngCastable = Application.Range(xmlCastableLoop.getAttribute("rangeAnchor"))
        rngCastable.Resize(1, 3).Interior.Color = rgbYellow
        
        rngCastable.EntireColumn.AutoFit
        rngCastable.Offset(0, 1).EntireColumn.AutoFit
        rngCastable.Offset(0, 2).EntireColumn.AutoFit
        
'        Dim rngAutoFitLoop As Excel.Range
'        For Each rngAutoFitLoop In rngCastable.Cells
'            rngAutoFitLoop.EntireColumn.AutoFit
'        Next
        
        rngCastable.AddComment
        rngCastable.Comment.Visible = True
        rngCastable.Comment.Text Text:=xmlCastableLoop.getAttribute("ComInterface")
        
        Dim shp As Shape
        Set shp = rngCastable.Comment.Shape
        
        shp.ScaleWidth 1.07, msoFalse, msoScaleFromTopLeft
        shp.ScaleHeight 0.29, msoFalse, msoScaleFromTopLeft
        shp.IncrementTop -20
        
    Next
    
    Dim xmlApp As MSXML2.IXMLDOMElement
    Set xmlApp = xmlHandlesReport.SelectSingleNode("//*[@obj_Application_Name]")
    
    Debug.Assert Not xmlApp Is Nothing

    Dim rngApp As Excel.Range
    Set rngApp = Application.Range(xmlApp.getAttribute("rangeAnchor"))
    rngApp.Resize(1, 3).Interior.Color = rgbLightGreen
    Debug.Assert Not rngApp Is Nothing
End Sub

'******************************************************************************************************
'******************************************************************************************************
'* Accessibility QueryInterface code
'******************************************************************************************************
'******************************************************************************************************
Private Sub QueryInterfaceForAccessibility(ByVal xmlHandlesReport As MSXML2.DOMDocument60)

    Dim dicHandles As Scripting.Dictionary
    Set dicHandles = AllHandles(xmlHandlesReport.DocumentElement)

    Dim guid(0 To 3) As Long, acc As Object
    guid(0) = &H20400
    guid(1) = &H0
    guid(2) = &HC0
    guid(3) = &H46000000
    
    Dim vHandleLoop As Variant
    For Each vHandleLoop In dicHandles.Keys
        
        Dim xmlNode As MSXML2.IXMLDOMElement
        Set xmlNode = xmlHandlesReport.SelectSingleNode("//Window[@hWnd='" & vHandleLoop & "']")
        
        If Not xmlNode Is Nothing Then
        
            Set acc = Nothing
            
            DoEvents
            Dim lReturnIDisp As Long
            lReturnIDisp = AccessibleObjectFromWindow(vHandleLoop, -16&, guid(0), acc)
            DoEvents
    
            If lReturnIDisp = 0 Then
                Call xmlNode.setAttribute("ComInterface", TypeName(acc))
                
                'Debug.Print PadHex(vHandleLoop), TypeName(acc)
                
                Dim sAppName As String
                sAppName = ""
                
                Dim objApp As Object
                Set objApp = Nothing
                On Error Resume Next
                sAppName = acc.Application.Name
                On Error GoTo 0
                If Len(sAppName) > 0 Then
                    Call xmlNode.setAttribute("obj_Application_Name", sAppName)
                End If
            End If
           
        End If
        Set acc = Nothing
    Next

End Sub

Private Function AllHandles(ByVal xmlEle As MSXML2.IXMLDOMElement) As Scripting.Dictionary
    
    Dim dicHandles As Scripting.Dictionary
    Set dicHandles = New Scripting.Dictionary

    Dim xmlHandlesList As MSXML2.IXMLDOMNodeList
    Set xmlHandlesList = xmlEle.SelectNodes("//*[@hWnd]")

    Dim vLoop As MSXML2.IXMLDOMElement
    For Each vLoop In xmlHandlesList
        dicHandles.Add CLng(vLoop.getAttribute("hWnd")), 0
    Next

    Set AllHandles = dicHandles
End Function