VBA - Shell - Find - Command Line - Recursively find in files

Summary: Find, command line, searches for a specific string of text in a file or files. However, Find is limited to one folder, if you want to scan a folder structure recursively you'll need this VBA program.

So, I had a need to scan a heap of C++ source files looking for some relevant code sample. The command line program Find is very useful but generates too much output that needs editing, also it only runs on one folder at a time, so we need to write some code to loop through a list of folders. The list of folders itself is the result of shelling to the command line so there is some code ReadDirList_FoldersOnly() to parse a directory listing.

Also there is a file filters feature where one specifies a list of acceptable file extensions, the code given filters for *.cpp and *,.h files only because it is searching for C++ source files.

The code can take some time to run so I've added a status bar percentage progress counter. Because of disk activity there is little point trying to add multi-tasking or multi-threading.

The code is given below but here is some sample output

---------- C:\PROGRA~2\MICROS~4\2017\COMMUN~1\VC\TOOLS\MSVC\1412~1.258\ATLMFC\INCLUDE\AFXDOCOB.H
    BEGIN_INTERFACE_PART(OleDocument, IOleDocument)
    BEGIN_INTERFACE_PART(OleDocumentView, IOleDocumentView)
---------- C:\PROGRA~2\MICROS~4\2017\COMMUN~1\VC\TOOLS\MSVC\1412~1.258\ATLMFC\INCLUDE\AFXOLE.H
    BEGIN_INTERFACE_PART(OleDocumentSite, IOleDocumentSite)

Option Explicit
Option Private Module

Sub TestShellRecursiveDirectory2()
    Application.StatusBar = False
    Dim dicFolders As Scripting.Dictionary
    Set dicFolders = New Scripting.Dictionary
    'ShellRecursiveDirectory "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\", dicFolders
    ShellRecursiveDirectory "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\VC\Tools\MSVC\14.12.25827\atlmfc\include", dicFolders



    'Debug.Assert dicFolders.Count = 6467

    Dim sFindText As String
    sFindText = "IOLEDocument"

    Dim sTopFolder As String
    'sTopFolder = dicFolders.Keys(0)
    'dicFolders.RemoveAll
    'dicFolders.Add sTopFolder, 0

    Dim dicFindings As Scripting.Dictionary
    Set dicFindings = New Scripting.Dictionary

    RunFindInFolders dicFolders, sFindText, dicFindings, Array("cpp", "h")

    'Debug.Print Join(dicFindings.Items, vbNewLine)

    Call CreateObject("Scripting.FileSystemObject").CreateTextFile("n:\foo.txt").Write(Join(dicFindings.Items, vbNewLine))
    Application.StatusBar = False
End Sub


Sub RunFindInFolders(ByVal dicFolders As Scripting.Dictionary, ByVal sFindText As String, _
                                ByRef pdicFindings As Scripting.Dictionary, ByVal vFileFilters As Variant)

    If pdicFindings Is Nothing Then Set pdicFindings = New Scripting.Dictionary

    Dim lCounter As Long: lCounter = 0
    Dim lTotal As Long: lTotal = dicFolders.Count

    Dim vFolderLoop As Variant
    For Each vFolderLoop In dicFolders.Keys
        lCounter = lCounter + 1
        Dim lPercent As Long
        lPercent = CLng((lCounter / lTotal) * 100)

        If lPercent Mod 5 = 0 Then
            Application.StatusBar = "Complete " & lPercent & "%"

        End If

        DoEvents
        RunFindInFolder vFolderLoop, sFindText, pdicFindings, vFileFilters

    Next vFolderLoop

End Sub

Sub TestRunFindInFolder()
    Dim dicFindings As Scripting.Dictionary
    RunFindInFolder "C:\Users\Simon\DOWNLO~1\RUBBER~1\Rubberduck-next", "ole", dicFindings, Empty

    Debug.Print VBA.Join(dicFindings.Items, vbNewLine)
End Sub

