So I blogged about some interesting code some time ago that found all running instances of Excel without using the Running Object Table. I wanted to return to how it worked and I now I have. The code works by asking for an IAccessible interface for a given window handle. I found this curious and I wanted to know what else co-operates to supply a COM interface that is scriptable from Exel VBA. So I wrote some code. Here is the output ...
Handle | TypeName | WindowTitle | WindowClass | Scriptable | Notes |
---|---|---|---|---|---|
0018095C | IAccessible | Status Bar | MsoCommandBar | Status Bar | |
003400F0 | IAccessible | Ribbon | MsoCommandBar | Ribbon | |
00130E1A | ITextDocument2 | Calibri | RICHEDIT60W | Font Selector? | |
00140D90 | ITextDocument2 | 11 | RICHEDIT60W | Font size selector? | |
000E0F54 | ITextDocument2 | General | RICHEDIT60W | Format selector? | |
000E034C | Window | Book2 | EXCEL7 | True | A window on a workbook |
So only the Window handle definitely gives a scriptable object, other elements of the GUI require further investigation if worth it. Remember, IAccessible is for users with impaired ability, and it is a feature a good software developer citizen should ship.
Here is the code
Option Explicit
'* Tools->References
'Scripting Microsoft Scripting Runtime C:\Windows\SysWOW64\scrrun.dll
'MSScriptControl Microsoft Script Control 1.0 C:\Windows\SysWOW64\msscript.ocx
'MSXML2 Microsoft XML, v6.0 C:\Windows\SysWOW64\msxml6.dll
Private Type GUID
lData1 As Long
iData2 As Integer
iData3 As Integer
aBData4(0 To 7) As Byte
End Type
Private Const mlE_FAIL As Long = &H80004005
Private Const mlNATIVE_OBJECT_MODEL As Long = &HFFFFFFF0 'OBJID_NATIVEOM
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc.dll" ( _
ByVal hWnd As LongPtr, _
ByVal dwId As Long, _
ByRef riid As Any, _
ByRef ppvObject As IAccessible) As Long
Private Declare PtrSafe Function FindWindowExA Lib "user32.dll" ( _
ByVal hwndParent As LongPtr, _
ByVal hwndChildAfter As LongPtr, _
ByVal lpszClass As String, _
ByVal lpszWindow As String) As Long
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
Private Function GetAccessibleExcelObjects() As Scripting.Dictionary
Dim dicHandles As Scripting.Dictionary
Set dicHandles = GetWindows("XLMAIN", True)
Dim itf As stdole.IUnknown
Dim obj As Object
Dim hWnd As Long
Dim QI_IIDispatch As GUID
Dim QI_IIUnknown As GUID
SetIDispatch QI_IIDispatch
SetIUnknown QI_IIUnknown
Dim dicAccessibleExcelObjects As Scripting.Dictionary
Set dicAccessibleExcelObjects = New Scripting.Dictionary
Dim vHandleLoop As Variant
For Each vHandleLoop In dicHandles.Keys
Set itf = Nothing
Set obj = Nothing
On Error GoTo 0
hWnd = vHandleLoop
Dim lReturnIUnk As Long: lReturnIUnk = mlE_FAIL
Dim lReturnIDisp As Long: lReturnIDisp = mlE_FAIL
'On Error Resume Next
DoEvents
lReturnIUnk = AccessibleObjectFromWindow(hWnd, mlNATIVE_OBJECT_MODEL, QI_IIUnknown, itf)
DoEvents
lReturnIDisp = AccessibleObjectFromWindow(hWnd, mlNATIVE_OBJECT_MODEL, QI_IIDispatch, obj)
DoEvents
On Error GoTo 0
If lReturnIUnk = 0 Then
Debug.Print PadHex(hWnd), TypeName(itf)
dicAccessibleExcelObjects.Add hWnd, itf
ElseIf lReturnIDisp = 0 Then
Debug.Print PadHex(hWnd), TypeName(obj)
dicAccessibleExcelObjects.Add hWnd, obj
Else
End If
Set obj = Nothing
Next
Set GetAccessibleExcelObjects = dicAccessibleExcelObjects
End Function
Private Function GetWindows(ByVal sRootClass As String, ByVal bWriteToSheet As Boolean) As Scripting.Dictionary
Dim objRoot As Object
Set objRoot = SC.Run("JSON_parse", "{}")
Dim hWnd As Long
hWnd = FindWindowExA(0, hWnd, sRootClass, vbNullString)
AdornAttributes objRoot, hWnd
GetWinInfo objRoot, hWnd&
Dim dicHandles As Scripting.Dictionary
Set dicHandles = New Scripting.Dictionary
AllHandles objRoot, dicHandles
'* write to the sheet
If bWriteToSheet Then
Dim ws As Excel.Worksheet
Set ws = ThisWorkbook.Worksheets.Item("Sheet1")
ws.Cells.Clear
ws.Cells(1, 1).Activate
WriteToSheet objRoot, ws, 1, 1
End If
'Debug.Assert dicHandles.Exists(25101170)
Set GetWindows = dicHandles
End Function
Private Sub GetWinInfo(ByVal obj As Object, hParent As Long)
'* 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 JSON document instead of a worksheet
Dim hWnd As Long
hWnd = FindWindowEx(hParent, 0&, vbNullString, vbNullString)
While hWnd <> 0
Dim objChildWindows As Object: Set objChildWindows = Nothing
If obj.hasOwnProperty("childWindows") Then
Set objChildWindows = VBA.CallByName(obj, "childWindows", VbGet)
Else
Set objChildWindows = SC.Run("JSON_parse", "[]")
Call SC.Run("setValueByKey", obj, "childWindows", objChildWindows)
End If
Dim objChild As Object
Set objChild = SC.Run("JSON_parse", "{}")
AdornAttributes objChild, hWnd
Call CallByName(objChildWindows, "push", VbMethod, objChild)
GetWinInfo objChild, hWnd
hWnd = FindWindowEx(hParent, hWnd, vbNullString, vbNullString)
Wend
End Sub
Private Function SC() As ScriptControl
'End
Static soSC As ScriptControl
If soSC Is Nothing Then
Set soSC = New ScriptControl
soSC.Language = "JScript"
soSC.AddCode "function deleteValueByKey(obj,keyName) { delete obj[keyName]; } "
soSC.AddCode "function setValueByKey(obj,keyName, newValue) { obj[keyName]=newValue; } "
soSC.AddCode "function enumKeysToMsDict(jsonObj,msDict) { for (var i in jsonObj) { msDict.Add(i,0); } } "
soSC.AddCode GetJavaScriptLibrary("https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js")
soSC.AddCode "function JSON_stringify(value, replacer,spacer) { return JSON.stringify(value, replacer,spacer); } "
soSC.AddCode "function JSON_parse(sJson) { return JSON.parse(sJson); } "
soSC.AddCode "function getjQuery(window) { return window.jQuery; } "
End If
Set SC = soSC
End Function
Private Function GetJavaScriptLibrary(ByVal sURL As String) As String
Dim xHTTPRequest As MSXML2.XMLHTTP60
Set xHTTPRequest = New MSXML2.XMLHTTP60
xHTTPRequest.Open "GET", sURL, False
xHTTPRequest.send
GetJavaScriptLibrary = xHTTPRequest.responseText
End Function
Private Sub SetIUnknown(ByRef ID As GUID)
'Defines the IUnknown variable. The interface
'ID is {00000000-0000-0000-C000-000000000046}.
With ID
.lData1 = &H0
.iData2 = &H0
.iData3 = &H0
.aBData4(0) = &HC0
.aBData4(1) = &H0
.aBData4(2) = &H0
.aBData4(3) = &H0
.aBData4(4) = &H0
.aBData4(5) = &H0
.aBData4(6) = &H0
.aBData4(7) = &H46
End With
End Sub
Private Sub SetIDispatch(ByRef ID As GUID)
'Defines the IDispatch variable. The interface
'ID is {00020400-0000-0000-C000-000000000046}.
With ID
.lData1 = &H20400
.iData2 = &H0
.iData3 = &H0
.aBData4(0) = &HC0
.aBData4(1) = &H0
.aBData4(2) = &H0
.aBData4(3) = &H0
.aBData4(4) = &H0
.aBData4(5) = &H0
.aBData4(6) = &H0
.aBData4(7) = &H46
End With
End Sub
Private Function HandleAndHex(ByVal l32Bit As Long) As String
HandleAndHex = PadHex(l32Bit) & " (" & CStr(l32Bit) & ")"
End Function
Private Function PadHex(ByVal l32Bit As Long) As String
PadHex = Right$("00000000" & Hex$(l32Bit), 8)
End Function
Private Function AdornAttributes(ByVal obj As Object, ByVal hWnd As Long)
Call SC.Run("setValueByKey", obj, "hWndHex", PadHex(hWnd))
Call SC.Run("setValueByKey", obj, "hWnd", hWnd)
Call SC.Run("setValueByKey", obj, "title", GetTitle(hWnd))
Call SC.Run("setValueByKey", obj, "class", GetClassName2(hWnd))
End Function
Private Function AllHandles(ByVal obj As Object, ByVal dic As Scripting.Dictionary)
Debug.Assert Not dic Is Nothing
Debug.Assert Not obj Is Nothing
If obj.hasOwnProperty("hWnd") Then
Dim hWnd As Long
hWnd = VBA.CallByName(obj, "hWnd", VbGet)
Debug.Assert Not dic.Exists(hWnd) '* one would think!
dic.Add hWnd, 0
End If
If obj.hasOwnProperty("childWindows") Then
Dim objChildWindows As Object
Set objChildWindows = VBA.CallByName(obj, "childWindows", VbGet)
Dim lLength As Long
lLength = VBA.CallByName(objChildWindows, "length", VbGet)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim objChild As Object
Set objChild = VBA.CallByName(objChildWindows, CStr(lLoop), VbGet)
AllHandles objChild, dic
Next lLoop
End If
End Function
Private Function WriteToSheet(ByVal obj As Object, ByVal ws As Excel.Worksheet, ByVal lRow As Long, ByVal lColumn As Long) As Long
Dim hWnd As Long
hWnd = CallByName(obj, "hWnd", VbGet)
ws.Cells(lRow, lColumn).Formula = "'" & HandleAndHex(hWnd)
ws.Cells(lRow, lColumn + 1).Value = CallByName(obj, "title", VbGet)
ws.Cells(lRow, lColumn + 2).Value = CallByName(obj, "class", VbGet)
If obj.hasOwnProperty("childWindows") Then
Dim objChildWindows As Object
Set objChildWindows = VBA.CallByName(obj, "childWindows", VbGet)
Dim lLength As Long
lLength = VBA.CallByName(objChildWindows, "length", VbGet)
Dim lLoop As Long
For lLoop = 0 To lLength - 1
Dim objChild As Object
Set objChild = VBA.CallByName(objChildWindows, CStr(lLoop), VbGet)
lRow = WriteToSheet(objChild, ws, lRow + 1, lColumn + 3)
Next lLoop
End If
WriteToSheet = lRow
End Function
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
Any idea of how we can do set operations using this library. I would like to Take controls in my VBA form and set accessible name on those at run-time.
ReplyDelete