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 "