Sub RunFindInFolder(ByVal sFolder As String, ByVal sFindText As String, _
                    ByRef pdicFindings As Scripting.Dictionary, ByVal vFileFilters As Variant)
    Static fso As New Scripting.FileSystemObject
    If pdicFindings Is Nothing Then Set pdicFindings = New Scripting.Dictionary

    If fso.FolderExists(sFolder) Then

        Dim sFullFileFilter As String
        sFullFileFilter = fso.BuildPath(sFolder, "*.*")
        '#sFullFileFilter = fso.BuildPath(sFolder, sFileFilter)



        Dim sTempFile As String, sFullTempFile As String
        TempFile sFullFileFilter, sTempFile, sFullTempFile, ".txt"

        If fso.FileExists(sFullTempFile) Then fso.DeleteFile sFullTempFile
        Debug.Assert Not fso.FileExists(sFullTempFile)


        Dim sCmd As String
        sCmd = Environ$("comspec") & " /C Find """ & sFindText & """ " & sFullFileFilter & " /I > " & sFullTempFile
        'find "Ole" *.*  /I > %TEMP%\ole_find.txt

        Dim oWshShell As IWshRuntimeLibrary.WshShell
        Set oWshShell = New IWshRuntimeLibrary.WshShell

        Dim lProc As Long
        lProc = oWshShell.Run(sCmd, 0, True)

        Debug.Assert fso.FileExists(sFullTempFile)

        Dim dicLines As Scripting.Dictionary
        Set dicLines = New Scripting.Dictionary


        Dim txtIn As Scripting.TextStream
        Set txtIn = fso.OpenTextFile(sFullTempFile)

        Do While Not txtIn.AtEndOfStream
            DoEvents
            Dim sLine As String
            sLine = txtIn.ReadLine

            dicLines.Add dicLines.Count, sLine


        Loop
        txtIn.Close
        Set txtIn = Nothing

        Call ReadFindingsFile(sFolder, dicLines, pdicFindings, vFileFilters)

    End If

End Sub

Sub ReadFindingsFile(ByVal sFolder As String, ByVal dicLines As Scripting.Dictionary, _
                ByRef pdicFindings As Scripting.Dictionary, ByVal vFileFilters As Variant)
    Static fso As New Scripting.FileSystemObject


    If pdicFindings Is Nothing Then Set pdicFindings = New Scripting.Dictionary

    'Dim vSplit 'As String
    'vSplit = Split(sFindings, vbNewLine)

    Dim sPrefix As String
    sPrefix = "---------- " & sFolder

    Dim dicTemp As Scripting.Dictionary
    Set dicTemp = New Scripting.Dictionary

    Dim vLoop As Variant
    For Each vLoop In dicLines.Items
        DoEvents
        
            Dim sCurrentFile As String
        
        '* do we have a file header, if so capture the filename
        '* and check if it has the right file extension
        If StartsWith(sPrefix, vLoop) Then
            Dim sNextFile As String
            sNextFile = Trim(Mid(vLoop, Len("---------- "), Len(vLoop)))
            
            Dim bCaptureOutput As Boolean
            bCaptureOutput = FileExtensionMatch(sNextFile, vFileFilters)
            
            '* copy over anything
            MoveOverItemsWithHeader sCurrentFile, dicTemp, pdicFindings
            
            sCurrentFile = sNextFile
        Else
            '* it's not a header line it is an output line
            If bCaptureOutput Then
                If Len(Trim(vLoop)) > 0 Then
                    dicTemp.Add dicTemp.Count, vLoop
                End If
            End If
        
        End If
        
        
        
'        If StartsWith(sPrefix, vLoop) Then
'
'            Dim sFile As String
'
'            Dim sNextFile As String
'            sNextFile = Trim(Mid(vLoop, Len("---------- "), Len(vLoop)))
'
'
'
'            Dim sFileName As String
'            sFileName = Trim(Mid(vLoop, Len("---------- "), Len(vLoop)))
'
'            'Debug.Assert fso.FileExists(sFileName)
'
'
'
'            If FileExtensionMatch(sFileName, vFileFilters) Then 'UCase$(fil.Name) Like UCase$(sFileFilter)
'                'If Len(sFile) > 0 Then
'                    MoveOverItemsWithHeader sFile, dicTemp, pdicFindings
'                'End If
'            Else
'                dicTemp.RemoveAll
'            End If
'
'            sFile = sNextFile
'
'        Else
'            If Len(Trim(vLoop)) > 0 Then
'                dicTemp.Add dicTemp.Count, vLoop
'
'            End If
'
'        End If
    Next vLoop
    'Stop

    '* copy over anything
    MoveOverItemsWithHeader sCurrentFile, dicTemp, pdicFindings


'    If FileExtensionMatch(sFileName, vFileFilters) Then
'        MoveOverItemsWithHeader sFile, dicTemp, pdicFindings
'    Else
'        dicTemp.RemoveAll
'    End If


    Debug.Assert dicTemp.Count = 0

End Sub

Private Function FileExtensionMatch(ByVal sFileName As String, _
                            ByVal vFileFilters As Variant) As Boolean
    Static fso As New Scripting.FileSystemObject

    If Len(sFileName) > 0 Then

        If Not fso.FileExists(sFileName) Then
            FileExtensionMatch = False
        Else

            If IsEmpty(vFileFilters) Then
                FileExtensionMatch = True
            Else

                Debug.Assert fso.FileExists(sFileName)

                Dim fil As Scripting.File
                Set fil = fso.GetFile(sFileName)

                Dim vSplitFileName As Variant
                vSplitFileName = Split(fil.Name, ".")

                Dim sFileExt As String
                sFileExt = vSplitFileName(UBound(vSplitFileName))

                Dim bFilterMatch As Boolean
                FileExtensionMatch = (VBA.InStr(1, _
                            "|" & Join(vFileFilters, "|") & "|", _
                            "|" & sFileExt & "|", _
                            vbTextCompare) > 0)

            End If
        End If
    End If

End Function

Private Function MoveOverItemsWithHeader(ByVal sFile As String, ByVal dicFrom As Scripting.Dictionary, _
            ByVal dicTo As Scripting.Dictionary)

    If Len(sFile) > 0 Then
        If dicFrom.Count > 0 Then
            Debug.Print "---------- " & sFile
            dicTo.Add dicTo.Count, "---------- " & sFile
    
            Dim vCopyLoop As Variant
            For Each vCopyLoop In dicFrom.Items
                dicTo.Add dicTo.Count, vCopyLoop
                Debug.Print vCopyLoop
            Next
    
            dicFrom.RemoveAll
        End If
    End If

End Function


'Private Sub TestStartsWith()
'    Debug.Assert StartsWith("Hell", "Hello world")
'    Debug.Assert Not StartsWith("Hell", "He")
'    Debug.Assert Not StartsWith("Hell", "Foob")
'End Sub

Function StartsWith(ByVal sPrefix As String, ByVal sTest As String) As Boolean
    If LenB(sPrefix) <= LenB(sTest) Then
        StartsWith = (VBA.StrComp(sPrefix, Left$(sTest, Len(sPrefix)), vbTextCompare) = 0)
    End If
End Function

Function TempFile(ByVal sURL As String, ByRef psTempFile As String, ByRef psFullTempFile As String, _
                                                            Optional ByVal sSuffix As String = ".txt")


    Static dict As New Scripting.Dictionary
    Static fso As New Scripting.FileSystemObject

    Dim lProcessUniqueId As Long
    lProcessUniqueId = UniqueProcessId

    Dim sTempFile As String
    psTempFile = CStr(lProcessUniqueId) & CStr(dict.HashVal(sURL)) & sSuffix

    Dim sFullTempFile As String
    psFullTempFile = fso.BuildPath(Environ$("TEMP"), psTempFile)


End Function

Function UniqueProcessId() As Long
    On Error Resume Next
    UniqueProcessId = CallByName(Application, "Hwnd", VbGet)
End Function

Sub ShellRecursiveDirectory(ByVal sStartFolder As String, ByRef pdicFolders As Scripting.Dictionary)

    Static fso As New Scripting.FileSystemObject


    If Not fso.FolderExists(sStartFolder) Then
        Err.Raise vbObjectError, , "#Folder sStartFolder '" & sStartFolder & "' does not exist!"
    Else
        Dim fld As Scripting.Folder
        Set fld = fso.GetFolder(sStartFolder)

        Dim oWshShell As IWshRuntimeLibrary.WshShell
        Set oWshShell = New IWshRuntimeLibrary.WshShell



        Dim sTempFile As String, sFullTempFile As String
        TempFile sStartFolder, sTempFile, sFullTempFile, ".txt"

        If fso.FileExists(sFullTempFile) Then fso.DeleteFile sFullTempFile
        Debug.Assert Not fso.FileExists(sFullTempFile)

        Dim sCmdSpec As String
        sCmdSpec = Environ("comspec") & " /C " '* /C is required to run remainder of command

        Dim sCmdLine As String
        sCmdLine = sCmdSpec & " dir " & fld.ShortPath & "\*.* /s  > " & sFullTempFile


        Dim lProc As Long
        lProc = oWshShell.Run(sCmdLine, 0, True)

        Debug.Assert fso.FileExists(sFullTempFile)

        Dim dic As Scripting.Dictionary

        ReadDirList_FoldersOnly sFullTempFile, pdicFolders
        'Stop
    End If


End Sub


Function ReadDirList_FoldersOnly(ByVal sPipedOutputPath As String, ByRef pdicFolders As Scripting.Dictionary)

    Static fso As New Scripting.FileSystemObject
    If fso.FileExists(sPipedOutputPath) Then

        Dim txtIn As Scripting.TextStream
        Set txtIn = fso.OpenTextFile(sPipedOutputPath)

        Set pdicFolders = New Scripting.Dictionary

        Dim sLine As String
        sLine = txtIn.ReadLine
        While Not txtIn.AtEndOfStream
            DoEvents

            Dim sDirectory As String
            Dim bIsDirectoryHeader As Boolean
            bIsDirectoryHeader = IsDirectoryHeader(sLine, sDirectory)

            If IsTrailerLine(sLine) Then

                If Not pdicFolders.Exists(sDirectory) Then pdicFolders.Add sDirectory, 0
            End If

            sLine = txtIn.ReadLine
        Wend

        txtIn.Close
        Set txtIn = Nothing
    End If

End Function

Function IsTrailerLine(ByVal sLine As String) As Boolean
    If (VBA.InStr(1, sLine, "File(s)", vbTextCompare) > 0) Then
        IsTrailerLine = True
    End If
End Function

Function IsDirectoryHeader(ByVal sLine As String, ByRef psDirectory As String) As Boolean
    If VBA.InStr(1, sLine, " Directory of ", vbTextCompare) > 0 Then
        psDirectory = Trim(Mid$(sLine, 15))
        IsDirectoryHeader = True
    End If
End Function

VBA - XMLHTTP60 - Tricky event handling

Summary: XMLHTTP60 does not have any standard VBA events but by adding a class and pulling a trick in a text editor we can track events.

So neither MSXML2.XMLHTTP60 nor MSXML2.ServerXMLHTTP60 have any standard VBA events that can be trapped by declaring a variable with the WithEvents keyword. This contrasts with the WinHttp.WinHttpRequest class (see prior blog post for example code). However, we can still trap events but we have to pull a trick or two along the way. The official tutorial from Microsoft is given here, Microsoft - Use the onReadyStateChange Property (Visual Basic)

One needs to create a VBA class to handle the events. I give the source next but this is exported file source to be copied into a text editor such as Notepad, saved and then imported in the VBA IDE. Do not cut and paste directly into the VBA IDE. This is because of a line of hidden source code which is given here

Attribute Item.VB_UserMemId = 0

This line will disappear from view once the class module is imported. [In case you're interested in what it does, setting UserMemId=0 makes it the default method which means you can call it whatever you want because the caller will ask for it by its Dispatch Id (0), this is an IDispatch trick]. The top 9 lines also disappear but that is standard behaviour.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "XHRSink"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' In text editor, need to put "Attribute Item.VB_UserMemId = 0" on line underneath next line, 
' save and then import into VBA IDE, this sets the default method of this class
' Then we set an instance of this class to the OnReadyStateChange property of
' MSXML2.XMLHTTP60 or MSXML2.ServerXMLHTTP60 to get events
' The line "Attribute Item.VB_UserMemId = 0" will DISAPPEAR from view once imported
Sub OnReadyStateChange()
 Attribute Item.VB_UserMemId = 0

    Debug.Print goXHR.readyState
    If goXHR.readyState = 4 Then
        Debug.Print "sink code handling result"
        Debug.Print goXHR.responseText
    End If
End Sub

So now that the above class is imported, it should read XHRSink in the project folder, we can use it when setting the OnReadyStateChange [N.B. we don't use the Set keyword, this is not a typo!] of XMLHTTP60 (or ServerXMLHTTP60) . We are calling a slow and chunky web service built in a prior blog post.

Option Explicit

'* Tools->References
'MSXML2      Microsoft XML, v6.0      C:\Windows\SysWOW64\msxml6.dll


Global goXHR As MSXML2.XMLHTTP60

'https://msdn.microsoft.com/en-us/library/ms757030(v=vs.85).aspx


Public Sub HttpGet()
    On Error GoTo ErrHandler

    Randomize
    Debug.Print String(10, vbNewLine)

    Dim bAsync As Boolean
    'bAsync = True
    bAsync = False

    Set goXHR = New MSXML2.XMLHTTP60
    
    '* need random number in query parameters to make url unique and stop caching
    goXHR.Open bstrMethod:="GET", bstrURL:="http://localhost:34957/slowAndChunkyWebService?chunkCount=5&random=" & Rnd(1), varAsync:=bAsync
    
    Dim oSink As XHRSink
    Set oSink = VBA.IIf(bAsync, New XHRSink, Nothing)
    
    goXHR.OnReadyStateChange = oSink
    
    
    goXHR.send
    
    Debug.Print "send called with bAsync=" & bAsync
    If bAsync = False Then
        Debug.Print "main code handling result with bAsync=" & bAsync
        If goXHR.readyState = 4 Then Debug.Print goXHR.responseText
    End If
    
SingleExit:
    Exit Sub
ErrHandler:
    Debug.Print "Error (" & Err.Number & ") " & Err.Description
    Stop
    Resume
    
End Sub

To experiment swap the commenting on bAsync = True and bAsync = False. The code reports to the Immediate window what it is doing. Sadly no option to chunk the response is available (not that I know of). Here is some sample reported output when bAsync = True.

send called with bAsync=True
 2 
 3 
 4 
sink code handling result
foobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobar...

Ok, so that works but how extendable is it? What happens with multiple requests? So for multiple requests one would need to upgrade the XHRSink class with an identifier to tie it back to the source; this is a bit poor but not impossible.

Final thoughts. The limited event handling for XMLHTTP60 needs to be compared and contrasted with (a) WinHttpRequest (b) that found in modern browsers facilitated by jQuery and (c) that found on the web servers such as Node.js I would be very tempted to write web service client code in Node.js and then allow VBA to call in to the finalised and processed results.

VBA - WinHttpRequest - No asynchronous chunks

Summary: WinHttp.WinHttpRequest is yet another Http request class that has some features such as chunking, sadly it won't chunk asynchronously.

So someone asked a good question of SO about chunking data from a web service, the questioner complained about missing data. With the object browser it can be seen that WinHttp.WinHttpRequest supports events which can be used to trap chunks of data. It looked promising. However, after some experimentation it does not seem possible to have asynchronous chunking. One can have asynchronous request and receive the whole request or one can have a chunked synchronous request. One cannot have both chunked and asynchronous.

I give code below some that others can check my results. I tested against a Node.js slow and chunky web service from a prior blog post. In order to sink events it is necessary to use the WithEvents keyword in a class module. Here is the class module which I called WHRChunked

Option Explicit

'* Tools->References
'WinHttp        Microsoft WinHTTP Services, version 5.1          C:\WINDOWS\system32\winhttpcom.dll

Private WithEvents moWHR As WinHttp.WinHttpRequest

Public msBufferedResponse As String
Public mbFinished As Boolean

Private Const mbDEFAULT_DEBUG  As Boolean = True
Public mvDebug As Variant

Public Property Get bDebug() As Boolean
    If IsEmpty(mvDebug) Then mvDebug = mbDEFAULT_DEBUG
    
    bDebug = mvDebug
End Property
Public Property Let bDebug(ByVal bRHS As Boolean)
    mvDebug = bRHS
End Property

Public Sub HttpGet(ByVal sURL As String, bAsync As Boolean)
    On Error GoTo ErrHandler

    Set moWHR = New WinHttp.WinHttpRequest
    
    
    mbFinished = False
    msBufferedResponse = ""
    
    moWHR.Open Method:="GET", URL:=sURL, async:=bAsync
    
    moWHR.send
    Debug.Print "send called with bAsync=" & bAsync
SingleExit:
    Exit Sub
ErrHandler:
    Debug.Print "Error (" & Err.Number & ") " & Err.Description
    Stop
    Resume
    
End Sub


Private Sub moWHR_OnError(ByVal ErrorNumber As Long, ByVal ErrorDescription As String)
    Debug.Print "moWHR_OnError"

End Sub

Private Sub moWHR_OnResponseDataAvailable(Data() As Byte)
    
    Dim sThisChunk As String
    sThisChunk = StrConv(Data(), vbUnicode)
    
    Debug.Print "moWHR_OnResponseDataAvailable (" & Len(sThisChunk) & ")"
    
    msBufferedResponse = msBufferedResponse & sThisChunk
    
End Sub

Private Sub moWHR_OnResponseFinished()
    Debug.Print "moWHR_OnResponseFinished"
    mbFinished = True
End Sub

Private Sub moWHR_OnResponseStart(ByVal Status As Long, ByVal ContentType As String)

    Dim v
    v = VBA.Split(moWHR.getAllResponseHeaders, vbNewLine)
    Debug.Print "moWHR_OnResponseStart"

End Sub

And we need some code in a standard module to call into the class, remember this needs the web service from previous blog post.

Option Explicit

Sub Test()
    Dim oWHRChunked As WHRChunked
    Set oWHRChunked = New WHRChunked
    
    oWHRChunked.HttpGet "http://localhost:34957/slowAndChunkyWebService?chunkCount=2", True
    'oWHRChunked.HttpGet "http://localhost:34957/slowAndChunkyWebService?chunkCount=2", False
    
    While oWHRChunked.mbFinished = False
        DoEvents
    Wend
    
    Debug.Print oWHRChunked.msBufferedResponse


End Sub

So to experiment simply swap the above commented line for the other to see the different effects, the evidence is posted to the Immediate window using Debug.Print .

Final thoughts, I'm disappointed by this finding I hope I have it wrong. I must do a comparison table of the different features between MSXML2.XMLHTTP60, MSXML2.ServerXMLHTTP60 and WinHttpRequest.

Node.js - Slow and chunky webservice (deliberately slow)

So I want to test event handling of a library available for VBA developers but to test it I need to first build a web server that is deliberately slow and chunky. I blogged a simple web service previously that chunked a request (taking each chunk to process a portion of the post body). This time I want to chunk the response.

We use setTimeout (just like a browser) to schedule execution of a block of code. We are not reading a file or anything we are simply sending text strings back. We are splitting this out into schedule chunks to fit nicely with Node.js asynchronous non-blocking interleaved execution pattern.

The node.js libraries used are http and url. http handles the request and response streams. url will parse the url including querystring which is required here, we parse out chunkCount from the querystring (and take 1 on default). Parsing the url make its easy to route the url, in the code we are only interested in urls that start with /slowAndChunkyWebService.

Use Visual Studio 2017 community with Node,js installed and create a console app then paste in the following code, then press F5 to start running.

'use strict';

const http = require('http');
const url = require('url');
const port = 34957;

console.log('Slow and chunky web servicen');

const requestHandler = (request, response) => {

    var url_parts = url.parse(request.url, true);
    var query = url_parts.query;

    if (url_parts.pathname == '/slowAndChunkyWebService') {

        var chunkCount = 0;

        try {
            chunkCount = parseInt(query.chunkCount);

            if (typeof (chunkCount) == "undefined") { chunkCount = 1; }

        }
        catch (ex) { chunkCount = 1; }

        console.log('main code about to call myWriteChunk() with chunkCount' + chunkCount + 'n');
        myWriteChunk(response, chunkCount);

    } else {
        console.log(request.url);
        response.end(request.url);
    }
}

function myWriteChunk(response, chunkCount) {
    console.log('myWriteChunk called chunkCount' + chunkCount + 'n')

    var chunky = "foobar".repeat(10);

    response.write(chunky);

    chunkCount--;

    if (chunkCount > 0) {
        setTimeout(function () { myWriteChunk(response, chunkCount) }, 1000)
    } else {
        console.log('about to schedule myResponseEndn')
        setTimeout(function () { myResponseEnd(response) }, 1000)
        
    }
}

function myResponseEnd(response) {
    console.log('myResponseEnd calledn')
    response.end();
}



const server = http.createServer(requestHandler);

server.listen(port, (err) => {
    if (err) {
        return console.log('something bad happened', err);
    }

    console.log(`server is listening on ${port}`);
})

One can test this by going to a browser and typing in the url...

http://localhost:34957/slowAndChunkyWebService?chunkCount=2

In the node.js console the following output should be seen...

Debugger listening on ws://127.0.0.1:48449/40a2b131-8546-4801-adf3-c3b16d0b72a2
For help see https://nodejs.org/en/docs/inspector
Debugger attached.
(node:17292) [DEP0062] DeprecationWarning: `node --inspect --debug-brk` is deprecated. Please use `node --inspect-brk` instead.
Slow and chunky web service

server is listening on 34957
main code about to call myWriteChunk() with chunkCount2

myWriteChunk called chunkCount2

myWriteChunk called chunkCount1

about to schedule myResponseEnd

myResponseEnd called

/favicon.ico

And the browser will show contents only after all of them have been received.

foobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobarfoobar

VBA - Node.js - Simple Javascript Webservice

So after having established the limits of ScriptControl and cscript.exe I feel the need to find a Javascript interoperability platform for VBA programmers. The ScriptControl can still parse JSON thanks to Douglas Crockford's scripts still being runnable on Ecmascript v.3 but other javascript libraries are already on Ecmascript v.6.

Javascript Web Service

So we need a new solution and Node.js is the answer. Here we give a simple webservice that takes a Javascript document, extracts some information and returns it. First, the javascript file, open Visual Studio 2017 with Node.js workload installed and open new Node.js console project and paste in the code below.

extractTitleAndUrl()

The extraction logic takes place in extractTitleAndUrl() and is expecting a document of a certain format (actually its a Google Sheets API format) and will extract two facts, title and url from each entry in an array. It adds these two facts to a new smaller object and places them in array. The array is stringified before returning. An error handler traps any problem but foes not give much information. You can see some test data for extractTitleAndUrl() commented out.

The Web Server

Everything that is not extractTitleAndUrl() is web server logic. I'll not explain too much of the plumbing here because other documentation does it better. In the requestHandler() we inspect the url to see if it has suffix '/extractTitleAndUrl' and if so run our logic otherwise print a hello world message. The body of the request is accumulated in chunks because Node.js splits these tasks into very small pieces so that code interleaves, this is the asynchronous model. Once the body is fully received then our logic extractTitleAndUrl() can be executed.

VBA client code is given below

'use strict';

const http = require('http');
const port = 80;

console.log('\nversion Juno\n');

const requestHandler = (request, response) => {

    if (request.url == '/extractTitleAndUrl') {
        //https://nodejs.org/en/docs/guides/anatomy-of-an-http-transaction/

        let body = [];
        request.on('data', (chunk) => {
            body.push(chunk);
        }).on('end', () => {
            body = Buffer.concat(body).toString();
            // at this point, `body` has the entire request body stored in it as a string
            console.log('\nbody received:\n\n'+body);

            var titleAndUrl = extractTitleAndUrl(body)
            console.log('\nextracted title and url:\n\n' + titleAndUrl );

            response.end(titleAndUrl);
        });

    } else {
        console.log(request.url);
        response.end('Hello Node.js Server!');
    }
}

const server = http.createServer(requestHandler);

server.listen(port, (err) => {
    if (err) {
        return console.log('something bad happened', err);
    }

    console.log(`server is listening on ${port}`);
})

//var doc = {
//    "feed": {
//        "entry":
//        [{ "title": { "$t": "1 Med" }, "link": [{ "href": "https//removed.1.Med.." }] },
//        { "title": { "$t": "2 Dent" }, "link": [{ "href": "https//removed.2.Dent.." }] },
//        { "title": { "$t": "3 Vet" }, "link": [{ "href": "https//removed.3.Vet.." }] }]
//    }
//};

//console.log(JSON.stringify(extractTitleAndUrl(doc)));

function extractTitleAndUrl(text) {

    try {
        var doc = JSON.parse(text);
        var newArray = new Array();

        for (var i = 0; i < doc.feed.entry.length; i++) {

            var newObj = new Object();
            newObj['title'] = doc.feed.entry[i].title.$t;
            if (doc.feed.entry[i].link.length = 1) {
                newObj['url'] = doc.feed.entry[i].link[0].href;
            } else {
                newObj['url'] = doc.feed.entry[i].link[2].href;
            }

            newArray.push(newObj);
        }
        return  JSON.stringify(newArray);
    }
    catch (ex) {
        return ('#error in extractTitleAndUrl!'); 
    }
}

Run the code with the Visual Studio start button, the following should be outputted

Debugger listening on ws://127.0.0.1:15347/1c2b4b25-fa9e-4690-b6a4-524b506491cb
For help see https://nodejs.org/en/docs/inspector
Debugger attached.
(node:5212) [DEP0062] DeprecationWarning: `node --inspect --debug-brk` is deprecated. Please use `node --inspect-brk` instead.

version Juno

server is listening on 80
...

VBA client code

The VBA code is given below. One point of note is that to stop cacheing it is necessary to use ServerXMLHTTP60 and not XMLHTTP60 re this StackOverflow response. The place to start execution is TestWebService(), press F5 there. This should return with the correct results but the console for Node.js should also output some messages...

...
server is listening on 80

body received:

{ "feed": {"entry": [   {     "title": { "$t": "1 Med" },     "link": [ { "href": "https//removed...." } ]   },  
 {     "title": { "$t": "2 Dent" },     "link": [ { "href": "https//removed...." } ]   },  
 {     "title": { "$t": "3 Vet" },     "link": [  { "href": "https//removed...." }]   }] } }

extracted title and url:

[{"title":"1 Med","url":"https//removed...."},{"title":"2 Dent","url":"https//removed...."},{"title":"3 Vet","url":"https//removed...."}]

Option Explicit

'* Tools->References
'MSScriptControl        Microsoft Script Control 1.0        C:WindowsSysWOW64msscript.ocx
'MSXML2                 Microsoft XML, v6.0                 C:WindowsSysWOW64msxml6.dll

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

Function SimpleMasterPage() As String

    SimpleMasterPage = "{ ""feed"": {" & _
    """entry"": [ " & _
    "  { " & _
    "    ""title"": { ""$t"": ""1 Med"" }, " & _
    "    ""link"": [ { ""href"": ""https//removed...."" } ] " & _
    "  }, " & _
    "  { " & _
    "    ""title"": { ""$t"": ""2 Dent"" }, " & _
    "    ""link"": [ { ""href"": ""https//removed...."" } ] " & _
    "  }, " & _
    "  { " & _
    "    ""title"": { ""$t"": ""3 Vet"" }, " & _
    "    ""link"": [  { ""href"": ""https//removed...."" }] " & _
    "  }" & _
    "] } }"

    Dim objGutted2 As Object
    Set objGutted2 = SC.Run("JSON_parse", SimpleMasterPage)

End Function

Sub TestWebService()

    '* Do not use XMLHTTP60 because it caches!
    '* https://stackoverflow.com/questions/5235464/how-to-make-microsoft-xmlhttprequest-honor-cache-control-directive#5386957
    
    Dim vBody As Variant
    vBody = SimpleMasterPage


    Dim oXHR As MSXML2.ServerXMLHTTP60
    Set oXHR = New MSXML2.ServerXMLHTTP60
    oXHR.Open "POST", "http://localhost/extractTitleAndUrl"
    oXHR.setRequestHeader "Cache-Control", "no-cache, no-store"
    oXHR.send vBody
    
    Debug.Print oXHR.responseText
    Debug.Assert oXHR.responseText = "[{""title"":""1 Med"",""url"":""https//removed....""},{""title"":""2 Dent"",""url"":""https//removed....""},{""title"":""3 Vet"",""url"":""https//removed....""}]"

    Stop

End Sub

VBA - XMLHttp Request (XHR) does not parse response as XML

HTML was initially conceived to be like XML in that for every opening tag there is a closing tag and the attributes are enclosed in quotes but in reality it breaks these rules and can rarely be used with an Xml parser. So XML is fussy and HTML is not.

However, take a look at the following code; it uses the XmlHttp request (XHR) object but we should note that it never parses the response as Xml unless you write the code (example code given in separate function). I think this is nice use of XHR. The code goes on to insert the response text as Html into a MSHTML.HTMLDocument and from there can web scrape whatever.

Sub DoNotParseXml()

    Dim oXHR As MSXML2.XMLHTTP60
    Set oXHR = New MSXML2.XMLHTTP60
    
    Dim oHtmlDoc As MSHTML.HTMLDocument
    Set oHtmlDoc = New MSHTML.HTMLDocument
    
    oXHR.Open "GET", "https://coinmarketcap.com/all/views/all/" & "?Random=" & Rnd() * 100, False
    oXHR.setRequestHeader "Content-Type", "text/XML"
    oXHR.send

    If oXHR.Status = "200" Then
        
        '* no parse of 'non well-formed xml' take place
        oHtmlDoc.body.innerHTML = oXHR.responseText
    
        '** do some web scraping with MSHTML.HTMLDocument
    
        '... oHtmlDoc.getElementsByClassName("price")

        
        '* but if we had tried to parse the response text .. it would have errored
        ParseXml oXHR.responseText
    End If
End Sub

Private Function ParseXml(ByVal sText As String) As MSXML2.DOMDocument60
    Dim oDom As MSXML2.DOMDocument60
    Set oDom = New MSXML2.DOMDocument60
    oDom.LoadXML sText
    
    '* it would have errored
    Debug.Assert oDom.parseError = 0

End Function

VBA - Webscraping - jQuery selectors available with MSHTML's querySelector and querySelectorAll

So another SO question about web scraping in VBA. I wrote some code but was not happy with it and so revisited it. It turns out that the jQuery selector syntax can be quite advanced, a bit like XPath for Xml.

Tip #1 When using querySelectorAll() use Early-binding

I have seen some strangeness when using querySelectorAll() when getting the length, the problem goes away if you use early binding type library (Tools->References->Microsoft HTML Object Library)

    Dim oSelectors As MSHTML.IHTMLDOMChildrenCollection
    Set oSelectors = oHtml.querySelectorAll("div.blocoCampos input")
    
    Dim lSelectorResultList As Long
    lSelectorResultList = oSelectors.Length

Note above the selector gets input elements which are children of div elements with the class 'blocoCampos'.

Tip #2 When using querySelectorAll() use item to acquire each element not For Each

I have also seen some strangeness when using querySelectorAll() that errors on the Next line of a For Each loop. So avoid by establishing the length of the result array and then use a standard integer loop and acquire each element with item.

    Dim lSelectorResultLoop As Long
    For lSelectorResultLoop = 0 To lSelectorResultList - 1

        Dim objChild As Object
        Set objChild = oSelectors.Item(lSelectorResultLoop)

Selecting grandchild anchor off second span child of a div with id

Given the following HTML source the questioner wanted to navigate to the anchor links. The anchors do have not id and no class; neither do their parent span elements; but the spans' parent div element have (non-unique) id so we can start the capture there.

<div id="resumopesquisa">

  <div id="itemlistaresultados" style="background-color: #EDEDED">
   <span class="labellinha">Acórdãos de Repetitivos</span>
   <!-- <span>  PIS E ICMS E COFINS E CALCULO E BASE E DE REPETITIVOS.NOTA.
   </span> -->
   
   <span><a href="/SCON/jurisprudencia/toc.jsp?livre=ICMS+BASE+DE+CALCULO+PIS+COFINS&repetitivos=REPETITIVOS&&b=ACOR&thesaurus=JURIDICO&p=true">1
     documento(s) encontrado(s)</a></span>
   
  </div>
  
 
 <div id="itemlistaresultados">
  <span class="labellinha">Acórdãos</span>
  <!-- <span>  PIS E ICMS E COFINS E CALCULO E BASE E DE
  </span> -->
  
  <span><a href="/SCON/jurisprudencia/toc.jsp?livre=icms+base+de+calculo+pis+cofins&&b=ACOR&thesaurus=JURIDICO&p=true">284
    documento(s) encontrado(s)</a></span>
  
 </div>
</div>

So let's build up our jQuery selector expression, first let's get the divs but specifiying their id ( yeah, I know I though ids were unique as well) ...

div#itemlistaresultados

But then we need to get the second child span element of the div, we can do this with jQuery's nth-child selector. We simply add a space between the div expression and the span expression to express the parent child relationship ...

div#itemlistaresultados span:nth-child(2)

Finally we pick out the anchor element with

div#itemlistaresultados span:nth-child(2) a

So we can put this jQuery selector expression into MSHTML's querySelectorAll method (use querySelector for singleton results), here is the VBA

    Set oHtml = ie.Document
    Dim objResultList As MSHTML.IHTMLDOMChildrenCollection
    Set objResultList = oHtml.querySelectorAll("div#itemlistaresultados span:nth-child(2) a")

    Dim lResultCount As Long
    lResultCount = objResultList.Length

    Debug.Print
    Dim lResultLoop As Long
    For lResultLoop = 0 To lResultCount - 1

        Dim anchorLoop As MSHTML.HTMLAnchorElement
        Set anchorLoop = objResultList.Item(lResultLoop)

        Debug.Print achLoop.href

    Next

Tip #3 When not required use late binding to get aggregated interface

So when dealing with an input checkbox then it must be understood that its functionality is defined across a great many number of different interfaces such as MSHTML.HTMLInputElement, MSHTML.IHTMLInputElement and many more. Perhaps the input box is a worst case example because it is a multifaceted definition but for illustration here is what OLEView gives the interfaces implemented by the coclass MSHTML.HTMLInputElement ...

    coclass HTMLInputElement {
        [default] dispinterface DispHTMLInputElement;
        [default, source] dispinterface HTMLInputTextElementEvents;
        [source] dispinterface HTMLInputTextElementEvents2;
        [source] dispinterface HTMLOptionButtonElementEvents;
        [source] dispinterface HTMLButtonElementEvents;
        interface IHTMLElement;
        interface IHTMLElement2;
        interface IHTMLElement3;
        interface IHTMLElement4;
        interface IHTMLUniqueName;
        interface IHTMLDOMNode;
        interface IHTMLDOMNode2;
        interface IHTMLDOMNode3;
        interface IHTMLDatabinding;
        interface IHTMLElement5;
        interface IHTMLElement6;
        interface IElementSelector;
        interface IHTMLDOMConstructor;
        interface IHTMLElement7;
        interface IHTMLControlElement;
        interface IHTMLInputElement;
        interface IHTMLInputElement2;
        interface IHTMLInputTextElement;
        interface IHTMLInputTextElement2;
        interface IHTMLInputHiddenElement;
        interface IHTMLInputButtonElement;
        interface IHTMLInputFileElement;
        interface IHTMLOptionButtonElement;
        interface IHTMLInputImage;
        interface IHTMLInputElement3;
        interface IHTMLInputRangeElement;
    };

So instead of figuring out on which interface of the list above a method is implemented it is better to declare the variable with As Object to use late binding, and then all the methods from all of the interfaces are aggregated onto a IDispatch interface.

Links

• jQuery API Documentation - nth-child() Selector
• Stack Overflow - vba - Clicking on a link without Id or class

Javascript - cscript.exe and script control limited to Ecmascript 3

So the script control (MSScriptControl|Microsoft Script Control 1.0|C:\Windows\SysWOW64\msscript.ocx) is very useful for parsing JSON because Douglas Crockford's scripts run happily but it is limited to Ecmascript version 3. Sadly the command line script executable, cscript.exe (c:\Windows\SysWOW64\cscript.exe) is also restricted to Ecmascript version 3 because they sahare the same JScript engine.

We can see this we some Javascript version detection code. Save this file as test.js

JavaScriptVersion();


function JavaScriptVersion() {
    if (typeof this.WScript != 'undefined') {
        WScript.echo("supports ES3:" + checkES3());
        WScript.echo("supports ES5:" + checkES5());
        WScript.echo("supports foreach:" + forEach());
    }
}


function checkES3() {
    try {
    return "function" === typeof [].hasOwnProperty;
    }
    catch (ex) { }
}

function checkES5() {
    try {
        var methods = 'function' === typeof [].filter &&
            'function' === typeof Function.prototype.bind &&
            'function' === typeof Object.defineProperty &&
            'function' === typeof ''.trim &&
            'object' === typeof JSON;

        var syntax = supports("reservedWords");
    }
    catch (ex) { }

    return methods && syntax;
}

function forEach() {

    try {
        var supportsForEach = false;
        var arr = ['a', 'b', 'c'];

        arr.forEach(function callback(element) {
            var b = element + " ";
        });
        supportsForEach = true;
    }
    catch (ex) { }
    return supportsForEach;
}

So now run this console command

c:\Windows\SysWOW64\cscript.exe test.js

The console command generates the output below showing cscript.exe is limited to ES3.

Microsoft (R) Windows Script Host Version 5.812
Copyright (C) Microsoft Corporation. All rights reserved.

supports ES3:true
supports ES5:false
supports foreach:false

COM - Windows Scripting Components - wrap JScript and VBscript into components callable from VBA

Surprisingly, it is possible to write JScript or VBcript programs and package them into Windows Scripting Components which can be registered as COM components. Here are two examples, one JScript and one VBScript.

Example JScript Component

<?xml version="1.0"?> 
<package>
<component id="ExcelDevelopmentPlatform.JScriptComponent1">
 
<registration 
   description="Example JScript component" 
   progid="ExcelDevelopmentPlatform.JScriptComponent1" 
   version="1.00" 
   classid="{63A7A78A-933C-4BD2-844A-5D78CFC5FB92}"
   remotable="True"> 

</registration> 

<public> 
   <method name="Greet"> 
      <PARAMETER name="s"/> 
   </method> 
   <method name="Sum"> 
      <PARAMETER name="a"/> 
      <PARAMETER name="b"/> 
   </method> 
</public> 
<script language="JScript"> 
<![CDATA[ 

function Greet(s) {
   return ("From JScript Component, hello " + s); 
}

function Sum(a,b) {
   return (a+b);
}

]]> 
</script> 
</component>
</package>

Example VBScript Component

<?xml version="1.0"?> 
<package>
<component id="ExcelDevelopmentPlatform.VBScriptComponent2">

<registration 
   description="Example vbScript component" 
   progid="ExcelDevelopmentPlatform.VBScriptComponent2" 
   version="1.00" 
   classid="{63A7A78A-933C-4BD2-844A-5D78CFC5FB93}"
   remotable="True"> 

  <script language="VBScript">
  <![CDATA[
    '* not strictly necessary but nice to see one can customize the messages
 '* received when registering with regsvr32.exe 
  
    sMyBlog = "See my blog http:\exceldevelopmentplatform.blogspot.com"

'******************************************************************************

    Function Register
        Msgbox "Windows Script Component registered." & vbNewLine & sMyBlog
    End Function

'******************************************************************************

    Function Unregister
        Msgbox  "Windows Script Component unregistered." & vbNewLine & sMyBlog
    End Function

'******************************************************************************

  ]]>
  </script>   
   
   
</registration> 

<public> 
   <method name="Greet"> 
      <PARAMETER name="s"/> 
   </method> 
   <method name="Sum"> 
      <PARAMETER name="a"/> 
      <PARAMETER name="b"/> 
   </method> 
</public> 
<script language="VBScript"> 
<![CDATA[ 

function Greet(s) 
   Greet = ("From VBScript Component, hello " + s)
end function

function Sum(a,b) 
   Sum = (a+b)
end function

]]> 
</script> 
</component>
</package>

Registering the components on the command line

N:JScriptDev>regsvr32 jScriptComponent1.wsc

N:JScriptDev>regsvr32 vbScriptComponent2.wsc

VBA code to create and call the components

Sub TestJScriptComponent1()

    Dim obj As Object
    Set obj = VBA.CreateObject("ExcelDevelopmentPlatform.JScriptComponent1")
    
    Debug.Assert TypeName(obj) = "ExcelDevelopmentPlatform.JScriptComponent1"
    Debug.Print obj.Greet("Simon")
    Debug.Print obj.Sum(3, 4)
End Sub


Sub TestVBScriptComponent2()

    Dim obj As Object
    Set obj = VBA.CreateObject("ExcelDevelopmentPlatform.VBScriptComponent2")
    
    Debug.Assert TypeName(obj) = "ExcelDevelopmentPlatform.VBScriptComponent2"
    Debug.Print obj.Greet("Simon")
    Debug.Print obj.Sum(3, 4)
End Sub

Links

Some useful links given that a lot of the documentation has fallen into disuse.

• MSDN - Creating a Script Component
• Google - wsc windows script component
• Microsoft Technet - Scripting Guide
• MSDN - Windows Script Components - They Get Around
• MSDN - Scripting Clinic
• MSDN - WMI Scripting Primer - Part 3
• MSDN - Scripting Events
• MSDN - Windows Script Host 5.6
• Microsoft Technet - Doctor Scripto's Script Shop_ Windows Script Components Have a COM-ing Effect
• Google Books - Windows Script Host - Tim Hill - Do not place Wscript.Echo statements in a component
• MSDN - WMI Scripting Object Model Diagram

VBA - Querying an IE's javascript namespace

So once you have hold of an IE instance then you can begin to poke around in its namespace :) In the following program we query all the keys of the top level window object and then we show all the keys to jQuery the (near) ubiquitous javascript library. We write a one-line helper function to get jQuery.

