VBA - Equivalent of Spy++ - JSONified

So I'm interested in all things JSON and will rewrite code to use it. In the previous post we saw some great code to query the Windows API and get the windows hierarchy in a manner similar to Spy++. I rewrote the code. I did this because (a) I wanted to decouple the gui logic from the core logic (b) I wanted to query the hierarchy for all the handles (for a different task) and (c) I wanted to use JSON as the vessel of state.

Option Explicit

'* Tools->References
'MSXML2             Microsoft XML, v6.0             C:\Windows\SysWOW64\msxml6.dll
'MSScriptControl    Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx
'Scripting          Microsoft Scripting Runtime     C:\Windows\SysWOW64\scrrun.dll

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 GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) 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 Function SC() As ScriptControl
    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); } "

    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
 
Public Sub GetWindows()
     
    Dim objRoot As Object
    Set objRoot = SC.Run("JSON_parse", "{}")
     
    Dim hWnd As Long
    hWnd = FindWindowExA(0, hWnd, "XLMAIN", vbNullString)
    
    AdornAttributes objRoot, hWnd
    GetWinInfo objRoot, hWnd&
        
    Dim dicHandles As Scripting.Dictionary
    Set dicHandles = New Scripting.Dictionary
    
    AllHandles objRoot, dicHandles
    
    
    '* write to the sheet
    
    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 Sub

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 = "'" & PadHex(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 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


Public 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

Public Function HandleAndHex(ByVal l32Bit As Long) As String
    HandleAndHex = PadHex(l32Bit) & " (" & CStr(l32Bit) & ")"
End Function

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

Public 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

Public 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


Public 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