Option Explicit

'* Tools->References
'Shell32                Microsoft Shell Controls And Automation         C:\Windows\SysWOW64\shell32.dll
'MSHTML                 Microsoft HTML Object Library                   C:\Windows\SysWOW64\mshtml.tlb
'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 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

Sub Test()

    Dim objIE As Object
    Set objIE = FindInternetExplorer()

    If Not objIE Is Nothing Then

        Dim objWindow As Object
        Set objWindow = objIE.document.parentWindow

        Dim dicWindowKeys As Scripting.Dictionary
        Set dicWindowKeys = New Scripting.Dictionary
        Call SC.Run("enumKeysToMsDict", objWindow, dicWindowKeys)

        Debug.Print vbNewLine & "The window interface " & vbNewLine & Join(dicWindowKeys.Keys, vbTab)

        If dicWindowKeys.Exists("jQuery") Then

            Dim objJQuery As Object
            Set objJQuery = SC.Run("getjQuery", objWindow)

            Dim dicJQueryKeys As Scripting.Dictionary
            Set dicJQueryKeys = New Scripting.Dictionary
            Call SC.Run("enumKeysToMsDict", objJQuery, dicJQueryKeys)

            Debug.Print vbNewLine & "The jQuery interface " & vbNewLine & Join(dicJQueryKeys.Keys, vbTab)


        End If



        Stop


    End If

End Sub



Private Function FindInternetExplorer(Optional sMatchURL As String)

    Dim oShell As Shell32.Shell
    Set oShell = New Shell32.Shell

    Dim wins As Object 'Shell32.Windows
    Set wins = oShell.Windows

    Dim winLoop As Variant
    For Each winLoop In oShell.Windows
        If "C:\Program Files (x86)\Internet Explorer\IEXPLORE.EXE" = winLoop.FullName Then

            Dim oApp As Object
            Set oApp = winLoop.Application
            If oApp.Visible = False Then
                '* why have invisible IE lying around, must have hung, get rid
                oApp.Quit
            End If
            If Len(sMatchURL) > 0 Then
                If sMatchURL = winLoop.LocationURL Then

                    Set FindInternetExplorer = winLoop.Application
                    Exit Function

                End If
            Else
                '* we're not fussy, return the first one and exit
                Set FindInternetExplorer = winLoop.Application
                Exit Function
            End If

        End If

    Next

End Function

VBA - Find all Internet Explorer instances by iterating through shell windows

Previously I moaned about how IE cannot be found using the IAccessible trick, well no matter because actually they can be found by iterating through the shell windows collection. Here is the code.

Option Explicit

'* Tools->References
'Shell32        Microsoft Shell Controls And Automation         C:\Windows\SysWOW64\shell32.dll


Private Sub EnumerateInternetExplorers()

    Dim oShell As Shell32.Shell
    Set oShell = New Shell32.Shell
    
    Dim wins As Object 'Shell32.Windows
    Set wins = oShell.Windows

    Dim winLoop As Variant
    For Each winLoop In oShell.Windows
        If "C:\Program Files (x86)\Internet Explorer\IEXPLORE.EXE" = winLoop.FullName Then
            
            Dim oApp As Object
            Set oApp = winLoop.Application
            If oApp.Visible = False Then
                '* why have invisible IE lying around, must have hung, get rid
                oApp.Quit
            End If
            Debug.Print winLoop.LocationName, winLoop.LocationURL
                
        End If
            
    Next

End Sub

WinAPI - Querying for IAccessible on Internet Explorer yields nothing!

So after the experiment of querying every window handle owned by Excel for scriptable objects I decided to do the same for Internet Explorer. I wanted this because whilst one can create a new instance of IE I've seen the connection between IE and its calling code break down. I figured that just as there is code that can reconnect with all running Excel instances that we could do the same for IE. Well, IE doesn't allow this, at least not via this route.

This does not mean to say we cannot at all drive IE via the IAccessible interface, simply that we cannot write VBA to control it via this channel. At some point I'll return to figure out how to select a tab from a selection using IAccessible.

Dumping the code here before showing an alternative in a future post.

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
'SHDocVw                Microsoft Internet Controls                     C:\Windows\SysWOW64\ieframe.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 Sub StartIE()
    Dim oIE As SHDocVw.InternetExplorerMedium
    Set oIE = New SHDocVw.InternetExplorerMedium
    
    oIE.Visible = True
    oIE.navigate "https://stackoverflow.com/questions/tagged/vba"

    Set oIE = Nothing '* sever , let it hang around!

End Sub

Private Function GetAccessibleIEObjects() As Scripting.Dictionary

    '* Do you have an instance of IE hanging around?
    Stop

    Dim dicHandles As Scripting.Dictionary
    Set dicHandles = GetWindows("IEFRAME", 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 dicAccessibleIEObjects As Scripting.Dictionary
    Set dicAccessibleIEObjects = 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)
            dicAccessibleIEObjects.Add hWnd, itf
        ElseIf lReturnIDisp = 0 Then
            Debug.Print PadHex(hWnd), TypeName(obj)
            dicAccessibleIEObjects.Add hWnd, obj
        Else
           
        End If
        Set obj = Nothing
    Next

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.Activate
        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

VBA - Excel table to HTML

Just a little routine to help me write these articles. Given an Excel range it will generate the HTML for a table with some subtle (i.e grey) styling.

Option Explicit

Function MarkupTable(ByVal rng As Excel.Range)

    Dim s As String
    s = "<table style='border: 1px solid lightgrey;'>"
    
    Dim rngRowLoop As Excel.Range
    For Each rngRowLoop In rng.Rows
        s = s & "<tr>"
    
        Dim rngCellLoop As Excel.Range
        For Each rngCellLoop In rngRowLoop.Cells
        
            s = s & "<td style='border: 1px solid lightgrey;'>" & rngCellLoop.Value2 & "</td>"
        
        Next rngCellLoop
    
    
        s = s & "</tr>"
    Next
    

    s = s & "</table>"

    MarkupTable = s

End Function

Sub TestMarkupTable()
    Debug.Print MarkupTable(ActiveCell.CurrentRegion)
End Sub

sample

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

WinAPI - Use IAccessible interfaces to look for scriptable Excel objects

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

Javascript - Add Objects via ScriptControl to the JScript namespace

So now we have the development environment sorted we can make better progress with Javascript and Excel interoperability. Let's review the sample code from previous post.

To explain, the Javascript simply defines a switchboard of an output() function which detects its environment. If running in an HTML page then the window object would be defined and the alert() method can be called. If running from cscript.exe then the WScript object would be defined and the echo() method can be called. The final two clauses are very interesting, they are for Word and Excel; the calling code can inject Excel (or Word) objects into JScript's namespace and make them accessible to the javascript code. We can then call into functions defined in ThisWorkbook (or ThisDocument for Word). This means JScript can do callbacks!

The line of code to inject ThisWorkbook (or ThisDocument) is simple, where soSC is an instance of ScriptControl, see full code below for context.

soSC.AddObject "ThisWorkbook", ThisWorkbook

Once injected it should be accessible in javascript with this.ThisWorkbook, we use a cryptic javascript pattern to test to see if it is defined with

    if (typeof this.ThisWorkbook != 'undefined') {

One could even pass in instances of classes you have defined. Note that such injected objects cannot be reached by cscript.exe unless one uses the RunningObjectTable to publish the objects machine wide.

Running the function RunGreet() with F5 should call into the javascript which should call back into the ThisWorkbook module. Pretty damn clever, huh? Enjoy!

The Javascript is as following

// * the following will run if using cscript.exe
Greet("to you")

function Greet(a) {
    output("Hi, " + a);
}

function output(str) {
    if (typeof this.window != 'undefined') {
        this.window.alert(str);
    }

    if (typeof this.WScript != 'undefined') {
        /* this will run if you ran from cscript.exe */
        WScript.echo(str);
    }

    if (typeof this.ThisDocument != 'undefined') {
        /* For Word VBA projects 
           this will run if you ran a ScriptControl instance (C:\Windows\SysWOW64\msscript.ocx) 
           and you ran ScriptControl.AddObject "ThisDocument", ThisDocument
           and within ThisDocument you defined "Public Function VBAOutput(str): Debug.Print str: End Function"  */
        ThisDocument.VBAOutput(str);
    }

    if (typeof this.ThisWorkbook != 'undefined') {
        /* For Excel VBA projects 
           this will run if you ran a ScriptControl instance (C:\Windows\SysWOW64\msscript.ocx) 
           and you ran ScriptControl.AddObject "ThisWorkbook", ThisWorkbook
           and within ThisWorkbook you defined "Public Function VBAOutput(str): Debug.Print str: End Function"  */
        ThisWorkbook.VBAOutput(str);
    }
}

And in an Excel workbook add the following to a standard module see below and also some code to the ThisWorkbook module see

Option Explicit

'* Tools->References
'MSScriptControl        Microsoft Script Control 1.0        C:\Windows\SysWOW64\msscript.ocx
'Scripting              Microsoft Scripting Runtime         C:\Windows\SysWOW64\scrrun.dll


Private mfso As New Scripting.FileSystemObject

Private Function SC() As ScriptControl
    Static soSC As ScriptControl
    'If soSC Is Nothing Then


        Set soSC = New ScriptControl
        soSC.Language = "JScript"

        soSC.AddCode ReadFileToString("N:\JScriptDev\Solution1\test.js")
        
        soSC.AddObject "ThisWorkbook", ThisWorkbook
    'End If
    Set SC = soSC
End Function

Private Sub RunGreet()
    Call SC.Run("Greet", "Tim")
End Sub


Private Sub TestReadFileToString()
    Dim s As String
    s = ReadFileToString("N:\JSONPath\test.js")
End Sub

Public Function ReadFileToString(ByVal sFilePath As String) As String
    If mfso.FileExists(sFilePath) Then
        ReadFileToString = mfso.OpenTextFile(sFilePath).ReadAll
    End If
End Function

And finally the code for ThisWorkbook

Option Explicit

Public Function VBAOutput(str)
    Debug.Print "From ThisWorkbook: " & str
End Function

Javascript - Use Visual Studio to write and VBA to run JScript

Ok, so using the ScriptControl is a major pain if you are adding in your code as text strings such as the following one-liners

        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 "function subString(sExpr, lStart, lEnd) {  return sExpr.substring(lStart, lEnd) ;}"
        soSC.AddCode "function indexOf(sExpr,searchvalue, start) {  return sExpr.indexOf(searchvalue, start) ;}"

        soSC.AddCode "function CountLeftBrackets(sExpr) {  return sExpr.split('[').length-1 ;}"
        soSC.AddCode "function CountRightBrackets(sExpr) {  return sExpr.split(']').length-1 ;}"

Any double quotes are best changed to single quotes. Each of the lines above fits on one line and so it is not so difficult to add the correct bracketing. But imagine a program full of functions like the following

        soSC.AddCode "function ValidSquareBrackets(sExpr) {" & _
                "   var lCountLeftBrackets = CountLeftBrackets(sExpr); var lCountRightBrackets = CountRightBrackets(sExpr);" & _
                "   if (lCountLeftBrackets!==lCountRightBrackets)  { return -1; } else {" & _
                "         if (lCountLeftBrackets===0 || lCountRightBrackets===1) { return lCountLeftBrackets;} else { return -1;}" & _
                "   }}"
        
        
        soSC.AddCode "function ValidSquareBracketsForPath(sPath) {" & _
                "    var vSplit=sPath.split('.');  var bAllPathSgementsAreValid=true;" & _
                "    for (i = 0; i < vSplit.length; i++) {" & _
                "        var vSplitLoop=vSplit[i];" & _
                "        var lMatchedBracketCount = ValidSquareBrackets(vSplitLoop);" & _
                "        var bValid = (lMatchedBracketCount === 0 || lMatchedBracketCount === 1);" & _
                "        bAllPathSgementsAreValid =  bAllPathSgementsAreValid && bValid;" & _
                "    }" & _
                "    return bAllPathSgementsAreValid;" & _
                "}"

This very quickly gets painful. So ideally we would use Visual Studio to write the Javascript file, debug also in VS and then finally test the code on the ScriptControl because VS2017 will be running a later version of Javascript (Ecmascript 6) whereas I believe the ScriptControl only runs Ecmascript v.3. Once the code is finalised then instead of hard coding in strings we can simply read in the code from a file thus.

Option Explicit

'* Tools->References
'MSScriptControl        Microsoft Script Control 1.0        C:\Windows\SysWOW64\msscript.ocx
'Scripting              Microsoft Scripting Runtime         C:\Windows\SysWOW64\scrrun.dll


Private mfso As New Scripting.FileSystemObject

Private Function SC() As ScriptControl
    Static soSC As ScriptControl
    'If soSC Is Nothing Then


        Set soSC = New ScriptControl
        soSC.Language = "JScript"

        soSC.AddCode ReadFileToString("N:\JScriptDev\Solution1\test.js")
        
        soSC.AddObject "ThisDocument", ThisDocument
    'End If
    Set SC = soSC
End Function

Private Sub RunGreet()
    Call SC.Run("Greet", "Tim")
End Sub


Private Sub TestReadFileToString()
    Dim s As String
    s = ReadFileToString("N:\JSONPath\test.js")
End Sub

Public Function ReadFileToString(ByVal sFilePath As String) As String
    If mfso.FileExists(sFilePath) Then
        ReadFileToString = mfso.OpenTextFile(sFilePath).ReadAll
    End If
End Function

However, we need to pull a couple of tricks on the Visual Studio side. First one needs to create a blank solution, somebody helpful has answered how to do this on StackOverflow. Then add your javascript such as the following

// * the following will run if using cscript.exe
Greet("to you")

function Greet(a) {
    output("Hi, " + a);
}

function output(str) {
    if (typeof this.window != 'undefined') {
        this.window.alert(str);
    }

    if (typeof this.WScript != 'undefined') {
        /* this will run if you ran from cscript.exe */
        WScript.echo(str);
    }

    if (typeof this.ThisDocument != 'undefined') {
        /* For Word VBA projects 
           this will run if you ran a ScriptControl instance (C:\Windows\SysWOW64\msscript.ocx) 
           and you ran ScriptControl.AddObject "ThisDocument", ThisDocument
           and within ThisDocument you defined "Public Function VBAOutput(str): Debug.Print str: End Function"  */
        ThisDocument.VBAOutput(str);
    }

    if (typeof this.ThisWorkbook != 'undefined') {
        /* For Excel VBA projects 
           this will run if you ran a ScriptControl instance (C:\Windows\SysWOW64\msscript.ocx) 
           and you ran ScriptControl.AddObject "ThisWorkbook", ThisWorkbook
           and within ThisWorkbook you defined "Public Function VBAOutput(str): Debug.Print str: End Function"  */
        ThisWorkbook.VBAOutput(str);
    }
}

Your VS should look something like the following

The second trick is to define a custom "External Tool" by taking the Visual Studio menu Tools->External Tools... and then populate the dialog as per the screenshot below.

So now when you have your javascript file in view and you take the menu 'Tools->Cscript Debug' then it will run cscript.exe for your file and you will get a 'Choose Just-In-Time Debugger' dialog like this

Select the current session of VS, i.e. same session as your javascript file, and then click OK. This will drop you into the first set breakpoint and will look something like the following.

So now you can enjoy the powerful debugging features of Visual Studio 2017, and remember Community Edition is free.

PowerQuery (M) to drill into Google Sheets API v.3 and extract sheet name and link url

So I am indebted to a fellow StackOverflow citizen who helped me over a Power Query problem. Powerquery looks like a great technology and has been in Excel since 2013 edition but not VBA scriptable until 2016 edition. I especially like the ability to drill into JSON documents and extract information. But I find Powerquery's syntax challenging and clealy I have yet to master it.

The use case in hand is calling the Google Sheets API (version 3, I know I should move to version 4) to get the 'master' details of a Google sheets workbook and then drill in to find the sheet details. Amongst the sheet details are the sheet name and the url of the sheet data itself. I have tidied an example structure and it is given below. The sheet name is at feed.entry[x].title.$t whilst the url for the sheet data is at feed.entry[x].link[y].href where x increments and y is 0.

{ ""feed"": {""entry"": [ 
  {     ""title"": { ""$t"": ""1 Med"" },     ""link"": [ { ""href"": 
""https//removed1...."" } ]   }, 
  {     ""title"": { ""$t"": ""2 Dent"" },     ""link"": [ { ""href"": 
""https//removed2...."" } ]   }, 
  {     ""title"": { ""$t"": ""3 Vet"" },     ""link"": [  { ""href"": 
""https//removed3...."" }]   }
] } }

Powerquery is orientated towards outputting data onto a grid of cells. I asked for a query to give the sheet name and url for each of the three sheets, yielding a 3 row 2 column matrix. So, my thanks to Mike Honey who gave a correct working answer

let
    Source = Json.Document("{ ""feed"": {""entry"": [
  {     ""title"": { ""$t"": ""1 Med"" },     ""link"": [ { ""href"": ""https//removed1...."" } ]   },
  {     ""title"": { ""$t"": ""2 Dent"" },     ""link"": [ { ""href"": ""https//removed2...."" } ]   },
  {     ""title"": { ""$t"": ""3 Vet"" },     ""link"": [  { ""href"": ""https//removed3...."" }]   }
] } }"),
    feed = Source[feed],
    entry = feed[entry],
    #"Converted to Table" = Table.FromList(entry, Splitter.SplitByNothing(), null, null, ExtraValues.Error),
    #"Expanded Column2" = Table.ExpandRecordColumn(#"Converted to Table", "Column1", {"title", "link"}, {"title", "link"}),
    #"Expanded title1" = Table.ExpandRecordColumn(#"Expanded Column2", "title", {"$t"}, {"$t"}),
    #"Expanded link" = Table.ExpandListColumn(#"Expanded title1", "link"),
    #"Expanded link1" = Table.ExpandRecordColumn(#"Expanded link", "link", {"href"}, {"href"})
in
    #"Expanded link1"

Here is the output

1 Med	https//removed1
2 Dent	https//removed2
3 Vet	https//removed3

I would like to be able to compete with PowerQuery in regards to a declarative technology that avoids stepping through using CallByName on JScriptTypeInfo.

Over the course of the weekend I wrote some VBA to implement a declarative syntax and then I rewrote it in Javascript. The results work but I am not happy with this code and would like to get the jsonpath library to work in the ScriptControl. Nevertheless, depositing the code here to pick up later.

Option Explicit
Option Private Module

Private mvMyAdviceToCaller As Variant


'* module name:     modJSONPath
'* module type:     standard
'* purpose:         parses, traverses JSON document using JScript in Microsoft's Script Control
'* Version:         0.01
'* Date:            19 Jan 2018  20:19
'* Author:          Simon Meaden, Sevenoaks, England
'* Other credits:   Douglas Crockford: JSON.parse and JSON.stringify routines
'* TODO:            speed up JSONPath by not checking for objects , requires shipping an option to optomise
'*                  consider how much of this VBA can in fact be run in scripting control with standard javascript!




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


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 Function JsonPathSC() As ScriptControl
    Set JsonPathSC = SC
End Function



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 subString(sExpr, lStart, lEnd) {  return sExpr.substring(lStart, lEnd) ;}"
        soSC.AddCode "function indexOf(sExpr,searchvalue, start) {  return sExpr.indexOf(searchvalue, start) ;}"
        
        
        soSC.AddCode "function CountLeftBrackets(sExpr) {  return sExpr.split('[').length-1 ;}"
        soSC.AddCode "function CountRightBrackets(sExpr) {  return sExpr.split(']').length-1 ;}"

        
        soSC.AddCode "function ValidSquareBrackets(sExpr) {" & _
                "   var lCountLeftBrackets = CountLeftBrackets(sExpr); var lCountRightBrackets = CountRightBrackets(sExpr);" & _
                "   if (lCountLeftBrackets!==lCountRightBrackets)  { return -1; } else {" & _
                "         if (lCountLeftBrackets===0 || lCountRightBrackets===1) { return lCountLeftBrackets;} else { return -1;}" & _
                "   }}"
        
        
        soSC.AddCode "function ValidSquareBracketsForPath(sPath) {" & _
                "    var vSplit=sPath.split('.');  var bAllPathSgementsAreValid=true;" & _
                "    for (i = 0; i < vSplit.length; i++) {" & _
                "        var vSplitLoop=vSplit[i];" & _
                "        var lMatchedBracketCount = ValidSquareBrackets(vSplitLoop);" & _
                "        var bValid = (lMatchedBracketCount === 0 || lMatchedBracketCount === 1);" & _
                "        bAllPathSgementsAreValid =  bAllPathSgementsAreValid && bValid;" & _
                "    }" & _
                "    return bAllPathSgementsAreValid;" & _
                "}"
                
        soSC.AddCode "function HasSquareBrackets(sExpr) { return (ValidSquareBrackets(sExpr) === 1); }"

        soSC.AddCode "function ExtractSquareBrackets(sExpr) {" & _
                "   if (HasSquareBrackets(sExpr)===true) {" & _
                "        if (sExpr.substring(0,1)==='[') {" & _
                "            if (sExpr.substring(sExpr.length-1, sExpr.length)===']') {" & _
                "                return sExpr.substring(1, sExpr.length-1); " & _
                "            }" & _
                "        }" & _
                "   } else { return sExpr ; } " & _
                "}"


        soSC.AddCode "function LeftSquareIsMissingAdjacentPeriod(sJSONPath , lLeftSquareBracket) {" & _
                "    if (lLeftSquareBracket===1) { return true; } else { " & _
                "        var sOnMyLeft = sJSONPath.substring(lLeftSquareBracket,lLeftSquareBracket+1); " & _
                "        return (sOnMyLeft!=='.'); " & _
                "    }" & _
                "}"

        soSC.AddCode "function CharAndPrevChar(sJSONPath , lCharAt) {" & _
                "    if (lCharAt===1) {" & _
                "        return sJSONPath.substring(0,1); } else {" & _
                "        return (sJSONPath.substring(lCharAt-2,lCharAt));" & _
                "    }" & _
                "}"
        
        soSC.AddCode "function CheckCharAndPrevChar( sCharAndPrevChar ) {" & _
                "    if (sCharAndPrevChar.length===1) {" & _
                "        return (sCharAndPrevChar === '[')  ; } else {" & _
                "        return (sCharAndPrevChar === '.[') ;" & _
                "    }" & _
                "}"
        
        soSC.AddCode "function GetNextLeftSquareBracket ( sJSONPath , lStart ) {" & _
                "    return (sJSONPath.indexOf('[',lStart-1)+1); } "
    
        
        soSC.AddCode "function JSONPathNeedsPeriodising(sJSONPath) {" & _
                "   var lLeftSquareBracket=GetNextLeftSquareBracket(sJSONPath,1); " & _
                "   while (lLeftSquareBracket>1) {  " & _
                "       var sCharPrevChar = CharAndPrevChar(sJSONPath, lLeftSquareBracket);  " & _
                "       if (!CheckCharAndPrevChar ( sCharPrevChar) ) {  " & _
                "           return true; " & _
                "       }  " & _
                "       lLeftSquareBracket=GetNextLeftSquareBracket(sJSONPath,lLeftSquareBracket + 1); " & _
                "   }" & _
                "   return false;" & _
                "}"
        
        soSC.AddCode "function IsErrorMessage ( sExpr ) {" & _
                "    var lLen = sExpr.length;" & _
                "    return ((sExpr.substring( 0, 1) === '#') && (sExpr.substring( lLen - 1, lLen) === '!'));" & _
                "}"

        soSC.AddCode "function InsertPeriodBeforeLeftSquareBracket(sJSONPath) {  return sJSONPath.replace( /\[/g , '.['); }"


        soSC.AddCode "function RemoveDoublePeriods(sJSONPath) {" & _
                "    while (sJSONPath.indexOf( '..', 1) > -1) {" & _
                "        sJSONPath=sJSONPath.replace('..','.');" & _
                "    }" & _
                "    return sJSONPath;" & _
                "}"


        soSC.AddCode "function JSONPathPeriodiseSquareBrackets(sJSONPath) {" & _
                    "    if (JSONPathNeedsPeriodising(sJSONPath)===true) {" & _
                    "        if (ValidSquareBracketsForPath(sJSONPath)===true) { " & _
                    "            var sWork = InsertPeriodBeforeLeftSquareBracket(sJSONPath); " & _
                    "            while (sWork.indexOf( '..', 1) > -1) { " & _
                    "                sWork = RemoveDoublePeriods( sWork); " & _
                    "            } " & _
                    "            return sWork; " & _
                    "        } " & _
                    "        else " & _
                    "        { return '#Bad path, please check, mismatched square brackets?!' " & _
                    "        } " & _
                    "    } " & _
                    "    else " & _
                    "    { return sJSONPath; " & _
                    "    } " & _
                    "} "
    
        soSC.AddCode "function segmentCount(sExpr) { if (sExpr==='') { return 0;} else {return (sExpr.split('.')).length;} }"

        soSC.AddCode "function firstSegment(sPath) { var vSplit = sPath.split('.'); if (vSplit.length===1) { return sPath; } else { return vSplit[0]; } }"

        soSC.AddCode "function eatFirstSegment(sPath) { var vSplit = sPath.split('.'); if (vSplit.length===1) { return ''; } else { vSplit[0]='';  var rejoined = vSplit.join('.');  return rejoined.substring(1,rejoined.length); } }"
    
        soSC.AddCode "function JSONParsePath(sJSONPath) { " & _
                    "    var objReturn = JSON_parse('{}');  " & _
                    "    var sFirst = firstSegment(sJSONPath);" & _
                    "    objReturn.lCount=segmentCount(sJSONPath);" & _
                    "    objReturn.sNewPath=eatFirstSegment(sJSONPath);" & _
                    "    objReturn.sFirst=ExtractSquareBrackets(sFirst);" & _
                    "    return objReturn;" & _
                    " }"

        soSC.AddCode "function IsNothing(objStart ) {  return (!objStart || objStart === 'null' || objStart === 'undefined');}"
        

        soSC.AddCode "function JSONPathCheckParams(objStart , sJSONPath ) {  " & _
                    "    if (IsNothing(objStart)) { return '#Null objStart!' ;}" & _
                    "    if (sJSONPath.length===0) { return '#Null sJSONPath!' ;}" & _
                    "    return JSONPathPeriodiseSquareBrackets(sJSONPath);}"

        soSC.AddCode "function JSONPath(objStart, sJSONPath, bCheckParams) { " & _
                    "     if (bCheckParams===true) { sJSONPath  = JSONPathCheckParams(objStart, sJSONPath) ; }" & _
                    "     if (IsErrorMessage(sJSONPath)===true) { return sJSONPath ; }" & _
                    "     var objPathParsed = JSONParsePath(sJSONPath) ; " & _
                    "     if (objStart.hasOwnProperty(objPathParsed.sFirst)===true) { " & _
                    "         var first = objStart[objPathParsed.sFirst] ;" & _
                    "         if ((objPathParsed.lCount)> 1) { return JSONPath(first, objPathParsed.sNewPath, false) ; } else { return first ;} " & _
                    "     } else if ((objPathParsed.sFirst === '*')) {" & _
                    "         if (objStart.hasOwnProperty('length')===true) { " & _
                    "             var objJSArray=JSON.parse('[]');" & _
                    "             var lLength = objStart.length ; " & _
                    "             for (lArrayLoop=0  ; lArrayLoop< lLength ; lArrayLoop++ ) { " & _
                    "                 var first2 = objStart[lArrayLoop] ;" & _
                    "                 if ((objPathParsed.lCount)> 1) { " & _
                    "                     objJSArray.push(JSONPath(first2, objPathParsed.sNewPath, false)) ; " & _
                    "                 } else " & _
                    "                 { objJSArray.push(first2) ;}" & _
                    "             }" & _
                    "             return objJSArray;" & _
                    "         } else { return ('#Bad path \'' + sJSONPath + '\' , wildcard expression implies array but array length not found!') } " & _
                    "     }" & _
                    "     else {" & _
                    "         return ('#Bad path \'' + sJSONPath + '\'!')" & _
                    "     }" & _
                    " }"

        soSC.AddCode "function isObject(o) { if(IsNothing(o)===true) { return false; } else { return o instanceof Object && o.constructor === Object; }} "
    
        'soSC.AddCode "function myConstructor(o) { return JSON.stringify(o.constructor) ;  } "


        soSC.AddCode "function isArray(obj) { return Object.prototype.toString.call(obj) === '[object Array]'; } "
    
        soSC.AddCode "function ArrayOfLiteralsUpgradeToObjects(objArray,sLiteralsProperyName) {  " & _
                    "    if (isArray(objArray) ) { " & _
                    "        var objNewArray = JSON.parse('[]');" & _
                    "        for (lLoop=0; lLoop < objArray.length; lLoop++) {" & _
                    "            var ele = objArray[lLoop];" & _
                    "            if (isObject(ele)===false) { throw new Error('#Expecting array of literals but bumped into object \'' + JSON.stringify(ele) + '\' !') ; } " & _
                    "            if (isArray(ele)===false) { throw new Error('#Expecting array of literals but bumped into sub array \'' + JSON.stringify(ele) + '\' !') ; } " & _
                    "        } " & _
                    "    } " & _
                    "} "
    
        soSC.AddCode "function TypeObjectByStringification(obj) { " & _
                    "    /* return 2 for object, 1 for array, 0 for anything else */ " & _
                    "    var obj2 = JSON.stringify(obj);  " & _
                    "    if (obj2.length<2 ) { return 0; } " & _
                    "    var firstCh = obj2.substring(0,1);" & _
                    "    var lastCh = obj2.substring(obj2.length-1,obj2.length);" & _
                    "    if (firstCh=='[' &&  lastCh==']' ){ return 1; }" & _
                    "    if (firstCh=='{' &&  lastCh=='}' ){ return 2; }" & _
                    "    return 0;" & _
                    "}"
    
        
        

        soSC.AddCode "function upgradeToObject (v, propName) { " & _
                    "    if (TypeObjectByStringification(v)==2) { throw new Error('#Already an object!'); } " & _
                    "        var propName2 = 'dummy' +  propName;" & _
                    "        if (propName2.length>5) { var propNameLen = propName2.length-5;  propName2=propName2.substring(propName2.length-propNameLen,propName2.length); } " & _
                    "        var oRet = {};" & _
                    "        oRet[propName2] = v;" & _
                    "        return oRet;" & _
                    "    } "

        soSC.AddCode "function upgradeArrayElementsToObject (arr, propName) { " & _
                    "    if (TypeObjectByStringification(arr)!=1) { throw new Error('#Expecting an array!'); } " & _
                    "    var newArr = JSON.parse('[]'); " & _
                    "    " & _
                    "    for (lLoop=0 ; lLoop < arr.length; lLoop++) { " & _
                    "        var ele = arr[lLoop]; " & _
                    "        if (TypeObjectByStringification(ele)!=2) { " & _
                    "            newArr.push (upgradeToObject(ele, propName)) ; " & _
                    "        } else { " & _
                    "            newArr.push (JSON.parse(JSON.stringify(obj))); " & _
                    "        } " & _
                    "    } " & _
                    "    return newArr; " & _
                    " } "

        soSC.AddCode "function mergeObjects(obj1, obj2) { " & _
                    "    if (TypeObjectByStringification(obj1)!=2) { throw new Error('#Expecting obj1 to an object!'); } " & _
                    "    if (TypeObjectByStringification(obj2)!=2) { throw new Error('#Expecting obj2 to an object!'); } " & _
                    "    var objMerged = JSON.parse(JSON.stringify(obj1)); " & _
                    "    for (var i in obj2) { " & _
                    "        objMerged[i] = JSON.parse(JSON.stringify(obj2[i])); " & _
                    "    }  " & _
                    "    return objMerged;  " & _
                    " } "

        soSC.AddCode "function mergeEachObjectInArrays(arr1, arr2) { " & _
                    "    if (TypeObjectByStringification(arr1)!=1) { throw new Error('#Expecting arr1 to an object!'); } " & _
                    "    if (TypeObjectByStringification(arr2)!=1) { throw new Error('#Expecting arr2 to an object!'); } " & _
                    "    if (arr1.length!=arr2.length)  { throw new Error('#Arrays have different lengths!'); } " & _
                    "    var newArray= JSON.parse('[]'); " & _
                    "    for (lLoop=0 ; lLoop 1 Then
                
                Dim bSubReturnIsObject As Boolean
                bSubReturnIsObject = IsObject(JSONPath(objFirst, sNewPath, False))
                If bSubReturnIsObject Then
                    Set JSONPath = JSONPath(objFirst, sNewPath, False)
                Else
                    JSONPath = JSONPath(objFirst, sNewPath, False)
                End If
            Else
                
                Set JSONPath = objFirst
            End If
        Else
            Debug.Assert lCount = 1
            JSONPath = VBA.CallByName(objStart, sFirst, VbGet)
        End If
    
    ElseIf sFirst = "*" Then
        '* we have a wildcard
        If objStart.hasOwnProperty("length") Then
            Dim lLength As Long
            lLength = CallByName(objStart, "length", VbGet)

            Dim objJSArray As Object
            Set objJSArray = SC.Run("JSON_parse", "[]")
            
            Dim lArrayLoop As Long
            For lArrayLoop = 0 To lLength - 1
            
                Set objFirst = VBA.CallByName(objStart, CStr(lArrayLoop), VbGet)
                If lCount > 1 Then
                    Call CallByName(objJSArray, "push", VbMethod, JSONPath(objFirst, sNewPath, False))
                Else
                    Call CallByName(objJSArray, "push", VbMethod, objFirst)
                End If
    
            Next
            Set JSONPath = objJSArray

        End If
    Else
        Stop 'not yet handled
    End If
    #Else
    
    
    If TypeName(SC.Run("JSONPath", objStart, sJSONPath, bCheckParams)) = "JScriptTypeInfo" Then
        Set JSONPath = SC.Run("JSONPath", objStart, sJSONPath, bCheckParams)
    Else
        JSONPath = SC.Run("JSONPath", objStart, sJSONPath, bCheckParams)
    End If
    #End If
    

    
    
'    If VBA.IsObject(JSONPath) Then
'        mvMyAdviceToCaller = "JSONPath(" & sJSONPath & "):Caller needs to use Set"
'    Else
'        mvMyAdviceToCaller = "JSONPath(" & sJSONPath & "):Caller needs to not use Set"
'    End If
'
'    If Not bDoNotPrintAdviceToCaller Then
'        Debug.Print mvMyAdviceToCaller
'    End If

End Function


Public Function JSONPathPeriodiseSquareBrackets(ByVal sJSONPath As String) As String
    'function JSONPathPeriodiseSquareBrackets(sJSONPath) {
    '    if (JSONPathNeedsPeriodising(sJSONPath)===true) {
    '        if (ValidSquareBracketsForPath(sJSONPath)===true) {
    '            var sWork = InsertPeriodBeforeLeftSquareBracket(sJSONPath);
    '            while (sWork.indexOf( "..", 1) > -1) {
    '                sWork = RemoveDoublePeriods( sWork);
    '            }
    '            return sWork;
    '        }
    '        else
    '        { return '#Bad path, please check, mismatched square brackets?!'
    '        }
    '    }
    '    else
    '    { return sJSONPath;
    '    }
    '}
    
    #If USEVBA Then
    If JSONPathNeedsPeriodising(sJSONPath) Then
        If ValidSquareBracketsForPath(sJSONPath) Then
            
            JSONPathPeriodiseSquareBrackets = InsertPeriodBeforeLeftSquareBracket(sJSONPath)
            
            
            Do While IndexOf(JSONPathPeriodiseSquareBrackets, "..", 1) > -1
            
                DoEvents
                JSONPathPeriodiseSquareBrackets = RemoveDoublePeriods(JSONPathPeriodiseSquareBrackets)
            Loop
            
            Debug.Assert IndexOf(JSONPathPeriodiseSquareBrackets, "..", 1) = -1
            
        Else
            JSONPathPeriodiseSquareBrackets = "#Bad path, please check, mismatched square brackets?!"
            
        End If
    Else
        JSONPathPeriodiseSquareBrackets = sJSONPath
    End If
    #Else
    JSONPathPeriodiseSquareBrackets = SC.Run("JSONPathPeriodiseSquareBrackets", sJSONPath)
    #End If

End Function


Public Function RemoveDoublePeriods(ByVal sJSONPath As String) As String

    'function RemoveDoublePeriods(sJSONPath) {
    '    while (sJSONPath.indexOf( '..', 1) > -1) {
    '        sJSONPath.replace('..','.');
    '    }
    '    return sJSONPath;
    '}

    #If USEVBA Then
    
    Do While IndexOf(sJSONPath, "..", 1) > -1
    
        DoEvents
        sJSONPath = VBA.Replace(sJSONPath, "..", ".")
    Loop
    RemoveDoublePeriods = sJSONPath
    #Else
    RemoveDoublePeriods = SC.Run("RemoveDoublePeriods", sJSONPath)
    #End If
End Function

Public Function InsertPeriodBeforeLeftSquareBracket(ByVal sJSONPath As String) As String
    'function InsertPeriodBeforeLeftSquareBracket(sJSONPath) {  return sJSONPath.replace( '[' , '.['); }
    
    
    #If USEVBA Then
    InsertPeriodBeforeLeftSquareBracket = VBA.Replace(sJSONPath, "[", ".[")
    #Else
    InsertPeriodBeforeLeftSquareBracket = SC.Run("InsertPeriodBeforeLeftSquareBracket", sJSONPath)
    #End If

End Function



Public Function SubString(ByVal sExpr As String, ByVal lStart As Long, ByVal lEnd As Long)
    SubString = SC.Run("subString", sExpr, lStart, lEnd)
End Function


Public Function IndexOf(ByVal sExpr As String, ByVal sSearchvalue As String, lStart As Long)
    IndexOf = SC.Run("indexOf", sExpr, sSearchvalue, lStart)
End Function


Public Function JSONPathNeedsPeriodising(ByVal sJSONPath As String) As Boolean
    'function JSONPathNeedsPeriodising(sJSONPath) {
    '   var lLeftSquareBracket=GetNextLeftSquareBracket(sJSONPath,1);
    '   while (lLeftSquareBracket>1) {
    '       var sCharPrevChar = CharAndPrevChar(sJSONPath, lLeftSquareBracket)
    '       if (!CheckCharAndPrevChar ( sCharPrevChar) ) {
    '           return true;
    '       }
    '       lLeftSquareBracket=GetNextLeftSquareBracket(sJSONPath,lLeftSquareBracket + 1);
    '   }
    '   return false;
    '}


    #If USEVBA Then
    
    Dim lLeftSquareBracket As Long
    lLeftSquareBracket = GetNextLeftSquareBracket(sJSONPath, 1)
    
    Do While lLeftSquareBracket > 1
        DoEvents
        Dim sCharPrevChar As String
        sCharPrevChar = CharAndPrevChar(sJSONPath, lLeftSquareBracket)
        
        If Not CheckCharAndPrevChar(sCharPrevChar) Then
            JSONPathNeedsPeriodising = True
            Exit Function
        End If
        lLeftSquareBracket = GetNextLeftSquareBracket(sJSONPath, lLeftSquareBracket + 1)
    
    Loop
    
    #Else
    JSONPathNeedsPeriodising = SC.Run("JSONPathNeedsPeriodising", sJSONPath)
    #End If
    
End Function

Public Function IsErrorMessage(ByVal sExpr As String) As Boolean
    'function IsErrorMessage ( sExpr ) {
    '    var lLen = sExpr.length;
    '    return ((sExpr.substring( 0, 1) === '#') && (sExpr.substring( lLen - 1, lLen) === '!'));
    '}
    
    #If USEVBA Then
    Dim lLen As Long
    lLen = Len(sExpr)
    IsErrorMessage = SubString(sExpr, 0, 1) = "#" And SubString(sExpr, lLen - 1, lLen) = "!"
    #Else
    IsErrorMessage = SC.Run("IsErrorMessage", sExpr)
    #End If
End Function

Public Function GetNextLeftSquareBracket(ByVal sJSONPath As String, ByVal lStart As Long) As Long
    'function GetNextLeftSquareBracket ( sJSONPath , lStart ) {
    '    return sJSONPath.indexOf('[',lStart);
    '}

    #If USEVBA Then
    GetNextLeftSquareBracket = VBA.InStr(lStart, sJSONPath, "[", vbTextCompare)
    #Else
    GetNextLeftSquareBracket = SC.Run("GetNextLeftSquareBracket", sJSONPath, lStart)
    #End If
End Function

Public Function CheckCharAndPrevChar(ByVal sCharAndPrevChar As String) As Boolean
    'function CheckCharAndPrevChar( sCharAndPrevChar ) {
    '    if (sCharAndPrevChar.length===1) {
    '        return (sCharAndPrevChar === '[')  ; } else {
    '        return (sCharAndPrevChar === '.[') ;
    '    }
    '}
    
    
    #If USEVBA Then
    If Len(sCharAndPrevChar) = 1 Then
        CheckCharAndPrevChar = (sCharAndPrevChar = "[")
    Else
        CheckCharAndPrevChar = (sCharAndPrevChar = ".[")
    End If
    #Else
    CheckCharAndPrevChar = SC.Run("CheckCharAndPrevChar", sCharAndPrevChar)
    #End If
    
End Function

Public Function CharAndPrevChar(ByVal sJSONPath As String, ByVal lCharAt As Long) As String
    'function CharAndPrevChar(sJSONPath , lCharAt) {
    '    if (lCharAt===1) {
    '        return sJSONPath.substring(0,1); } else {
    '        return (sJSONPath.substring(lCharAt-1,lCharAt));
    '    }
    '}
    
    #If USEVBA Then
    
    
    If lCharAt = 1 Then
        CharAndPrevChar = Left$(sJSONPath, 1)
    Else
        CharAndPrevChar = Mid$(sJSONPath, lCharAt - 1, 2)
    End If
    #Else
    CharAndPrevChar = SC.Run("CharAndPrevChar", sJSONPath, lCharAt)
    #End If
End Function


Public Function LeftSquareIsMissingAdjacentPeriod(ByVal sJSONPath As String, ByVal lLeftSquareBracket As Long) As Boolean
    'function LeftSquareIsMissingAdjacentPeriod(sJSONPath , lLeftSquareBracket) {
    '    if (lLeftSquareBracket===1) { return true; } else {
    '        return (sJSONPath.substring(lLeftSquareBracket-1,lLeftSquareBracket)<>'.');
    '    }
    '}
    
    #If USEVBA Then
    If lLeftSquareBracket = 1 Then
        LeftSquareIsMissingAdjacentPeriod = True
    Else
        LeftSquareIsMissingAdjacentPeriod = (Mid$(sJSONPath, lLeftSquareBracket - 1, 1) <> ".")
    End If
    #Else
    LeftSquareIsMissingAdjacentPeriod = SC.Run("LeftSquareIsMissingAdjacentPeriod", sJSONPath, lLeftSquareBracket)
    #End If
End Function



Public Function ExtractSquareBrackets(ByVal sExpr As String) As String

    'function ExtractSquareBrackets(sExpr) {
    '   if (HasSquareBrackets(sExpr)===true) {
    '        if (sExpr.substring(0,1)==='[') {
    '            if (sExpr.substring(sExpr.length-1, sExpr.length)===']') {
    '                return sExpr.substring(1, sExpr.length-1);
    '            }
    '        }
    '   } else { return sExpr ; }
    '}

    '* assumes post periodisation
    
    #If USEVBA Then
    If HasSquareBrackets(sExpr) Then
        If Left$(sExpr, 1) = "[" Then
            If Right$(sExpr, 1) = "]" Then
                ExtractSquareBrackets = Mid$(sExpr, 2, Len(sExpr) - 2)
                Exit Function
            End If
        End If
    Else
        ExtractSquareBrackets = sExpr
    End If
    #Else
    ExtractSquareBrackets = SC.Run("ExtractSquareBrackets", sExpr)
    #End If
End Function

Public Function HasSquareBrackets(ByVal sExpr As String) As Boolean
    
    'function HasSquareBrackets(sExpr) { return (ValidSquareBrackets(sExpr) === 1); }"

    '* assumes post periodisation


    #If USEVBA Then
    '* assumes post periodisation
    HasSquareBrackets = (ValidSquareBrackets(sExpr) = 1)
    #Else
    HasSquareBrackets = SC.Run("HasSquareBrackets", sExpr)
    #End If
End Function





Public Function ValidSquareBracketsForPath(ByVal sPath As String) As Boolean
    'function ValidSquareBracketsForPath(sPath) {
    '    var vSplit=sPath.split('.');  var bAllPathSgementsAreValid=true;
    '    for (i = 0; i < vSplit.length; i++) {
    '        var vSplitLoop=vSplit[i];
    '        var lMatchedBracketCount = ValidSquareBrackets(vSplitLoop);
    '        var bValid = (lMatchedBracketCount === 0 || lMatchedBracketCount === 1);
    '        bAllPathSgementsAreValid =  bAllPathSgementsAreValid && bValid;
    '    }
    '    return bAllPathSgementsAreValid;
    '}

    '* returns true of false, checks each segment

    #If USEVBA Then
    Dim vSplit As Variant
    vSplit = VBA.Split(sPath, ".")
    
    Dim bAllPathSgementsAreValid As Boolean
    bAllPathSgementsAreValid = True '* until proven otherwise
    
    Dim vSplitLoop As Variant
    For Each vSplitLoop In vSplit
        Dim lMatchedBracketCount As Long
        lMatchedBracketCount = ValidSquareBrackets(vSplitLoop)
        
        Dim bValid As Boolean
        bValid = (lMatchedBracketCount = 0 Or lMatchedBracketCount = 1)
        
        bAllPathSgementsAreValid = bAllPathSgementsAreValid And bValid
    
    Next vSplitLoop
    
    ValidSquareBracketsForPath = bAllPathSgementsAreValid
    #Else
    ValidSquareBracketsForPath = SC.Run("ValidSquareBracketsForPath", sPath)
    #End If

End Function


Public Function ValidSquareBrackets(ByVal sExpr As String) As Long
    
    'function ValidSquareBrackets(sExpr) {
    '   var lCountLeftBrackets = CountLeftBrackets(sExpr); var lCountRightBrackets = CountRightBrackets(sExpr);
    '   if (lCountLeftBrackets!==lCountRightBrackets)  { return -1; } else {
    '         if (lCountLeftBrackets===0 || lCountRightBrackets===1) { return lCountLeftBrackets;} else { return -1;}
    '   }}
    
    '* returns either 0 or 1, or negative number
    '* 0 or 1 means either 0 or 1 pair of matched square brackets
    '* negative number means mismatch or more than 1 pair of matched brackets
    
    #If USEVBA Then
    Dim lReturn As Long
    
    Dim lCountLeftBrackets As Long
    lCountLeftBrackets = CountLeftBrackets(sExpr)

    Dim lCountRightBrackets As Long
    lCountRightBrackets = CountRightBrackets(sExpr)
    
    If lCountLeftBrackets <> lCountRightBrackets Then
        lReturn = -2 ^ 30
    Else
        Dim bValid As Boolean
        bValid = (lCountLeftBrackets = 0 Or lCountLeftBrackets = 1)
        If bValid Then
            lReturn = lCountLeftBrackets
        Else
            lReturn = -2 ^ 30
        End If
    End If
    ValidSquareBrackets = lReturn
    #Else
    ValidSquareBrackets = SC.Run("ValidSquareBrackets", sExpr)
    #End If

End Function





Public Function CountLeftBrackets(ByVal sExpr As String) As Long
    #If USEVBA Then
    CountLeftBrackets = CountChars(sExpr, "[")
    #Else
    CountLeftBrackets = SC.Run("CountLeftBrackets", sExpr)
    #End If
End Function

Public Function CountRightBrackets(ByVal sExpr As String) As Long
    #If USEVBA Then
    CountRightBrackets = CountChars(sExpr, "]")
    #Else
    CountRightBrackets = SC.Run("CountRightBrackets", sExpr)
    #End If
End Function

Private Function CountChars(ByVal sExpr As String, ByVal sChar As String) As Long
    Dim vSplit As Variant
    vSplit = VBA.Split(sExpr, sChar)

    CountChars = (UBound(vSplit) - LBound(vSplit))
End Function


Public Function IsNothing(ByVal objStart As Object) As Boolean
    IsNothing = SC.Run("IsNothing", objStart)
End Function

Public Function JSONPathCheckParams2(ByVal objStart As Object, ByVal sJSONPath As String) As String
    JSONPathCheckParams2 = SC.Run("JSONPathCheckParams", objStart, sJSONPath)
End Function

Public Function SegmentCount(ByVal sPath As String) As String
    SegmentCount = SC.Run("segmentCount", sPath)
End Function

Public Function FirstSegment(ByVal sPath As String) As String
    FirstSegment = SC.Run("firstSegment", sPath)
End Function


Public Function EatFirstSegment(ByVal sPath As String)
    EatFirstSegment = SC.Run("eatFirstSegment", sPath)
End Function


Public Function ArraysOfObjectsMergeProperties(ByVal objLeftArray As Object, ByVal objRightArray As Object) As Object


    Dim plLength As Long: plLength = 0
    If ArraysEqualLength(objLeftArray, objRightArray, plLength) Then
        
        Dim objNewArray As Object
        Set objNewArray = SC.Run("JSON_parse", "[]")
        
        Dim lLoop As Long
        For lLoop = 0 To plLength - 1
    
            If Not IsObject(CallByName(objLeftArray, CStr(lLoop), VbGet)) Then
                Err.Raise vbObjectError, , "#Expecting left arrays of objects, upgrade literals to objects!"
            End If

            If Not IsObject(CallByName(objRightArray, CStr(lLoop), VbGet)) Then
                Err.Raise vbObjectError, , "#Expecting right arrays of objects, upgrade literals to objects!"
            End If
            
            Dim objMerged As Object
            Set objMerged = ObjectsMergeProperties(CallByName(objLeftArray, CStr(lLoop), VbGet), CallByName(objRightArray, CStr(lLoop), VbGet))
            
            Call CallByName(objNewArray, "push", VbMethod, objMerged)

        Next
        Set ArraysOfObjectsMergeProperties = objNewArray
    End If

End Function

Public Function ObjectsMergeProperties(ByVal objLeft As Object, ByVal objRight As Object) As Object

    Dim objMergedObject As Object
    Set objMergedObject = SC.Run("JSON_parse", "{}")
    
    Dim dic As Scripting.Dictionary
    Set dic = New Scripting.Dictionary
    
    Call SC.Run("enumKeysToMsDict", objLeft, dic)
    
    Dim vKeyLoop As Variant
    For Each vKeyLoop In dic.Keys
    
        Call SC.Run("setValueByKey", objMergedObject, vKeyLoop, CallByName(objLeft, vKeyLoop, VbGet))
    Next vKeyLoop
    
    dic.RemoveAll
    
    Call SC.Run("enumKeysToMsDict", objRight, dic)
    For Each vKeyLoop In dic.Keys
    
        Call SC.Run("setValueByKey", objMergedObject, vKeyLoop, CallByName(objRight, vKeyLoop, VbGet))
    Next vKeyLoop
    
    Set ObjectsMergeProperties = objMergedObject

End Function



Public Function ArraysEqualLength(ByVal obj1 As Object, ByVal obj2 As Object, ByRef plLength As Long) As Boolean
    
    Dim v(1 To 2) As Variant
    v(1) = ArrayGetLength(obj1)
    v(2) = ArrayGetLength(obj2)
    
    If (Not IsEmpty(v(1))) And (Not IsEmpty(v(2))) Then
    
        If v(1) = v(2) Then
            plLength = v(2)
            ArraysEqualLength = True
        End If
    
    End If
    
End Function




Public Function JSONPathCheckParams(ByVal objStart As Object, ByVal sJSONPath As String) As String
    #If USEVBA Then
    'Debug.Assert Not objStart Is Nothing
    If objStart Is Nothing Then
        JSONPathCheckParams = "#Null objStart!"
        Exit Function
    End If
    
    If Len(sJSONPath) = 0 Then
        JSONPathCheckParams = "#Null sJSONPath!"
        Exit Function
    End If
    
    '* periodised path is required
    JSONPathCheckParams = JSONPathPeriodiseSquareBrackets(sJSONPath)
    'If IsErrorMessage(sJSONPath) Then
    '    JSONPathCheckParams = sJSONPath
    '    Exit Function
    'End If
    #Else
    JSONPathCheckParams = SC.Run("JSONPathCheckParams", objStart, sJSONPath)
    #End If

End Function

Public Function JSONParsePath(ByVal sJSONPath As String) As Object

    #If USEVBA Then

    Dim objReturn As Object
    Set objReturn = SC.Run("JSON_parse", "{}")
    
    Dim lCount As Long, sFirst As String, sNewPath As String
    
    lCount = SegmentCount(sJSONPath)
    sFirst = FirstSegment(sJSONPath)
    sNewPath = EatFirstSegment(sJSONPath)
    
    Call SC.Run("setValueByKey", objReturn, "lCount", lCount)
    Call SC.Run("setValueByKey", objReturn, "sNewPath", sNewPath)
    
    Dim bSquareBrackets As Boolean
    bSquareBrackets = HasSquareBrackets(sFirst)
    If bSquareBrackets Then
        sFirst = ExtractSquareBrackets(sFirst)
    End If
    Call SC.Run("setValueByKey", objReturn, "sFirst", sFirst)
    
    
    Set JSONParsePath = objReturn
    #Else
    Set JSONParsePath = SC.Run("JSONParsePath", sJSONPath)
    #End If
End Function



'Public Function ParseSquareBrackets(ByRef sExpr As String) As Boolean
'    'function ParseSquareBrackets(sExpr) {
'    '    sExpr = Trim(sExpr);
'    '    var lMatchedBracketCount = ValidSquareBrackets(sExpr);
'    '    if (lMatchedBracketCount==0 } {return true; }
'    '    if (lMatchedBracketCount==1) {
'    '        If (sExpr.substring(1,1) === '[') {
'    '
'    '        }
'    '    }
'    '    return false;
'    '}
'
'
'
'    #If USEVBA Then
'    sExpr = Trim(sExpr)
'
'    Dim lMatchedBracketCount As Long
'    lMatchedBracketCount = ValidSquareBrackets(sExpr)
'    If lMatchedBracketCount = 0 Then
'        ParseSquareBrackets = True: Exit Function
'    End If
'
'    If lMatchedBracketCount = 1 Then
'        '* expecting path to have periodised so if square brackets exists then of the form []
'        If Left$(sExpr, 1) = "[" Then
'
'            If Right$(sExpr, 1) = "]" Then
'                sExpr = Mid$(sExpr, 2, Len(sExpr) - 2)
'                ParseSquareBrackets = True
'                Exit Function
'            End If
'        End If
'    End If
'
'
''    If lMatchedBracketCount = 0 Or lMatchedBracketCount = 1 Then
''        ElseIf lMatchedBracketCount = 0 Then
''            ParseSquareBrackets = True
''        Else
''            ParseSquareBrackets = False
''        End If
''    End If
'    #Else
'    ParseSquareBrackets = SC.Run("ParseSquareBrackets", sExpr)
'    #End If
'
'End Function

'Public Function ArrayOfLiteralsUpgradeToObjects(ByVal objArray As Object, ByVal sLiteralsProperyName As String) As Object
'
'    #If USEVBA Then
'    Dim vLength As Variant
'    vLength = ArrayGetLength(objArray)
'
'    Dim objNewArray As Object
'    Set objNewArray = SC.Run("JSON_parse", "[]")
'
'    If Not IsEmpty(vLength) Then
'
'        Dim lLength As Long
'        lLength = CLng(vLength)
'        Dim lLoop As Long
'        For lLoop = 0 To lLength - 1
'
'            If IsObject(CallByName(objArray, CStr(lLoop), VbGet)) Then
'                Err.Raise vbObjectError, , "#Expecting literals only!"
'            End If
'
'            Dim vLiteralElement As Variant
'            vLiteralElement = CallByName(objArray, CStr(lLoop), VbGet)
'
'            Dim objNewObject As Object
'            If IsNumeric(vLiteralElement) Then
'                Set objNewObject = SC.Run("JSON_parse", "{""" & sLiteralsProperyName & """:" & vLiteralElement & "}")
'            Else
'
'                Set objNewObject = SC.Run("JSON_parse", "{""" & sLiteralsProperyName & """:""" & vLiteralElement & """}")
'            End If
'            Call CallByName(objNewArray, "push", VbMethod, objNewObject)
'
'        Next
'    End If
'    Set ArrayOfLiteralsUpgradeToObjects = objNewArray
'
'
'    #Else
'    Set ArrayOfLiteralsUpgradeToObjects = SC.Run("ArrayOfLiteralsUpgradeToObjects", objArray, sLiteralsProperyName)
'    #End If
'End Function

'Private Function ArrayGetLength(ByVal obj As Object) As Variant
'    If obj.hasOwnProperty("length") Then
'        ArrayGetLength = CallByName(obj, "length", VbGet)
'    End If
'
'End Function

Option Explicit
Option Private Module

'* module name:     tstJSONPath
'* module type:     standard
'* purpose:         tests, unit tests, real life use cases
'* Version:         0.01
'* Date:            19 Jan 2018  20:19
'* Author:          S Meaden
'* TODO:


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


Private Sub TestAll()
    'End
    TestCountLeftBrackets
    TestCountRightBrackets
    TestJSONPath
    TestJSONPath0
    TestJSONPathArrayWildcard0
    TestJSONPathArrayWildcard1
    TestJSONPathArrayWildcard2
    TestJSONPathNeedsPeriodising
    TestJSONPathPeriodiseSquareBrackets
    TestNonObjectReturn
    TestHasSquareBrackets
    TestExtractSquareBrackets
    'TestParseSquareBrackets
    TestValidSquareBrackets
    TestValidSquareBracketsForPath

End Sub

Sub TestMergeObjects()

    Dim oSC As Object
    Set oSC = modJSONPath.JsonPathSC

    Dim obj1 As Object
    Set obj1 = oSC.Run("JSON_parse", "{""a"":1}")

    Dim obj2 As Object
    Set obj2 = oSC.Run("JSON_parse", "{""b"":2}")

    Dim objMerged As Object
    Set objMerged = MergeObjects(obj1, obj2)
    
    Debug.Assert objMerged.hasOwnProperty("a")
    Debug.Assert objMerged.hasOwnProperty("b")
    
    Debug.Assert CallByName(objMerged, "a", VbGet) = 1
    Debug.Assert CallByName(objMerged, "b", VbGet) = 2
    'Stop
End Sub




Private Sub TestRealLifeTest2()
    '* get the title and url from the given test string
    Dim oSC As Object
    Set oSC = modJSONPath.JsonPathSC

    Dim lHeavyLooping As Long
    For lHeavyLooping = 1 To 1 '100

    Dim obj As Object
    Set obj = oSC.Run("JSON_parse", SimpleMasterPage)
    
    Dim objTitles As Object
    Set objTitles = JSONPath(obj, "feed.entry[*].title.$t", True)

    Dim objTitlesUpgraded As Object
    Set objTitlesUpgraded = UpgradeArrayElementsToObject(objTitles, "title")

    Dim objHrefs As Object
    Set objHrefs = JSONPath(obj, "feed.entry[*].link.[0].href", True)

    Dim objHrefsUpgraded As Object
    Set objHrefsUpgraded = UpgradeArrayElementsToObject(objHrefs, "href")
    
    Dim objMergedArray As Object
    Set objMergedArray = MergeEachObjectInArrays(objTitlesUpgraded, objHrefsUpgraded)
    
    
    Next lHeavyLooping
    Stop
    
End Sub



Private Sub TestUpgradeArrayElementsToObject()

    Dim oSC As Object
    Set oSC = modJSONPath.JsonPathSC


    Dim obj As Object
    Set obj = oSC.Run("JSON_parse", "[1,2,3,4]")

    Dim obj2 As Object
    Set obj2 = UpgradeArrayElementsToObject(obj, "goals")
    Debug.Assert VBA.IsObject(CallByName(obj2, "0", VbGet))
    Debug.Assert VBA.IsObject(CallByName(obj2, "1", VbGet))
    Debug.Assert VBA.IsObject(CallByName(obj2, "2", VbGet))
    Debug.Assert VBA.IsObject(CallByName(obj2, "3", VbGet))

    Debug.Assert CallByName(obj2, "0", VbGet).hasOwnProperty("goals")
    Debug.Assert CallByName(obj2, "1", VbGet).hasOwnProperty("goals")
    Debug.Assert CallByName(obj2, "2", VbGet).hasOwnProperty("goals")
    Debug.Assert CallByName(obj2, "3", VbGet).hasOwnProperty("goals")

    Debug.Assert CallByName(CallByName(obj2, "0", VbGet), "goals", VbGet) = 1
    Debug.Assert CallByName(CallByName(obj2, "1", VbGet), "goals", VbGet) = 2
    Debug.Assert CallByName(CallByName(obj2, "2", VbGet), "goals", VbGet) = 3
    Debug.Assert CallByName(CallByName(obj2, "3", VbGet), "goals", VbGet) = 4
    

End Sub

Private Sub TestUpgradeToObject()
    
    Dim oSC As Object
    Set oSC = modJSONPath.JsonPathSC
    
    Dim obj1Upgraded As Object
    Set obj1Upgraded = UpgradeToObject(1, "foo")
    Debug.Assert VBA.IsObject(obj1Upgraded)
    Debug.Assert CallByName(obj1Upgraded, "foo", VbGet) = 1

    
    Set obj1Upgraded = UpgradeToObject(1, "bar")
    Debug.Assert VBA.IsObject(obj1Upgraded)
    Debug.Assert CallByName(obj1Upgraded, "bar", VbGet) = 1

    Set obj1Upgraded = UpgradeToObject(1, "")
    Debug.Assert VBA.IsObject(obj1Upgraded)
    Debug.Assert CallByName(obj1Upgraded, "dummy", VbGet) = 1

    Set obj1Upgraded = UpgradeToObject(False, "foo")
    Debug.Assert VBA.IsObject(obj1Upgraded)
    Debug.Assert CallByName(obj1Upgraded, "foo", VbGet) = False

    Set obj1Upgraded = UpgradeToObject("Hello world", "foo")
    Debug.Assert VBA.IsObject(obj1Upgraded)
    Debug.Assert CallByName(obj1Upgraded, "foo", VbGet) = "Hello world"

    Set obj1Upgraded = UpgradeToObject("Hello world", "")
    Debug.Assert VBA.IsObject(obj1Upgraded)
    Debug.Assert CallByName(obj1Upgraded, "dummy", VbGet) = "Hello world"

    Dim objAlreadyAnObject As Object
    Set objAlreadyAnObject = oSC.Run("JSON_parse", "{""a"":1}")
    Dim objAlreadyAnObjectUpgraded As Object
    On Error Resume Next
    Set objAlreadyAnObjectUpgraded = UpgradeToObject(objAlreadyAnObject, "foo")
    
    Dim sSavedError As String
    sSavedError = Err.Description
    On Error GoTo 0
    Debug.Assert sSavedError = "#Already an object!"
    


End Sub


Private Sub TestTypeObjectByStringification()
    
    Dim oSC As Object
    Set oSC = modJSONPath.JsonPathSC
    
    Dim objArr As Object
    Set objArr = oSC.Run("JSON_parse", "[1,2,3,4]")
    Debug.Assert TypeObjectByStringification(objArr) = 1

    Dim obj As Object
    Set obj = oSC.Run("JSON_parse", "{""a"":1}")
    Debug.Assert TypeObjectByStringification(obj) = 2
    
    Debug.Assert TypeObjectByStringification("foo") = 0
    Debug.Assert TypeObjectByStringification(False) = 0
    Debug.Assert TypeObjectByStringification(True) = 0
    Debug.Assert TypeObjectByStringification(1) = 0
    Debug.Assert TypeObjectByStringification(1.5) = 0

End Sub

Private Sub TestIsArray()
    Dim oSC As Object
    Set oSC = modJSONPath.JsonPathSC

    Dim obj As Object
    Set obj = oSC.Run("JSON_parse", "[1,2,3,4]")
    Debug.Assert IsArray(obj)
    Stop
End Sub

Private Sub TestIsObject()
    Debug.Assert IsObject(1) = False
    Debug.Assert IsObject(Nothing) = False
    Debug.Assert IsObject("hello") = False
    Debug.Assert IsObject(True) = False
    Debug.Assert IsObject(1.5) = False
End Sub




Private Sub TestJSONPath()
    TestJSONPath0
    TestJSONPathArrayWildcard0
    TestJSONPathArrayWildcard1
    TestJSONPathArrayWildcard2
End Sub

Private Sub TestJSONPathArrayWildcard2()
    Dim oSC As Object
    Set oSC = modJSONPath.JsonPathSC

    Dim obj As Object
    Set obj = oSC.Run("JSON_parse", SimpleMasterPage)

    Dim objExpected(0 To 2) As Object
    Set objExpected(0) = CallByName(CallByName(CallByName(CallByName(obj, "feed", VbGet), "entry", VbGet), "0", VbGet), "title", VbGet)
    Set objExpected(1) = CallByName(CallByName(CallByName(CallByName(obj, "feed", VbGet), "entry", VbGet), "1", VbGet), "title", VbGet)
    Set objExpected(2) = CallByName(CallByName(CallByName(CallByName(obj, "feed", VbGet), "entry", VbGet), "2", VbGet), "title", VbGet)
    
    
    Dim objExpectedArray As Object
    Set objExpectedArray = oSC.Run("JSON_parse", "[]")
    Call CallByName(objExpectedArray, "push", VbMethod, CallByName(objExpected(0), "$t", VbGet))
    Call CallByName(objExpectedArray, "push", VbMethod, CallByName(objExpected(1), "$t", VbGet))
    Call CallByName(objExpectedArray, "push", VbMethod, CallByName(objExpected(2), "$t", VbGet))
    
    Dim objObserved As Object
    Set objObserved = JSONPath(obj, "feed.entry[*].title.$t", True)
    
    Debug.Assert oSC.Run("JSON_stringify", objExpectedArray) = oSC.Run("JSON_stringify", objObserved)

End Sub


Private Sub TestFirstSegment()
    Debug.Assert FirstSegment("feed") = "feed"
    'Debug.Assert FirstSegment("feed.entry") = "entry"
    Debug.Assert FirstSegment("entry.[*]") = "entry"
    'Debug.Assert FirstSegment("feed.entry.[*].title") = "entry.[*].title"
    'Debug.Assert FirstSegment("feed.entry.[*].title.$t") = "entry.[*].title.$t"
End Sub


Private Sub TestEatFirstSegment()
    Debug.Assert EatFirstSegment("feed") = ""
    Debug.Assert EatFirstSegment("feed.entry") = "entry"
    Debug.Assert EatFirstSegment("feed.entry.[*]") = "entry.[*]"
    Debug.Assert EatFirstSegment("feed.entry.[*].title") = "entry.[*].title"
    Debug.Assert EatFirstSegment("feed.entry.[*].title.$t") = "entry.[*].title.$t"
End Sub


Private Sub TestSegmentCount()
    Debug.Assert SegmentCount("") = 0
    Debug.Assert SegmentCount("feed") = 1
    Debug.Assert SegmentCount("feed.entry") = 2
    Debug.Assert SegmentCount("feed.entry.[*]") = 3
    Debug.Assert SegmentCount("feed.entry.[*].title") = 4
    Debug.Assert SegmentCount("feed.entry.[*].title.$t") = 5
End Sub

Private Sub TestJSONParsePath()
    Dim obj As Object
    
    Set obj = JSONParsePath("feed")
    Debug.Assert VBA.CallByName(obj, "lCount", VbGet) = 1
    Debug.Assert VBA.CallByName(obj, "sNewPath", VbGet) = ""
    Debug.Assert VBA.CallByName(obj, "sFirst", VbGet) = "feed"
    
    Set obj = JSONParsePath("feed.entry")
    Debug.Assert VBA.CallByName(obj, "lCount", VbGet) = 2
    Debug.Assert VBA.CallByName(obj, "sNewPath", VbGet) = "entry"
    Debug.Assert VBA.CallByName(obj, "sFirst", VbGet) = "feed"
    
    Set obj = JSONParsePath("feed.entry.[*]")
    Debug.Assert VBA.CallByName(obj, "lCount", VbGet) = 3
    Debug.Assert VBA.CallByName(obj, "sNewPath", VbGet) = "entry.[*]"
    Debug.Assert VBA.CallByName(obj, "sFirst", VbGet) = "feed"
    
    Set obj = JSONParsePath("feed.entry.[*].title")
    Debug.Assert VBA.CallByName(obj, "lCount", VbGet) = 4
    Debug.Assert VBA.CallByName(obj, "sNewPath", VbGet) = "entry.[*].title"
    Debug.Assert VBA.CallByName(obj, "sFirst", VbGet) = "feed"
    
    Set obj = JSONParsePath("feed.entry.[*].title.$t")
    Debug.Assert VBA.CallByName(obj, "lCount", VbGet) = 5
    Debug.Assert VBA.CallByName(obj, "sNewPath", VbGet) = "entry.[*].title.$t"
    Debug.Assert VBA.CallByName(obj, "sFirst", VbGet) = "feed"
    
    Set obj = JSONParsePath("[*].title.$t")
    Debug.Assert VBA.CallByName(obj, "lCount", VbGet) = 3
    Debug.Assert VBA.CallByName(obj, "sNewPath", VbGet) = "title.$t"
    Debug.Assert VBA.CallByName(obj, "sFirst", VbGet) = "*"
    
    'Stop
    
End Sub

Private Sub TestJSONPathArrayWildcard1()
    Dim oSC As Object
    Set oSC = modJSONPath.JsonPathSC

    Dim obj As Object
    Set obj = oSC.Run("JSON_parse", SimpleMasterPage)

    Dim objExpected(0 To 2) As Object
    Set objExpected(0) = CallByName(CallByName(CallByName(CallByName(obj, "feed", VbGet), "entry", VbGet), "0", VbGet), "title", VbGet)
    Set objExpected(1) = CallByName(CallByName(CallByName(CallByName(obj, "feed", VbGet), "entry", VbGet), "1", VbGet), "title", VbGet)
    Set objExpected(2) = CallByName(CallByName(CallByName(CallByName(obj, "feed", VbGet), "entry", VbGet), "2", VbGet), "title", VbGet)
    
    
    Dim objExpectedArray As Object
    Set objExpectedArray = oSC.Run("JSON_parse", "[]")
    Call CallByName(objExpectedArray, "push", VbMethod, objExpected(0))
    Call CallByName(objExpectedArray, "push", VbMethod, objExpected(1))
    Call CallByName(objExpectedArray, "push", VbMethod, objExpected(2))
    
    Dim objObserved As Object
    Set objObserved = JSONPath(obj, "feed.entry[*].title", True)
    
    Debug.Assert oSC.Run("JSON_stringify", objExpectedArray) = oSC.Run("JSON_stringify", objObserved)

End Sub

Private Sub TestJSONPathCheckParams()
    Debug.Assert JSONPathCheckParams2(Nothing, "") = "#Null objStart!"
    Debug.Assert JSONPathCheckParams2(Nothing, "foo") = "#Null objStart!"
    Debug.Assert JSONPathCheckParams2(ThisDocument, "foo") = "foo"
    Debug.Assert JSONPathCheckParams2(ThisDocument, "") = "#Null sJSONPath!"
    Debug.Assert JSONPathCheckParams2(ThisDocument, "foo[2]") = "foo.[2]"
End Sub

Private Sub TestIsNothing()
    Debug.Assert IsNothing(Nothing)
    Debug.Assert IsNothing(ThisDocument) = False
    'Debug.Assert IsNothing(0)
End Sub

Private Sub TestJSONPathArrayWildcard0()
    Dim oSC As Object
    Set oSC = modJSONPath.JsonPathSC

    Dim obj As Object
    Set obj = oSC.Run("JSON_parse", SimpleMasterPage)

    Dim objExpected(0 To 2) As Object
    Set objExpected(0) = CallByName(CallByName(CallByName(obj, "feed", VbGet), "entry", VbGet), "0", VbGet)
    Set objExpected(1) = CallByName(CallByName(CallByName(obj, "feed", VbGet), "entry", VbGet), "1", VbGet)
    Set objExpected(2) = CallByName(CallByName(CallByName(obj, "feed", VbGet), "entry", VbGet), "2", VbGet)
    
    Dim objExpectedArray As Object
    Set objExpectedArray = oSC.Run("JSON_parse", "[]")
    Call CallByName(objExpectedArray, "push", VbMethod, objExpected(0))
    Call CallByName(objExpectedArray, "push", VbMethod, objExpected(1))
    Call CallByName(objExpectedArray, "push", VbMethod, objExpected(2))
    
    Dim objObserved As Object
    Set objObserved = JSONPath(obj, "feed.entry[*]", True)
    
    Debug.Assert oSC.Run("JSON_stringify", objExpectedArray) = oSC.Run("JSON_stringify", objObserved)

End Sub

Private Sub TestNonObjectReturn()

    Dim oSC As Object
    Set oSC = modJSONPath.JsonPathSC

    Dim obj As Object
    Set obj = oSC.Run("JSON_parse", SimpleMasterPage)

    Dim objExpectedTitleObject As Object
    Set objExpectedTitleObject = CallByName(CallByName(CallByName(CallByName(obj, "feed", VbGet), "entry", VbGet), "0", VbGet), "title", VbGet)

    Dim vExpectedTDollar As Variant
    vExpectedTDollar = CallByName(objExpectedTitleObject, "$t", VbGet)
    
    Dim vObservedTDollar As Variant
    vObservedTDollar = JSONPath(objExpectedTitleObject, "$t", True)
    
    Debug.Assert vExpectedTDollar = vObservedTDollar

    Debug.Assert oSC.Run("JSON_stringify", vExpectedTDollar) = oSC.Run("JSON_stringify", vObservedTDollar)

End Sub

Private Sub TestJSONPath0()
    Dim oSC As Object
    Set oSC = modJSONPath.JsonPathSC

    Dim obj As Object
    Set obj = oSC.Run("JSON_parse", SimpleMasterPage)
    
    Dim objExpected As Object
    Dim objObserved As Object
    
    Set objExpected = CallByName(obj, "feed", VbGet)
    Set objObserved = JSONPath(obj, "feed", True)
    
    Debug.Assert oSC.Run("JSON_stringify", objExpected) = oSC.Run("JSON_stringify", objObserved)
    
    Set objExpected = CallByName(CallByName(obj, "feed", VbGet), "entry", VbGet)
    
    Set objObserved = JSONPath(obj, "feed.entry", True)
    
    Debug.Assert oSC.Run("JSON_stringify", objExpected) = oSC.Run("JSON_stringify", objObserved)
    
    Set objExpected = CallByName(CallByName(CallByName(obj, "feed", VbGet), "entry", VbGet), "0", VbGet)
    
    Set objObserved = JSONPath(obj, "feed.entry[0]", True)
    
    Debug.Assert oSC.Run("JSON_stringify", objExpected) = oSC.Run("JSON_stringify", objObserved)
    
End Sub

Private Sub TestIsErrorMessage()
    Debug.Assert modJSONPath.IsErrorMessage("#boo!")
    Debug.Assert modJSONPath.IsErrorMessage("#boo") = False
    Debug.Assert modJSONPath.IsErrorMessage("boo!") = False
    Debug.Assert modJSONPath.IsErrorMessage("boo") = False
End Sub

'Private Sub TestRemoveDoublePeriod()
'    Debug.Assert modJSONPath.RemoveDoublePeriod("foo..") = "foo."
'    Debug.Assert modJSONPath.RemoveDoublePeriod("..") = "."
'    Debug.Assert modJSONPath.RemoveDoublePeriod("...") = ".."
'
'End Sub

Private Sub TestRemoveDoublePeriods()
    Debug.Assert modJSONPath.RemoveDoublePeriods("foo..") = "foo."
    Debug.Assert modJSONPath.RemoveDoublePeriods("foo..bar..baz") = "foo.bar.baz"
    Debug.Assert modJSONPath.RemoveDoublePeriods("foo.[].bar..[]") = "foo.[].bar.[]"
    '

End Sub

Private Sub TestInsertPeriodBeforeLeftSquareBracket()
    Debug.Assert modJSONPath.InsertPeriodBeforeLeftSquareBracket("foo[].bar[]") = "foo.[].bar.[]"
    Debug.Assert modJSONPath.InsertPeriodBeforeLeftSquareBracket("foo[].bar.[]") = "foo.[].bar..[]"

End Sub

Private Sub TestJSONPathPeriodiseSquareBrackets()

    Debug.Assert modJSONPath.JSONPathPeriodiseSquareBrackets("foo") = "foo"
    Debug.Assert modJSONPath.JSONPathPeriodiseSquareBrackets("foo[]") = "foo.[]"
    Debug.Assert modJSONPath.JSONPathPeriodiseSquareBrackets("foo.bar") = "foo.bar"
    Debug.Assert modJSONPath.JSONPathPeriodiseSquareBrackets("foo.bar[]") = "foo.bar.[]"
    Debug.Assert modJSONPath.JSONPathPeriodiseSquareBrackets("foo[].bar[]") = "foo.[].bar.[]"
    Debug.Assert modJSONPath.JSONPathPeriodiseSquareBrackets("foo[].bar[].barry[]") = "foo.[].bar.[].barry.[]"
    Debug.Assert modJSONPath.JSONPathPeriodiseSquareBrackets("foo[].bar[].barry") = "foo.[].bar.[].barry"
    Debug.Assert modJSONPath.JSONPathPeriodiseSquareBrackets("foo.bar[].barry") = "foo.bar.[].barry"
    Debug.Assert modJSONPath.JSONPathPeriodiseSquareBrackets("feed.entry[*].link.[0]") = ("feed.entry.[*].link.[0]")


End Sub


Private Sub TestValidSquareBracketsForPath()
    Debug.Assert ValidSquareBracketsForPath("foo")
    Debug.Assert ValidSquareBracketsForPath("foo[]")
    Debug.Assert ValidSquareBracketsForPath("foo.bar")
    Debug.Assert ValidSquareBracketsForPath("foo.bar[]")
    Debug.Assert ValidSquareBracketsForPath("foo[].bar[]")
    Debug.Assert ValidSquareBracketsForPath("foo[].bar[].barry[]")
    Debug.Assert ValidSquareBracketsForPath("foo[].bar[].barry")
    Debug.Assert ValidSquareBracketsForPath("foo.bar[].barry")

End Sub


Private Sub TestValidSquareBrackets()
    'Dim lMatchedBracketCount As Long
    Debug.Assert ValidSquareBrackets("foo") = 0
    'Debug.Assert lMatchedBracketCount = 0
    
    Debug.Assert ValidSquareBrackets("foo[") < 0 'False
    'Debug.Assert lMatchedBracketCount < 0
    
    Debug.Assert ValidSquareBrackets("foo]") < 0 '= False
    'Debug.Assert lMatchedBracketCount < 0
    
    Debug.Assert ValidSquareBrackets("foo[]") = 1
    'Debug.Assert lMatchedBracketCount = 1
    
    Debug.Assert ValidSquareBrackets("foo[[]") < 0 '= False
    'Debug.Assert lMatchedBracketCount < 0
    
    Debug.Assert ValidSquareBrackets("foo[]]") < 0 '= False
    'Debug.Assert lMatchedBracketCount < 0
    
    Debug.Assert ValidSquareBrackets("foo[[]]") < 0 'False
    'Debug.Assert lMatchedBracketCount = 2
End Sub




Private Sub TestHasSquareBrackets()
    
    Debug.Assert HasSquareBrackets("[0]")
    
    Debug.Assert HasSquareBrackets("[*]")
    
    Debug.Assert HasSquareBrackets("foo") = False


End Sub

Private Sub TestExtractSquareBrackets()

    Debug.Assert ExtractSquareBrackets("foo") = "foo"
    
    Debug.Assert ExtractSquareBrackets("[0]") = "0"
    
    Debug.Assert ExtractSquareBrackets("[*]") = "*"

End Sub




Private Function SimpleMasterPage() As String

    SimpleMasterPage = "{ ""feed"": {" & _
    """entry"": [ " & vbNewLine & _
    "  { " & _
    "    ""title"": { ""$t"": ""1 Med"" }, " & _
    "    ""link"": [ { ""href"": ""https//removed....Med"" } ] " & _
    "  }, " & vbNewLine & _
    "  { " & _
    "    ""title"": { ""$t"": ""2 Dent"" }, " & _
    "    ""link"": [ { ""href"": ""https//removed....Dent"" } ] " & _
    "  }, " & vbNewLine & _
    "  { " & _
    "    ""title"": { ""$t"": ""3 Vet"" }, " & _
    "    ""link"": [  { ""href"": ""https//removed....Vet"" }] " & _
    "  }" & vbNewLine & _
    "] } }"

End Function

Private Sub TestLeftSquareIsMissingAdjacentPeriod()
    Debug.Assert modJSONPath.LeftSquareIsMissingAdjacentPeriod("foo[", 4)
    
    
    Debug.Assert modJSONPath.LeftSquareIsMissingAdjacentPeriod("fo.[", 2) = False
    Debug.Assert modJSONPath.LeftSquareIsMissingAdjacentPeriod("fo.[", 3) = False
    Debug.Assert modJSONPath.LeftSquareIsMissingAdjacentPeriod("fo.[", 4) = False
        

    Debug.Assert modJSONPath.LeftSquareIsMissingAdjacentPeriod("[", 1)

End Sub
Private Function TestGetNextLeftSquareBracket()

    Debug.Assert modJSONPath.GetNextLeftSquareBracket("[", 1) = 1
    Debug.Assert modJSONPath.GetNextLeftSquareBracket(".[", 1) = 2
    
End Function

Private Function TestCheckCharAndPrevChar()
    Debug.Assert modJSONPath.CheckCharAndPrevChar("[")
    Debug.Assert modJSONPath.CheckCharAndPrevChar(".[")
    Debug.Assert modJSONPath.CheckCharAndPrevChar("f.") = False
End Function

Private Function TestCharAndPrevChar()
    Debug.Assert modJSONPath.CharAndPrevChar("foo[", 4) = "o["
    
    Debug.Assert modJSONPath.CharAndPrevChar("fo.[", 2) = "fo"
    Debug.Assert modJSONPath.CharAndPrevChar("fo.[", 3) = "o."
    Debug.Assert modJSONPath.CharAndPrevChar("fo.[", 4) = ".["
        
    Debug.Assert modJSONPath.CharAndPrevChar("[", 1) = "["
End Function

Private Sub TestIndexOf()
    Debug.Assert modJSONPath.IndexOf("Hello world!", "l", 1) = 2
    Debug.Assert modJSONPath.IndexOf("Hello world!", "l", 3) = 3
    Debug.Assert modJSONPath.IndexOf("Hello world!", "l", 4) = 9
    Debug.Assert modJSONPath.IndexOf("Hello world!", "z", 4) = -1


End Sub

Private Sub TestSubString()
    Debug.Assert modJSONPath.SubString("Hello world!", 1, 4) = "ell"
    Debug.Assert modJSONPath.SubString("Hello world!", 0, 4) = "Hell"
    
    Debug.Assert Len("Hello world!") = 12
    Debug.Assert modJSONPath.SubString("Hello world!", 11, 12) = "!"
    

    '* Left$
    Debug.Assert modJSONPath.SubString("Hello world!", 0, 1) = Left$("Hello world!", 1) '* identity
    Debug.Assert modJSONPath.SubString("Hello world!", 0, 2) = Left$("Hello world!", 2) '* identity
    
    '* Right$
    Debug.Assert modJSONPath.SubString("Hello world!", Len("Hello world!") - 1, Len("Hello world!")) = Right$("Hello world!", 1) '* identity
    Debug.Assert modJSONPath.SubString("Hello world!", Len("Hello world!") - 2, Len("Hello world!")) = Right$("Hello world!", 2) '* identity
    
    '* Mid$
    Debug.Assert modJSONPath.SubString("Hello world!", 0, 1) = Mid$("Hello world!", 1, 1) '* identity
    Debug.Assert modJSONPath.SubString("Hello world!", 0, 2) = Mid$("Hello world!", 1, 2) '* identity
    

End Sub


Private Sub TestJSONPathNeedsPeriodising()
    Debug.Assert modJSONPath.JSONPathNeedsPeriodising("foo") = False
    Debug.Assert modJSONPath.JSONPathNeedsPeriodising("foo[]") = True
    Debug.Assert modJSONPath.JSONPathNeedsPeriodising("foo.[]") = False
    Debug.Assert modJSONPath.JSONPathNeedsPeriodising("[]") = False

    Debug.Assert modJSONPath.JSONPathNeedsPeriodising("feed.entry[*].link.[0]") = True
    
    
End Sub


Private Sub TestCountLeftBrackets()
    Debug.Assert modJSONPath.CountLeftBrackets("fffoo[") = 1
    Debug.Assert modJSONPath.CountLeftBrackets("fffoo[0]") = 1
End Sub
Private Sub TestCountRightBrackets()
    Debug.Assert modJSONPath.CountRightBrackets("fffoo]") = 1
    Debug.Assert modJSONPath.CountRightBrackets("fffoo[0]") = 1
End Sub

'Private Sub TestValidSquareBrackets()
'    Dim lMatchedBracketCount As Long
'    Debug.Assert ValidSquareBrackets("foo", lMatchedBracketCount)
'    Debug.Assert lMatchedBracketCount = 0
'
'    Debug.Assert ValidSquareBrackets("foo[", lMatchedBracketCount) = False
'    Debug.Assert lMatchedBracketCount < 0
'
'    Debug.Assert ValidSquareBrackets("foo]", lMatchedBracketCount) = False
'    Debug.Assert lMatchedBracketCount < 0
'    Debug.Assert ValidSquareBrackets("foo[]", lMatchedBracketCount)
'    Debug.Assert lMatchedBracketCount = 1
'
'    Debug.Assert ValidSquareBrackets("foo[[]", lMatchedBracketCount) = False
'    Debug.Assert lMatchedBracketCount < 0
'
'    Debug.Assert ValidSquareBrackets("foo[]]", lMatchedBracketCount) = False
'    Debug.Assert lMatchedBracketCount < 0
'
'    Debug.Assert ValidSquareBrackets("foo[[]]", lMatchedBracketCount) = False
'    Debug.Assert lMatchedBracketCount = 2
'End Sub

'Private Sub TestParseSquareBrackets()
'
'    Dim sExpr As String
'    sExpr = "[0]"
'
'    Debug.Assert ParseSquareBrackets(sExpr)
'
'    Debug.Assert sExpr = "0"
'
'    sExpr = "[*]"
'    Debug.Assert ParseSquareBrackets(sExpr)
'    Debug.Assert sExpr = "*"
'
'    sExpr = "foo"
'    Debug.Assert ParseSquareBrackets(sExpr)
'    Debug.Assert sExpr = "foo"
'
'
'End Sub


'Private Sub TestRealLifeTest()
'    '* get the title and url from the given test string
'    Dim oSC As Object
'    Set oSC = modJSONPath.JsonPathSC
'
'    Dim obj As Object
'    Set obj = oSC.Run("JSON_parse", SimpleMasterPage)
'
'    Dim objMergedArray As Object
'    Set objMergedArray = ArraysOfObjectsMergeProperties( _
'                ArrayOfLiteralsUpgradeToObjects(JSONPath(obj, "feed.entry[*].title.$t", True), "title"), _
'                ArrayOfLiteralsUpgradeToObjects(JSONPath(obj, "feed.entry[*].link.[0].href", True), "href"))
'
'
'
'    'Stop
'
'End Sub

'
'Private Sub Recon()
'
'    Dim oSC As Object
'    Set oSC = modJSONPath.JsonPathSC
'
'    Dim obj As Object
'    Set obj = oSC.Run("JSON_parse", "[1,2,3,4]")
'
'    Dim obj2 As Object
'    Set obj2 = ArrayOfLiteralsUpgradeToObjects(obj, "goals")
'
'    Dim obj3 As Object
'    Set obj3 = UpgradeArrayElementsToObject(obj, "goals")
'    Debug.Assert oSC.Run("JSON_stringify", obj2) = oSC.Run("JSON_stringify", obj3)
'End Sub

'Private Sub TestArrayOfLiteralsUpgradeToObjects()
'
'    Dim oSC As Object
'    Set oSC = modJSONPath.JsonPathSC
'
'
'    Dim obj As Object
'    Set obj = oSC.Run("JSON_parse", "[1,2,3,4]")
'
'    Dim obj2 As Object
'    Set obj2 = oSC.Run("upgradeArrayElementsToObject", obj, "goals")
'    Stop
'End Sub

'Private Sub TestRealLifeTestDeveloper()
'    '* get the title and url from the given test string
'    'End
'    Dim oSC As Object
'    Set oSC = modJSONPath.JsonPathSC
'
'    Dim obj As Object
'    Set obj = oSC.Run("JSON_parse", SimpleMasterPage)
'
'    Dim objTitles As Object
'    Set objTitles = JSONPath(obj, "feed.entry[*].title.$t", True)
'
'    Dim objURLs As Object
'    'Set objURLs = JSONPath(obj, "feed.entry[*].link")
'    'Set objURLs = JSONPath(obj, "feed.entry[*].link[0]")
'    'Set objURLs = JSONPath(obj, "feed.entry[*].link.[0]")
'    Set objURLs = JSONPath(obj, "feed.entry[*].link.[0].href", True)
'    'Set objURLs = JSONPath(obj, "feed.entry[*].link.[0]")
'
'    Dim objTitlesUpgraded As Object
'    Set objTitlesUpgraded = modJSONPath.ArrayOfLiteralsUpgradeToObjects(objTitles, "title")
'
'    Dim objURLsUpgraded As Object
'    Set objURLsUpgraded = modJSONPath.ArrayOfLiteralsUpgradeToObjects(objURLs, "href")
'
'
'    Dim objTitlesUpgraded0 As Object
'    Set objTitlesUpgraded0 = CallByName(objTitlesUpgraded, "0", VbGet)
'
'    Dim objURLsUpgraded0 As Object
'    Set objURLsUpgraded0 = CallByName(objURLsUpgraded, "0", VbGet)
'
'    Dim objMerged As Object
'    Set objMerged = ObjectsMergeProperties(objTitlesUpgraded0, objURLsUpgraded0)
'
'    Debug.Assert oSC.Run("JSON_stringify", objMerged) = "{""title"":""1 Med"",""href"":""https//removed....Med""}"
'
'
'    Dim objMergedArray As Object
'    Set objMergedArray = ArraysOfObjectsMergeProperties(objTitlesUpgraded, objURLsUpgraded)
'
'    Stop
'
'End Sub