VBA - Javascript - Passing arrays to and fro

Summary: Javascript arrays differ from VBA variant arrays so one needs some conversion logic, here we give it.

VBA (like VB6) has its own type of array called a SafeArray; safe because it does bounds checking unlike C++ arrays. Additionally, SafeArrays can be used in For Each Next loops so often I prefer to use them. Sadly, Javascript cannot direct read a Safearray, equally accessing Javascript arrays from VBA is quite painful (use CallByName, vbGet, with a stringified index number). We need some conversion logic both to and fro to help us along.

In the following module, one can find

• isArray(), a function to test for an array (a great many array tests on the Internet won't run in the ScriptControl because limited to Ecmascript 3)
• fromArray(), a function to convert a VB array to a javascript array .
• toVBArray (), a method added to the Array prototype (so is inherited by all arrays) that allows the conversion to a VB safearray.
• Some test code filterOdd() demonstrating the above.

Option Explicit

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


Private Sub TestJavascriptArraysToAndFro()

    Dim sProg As String

    Dim oSC As MSScriptControl.ScriptControl
    Set oSC = New MSScriptControl.ScriptControl
    oSC.Language = "JScript"
    oSC.AddCode "function isArray(arr) {  return arr.constructor.toString().indexOf('Array') > -1; }"
    
    '* https://docs.microsoft.com/en-us/scripting/javascript/reference/vbarray-object-javascript
    oSC.AddCode "function fromVBArray(vbArray) { return new VBArray(vbArray).toArray();}"


    'http://cwestblog.com/2011/10/24/javascript-snippet-array-prototype-tovbarray/
    sProg = "Array.prototype.toVBArray = function() {                                                                        " & _
            "   var dict = new ActiveXObject('Scripting.Dictionary');                                                        " & _
            "   for(var i = 0, len = this.length; i < len; i++)                                                              " & _
            "       dict.add(i, this[i]);                                                                                    " & _
            "   return dict.Items();                                                                                         " & _
            "};                                                                                                              "
    
    oSC.AddCode sProg
    
    sProg = "function filterOdd(vbArray) {                                                                                   " & _
            "    var numbers = new VBArray(vbArray).toArray();                                                               " & _
            "    var filtered = [];                                                                                          " & _
            "    if (isArray(numbers)) {                                                                                     " & _
            "        for (var i = 0; i < numbers.length; i++) {                                                              " & _
            "            if (numbers[i] % 2 === 1 ) {                                                                        " & _
            "                filtered.push(numbers[i]);                                                                      " & _
            "            }                                                                                                   " & _
            "        }                                                                                                       " & _
            "    }                                                                                                           " & _
            "    return filtered.toVBArray();                                                                                " & _
            "}                                                                                                               "
    
    oSC.AddCode sProg

    Dim vFiltered As Variant
    vFiltered = oSC.Run("filterOdd", Array(1, 2, 3, 4, 5, 6))

    Debug.Assert vFiltered(0) = 1
    Debug.Assert vFiltered(1) = 3
    Debug.Assert vFiltered(2) = 5

    Stop
End Sub

VBA - Gut array from parsed JSON Document

So I recommend using ScriptControl with some added javascript libraries to parse a JSON document in VBA. I may have given the impression that parsed document is immutable, this is not the case. We can add some more javascript to the script control or we can rely on some intrinsic javascript function to modify the document. In this blog post I show how a JSON array can be gutted, i.e. elements deleted, using the instrinsic JavaScript function array.splice(). The code has a loop that removes 2 out of 3 elements of a simple array. (For loops we should count backwards from the end so as not to upset iterators and indices.)

Run the sub GutJSONArray() to see a Google Maps API markers array being modified.

One can always return the object to a string at the end of the process with oSC.Run("JSON_stringify", objParsed). See the final lines.

Option Explicit

'* 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 SC() As ScriptControl
    Static soSC As ScriptControl
    If soSC Is Nothing Then

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

        soSC.AddCode GetJavaScriptLibrary("https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js")
        soSC.AddCode "function JSON_stringify(jsonObj) { return JSON.stringify(jsonObj); } "
        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

Sub GutJSONArray()
    Dim oSC As ScriptControl
    Set oSC = SC

    Dim sGoogleMapsMarkers As String
    sGoogleMapsMarkers = "{ ""markers"": [  {  ""name"": ""Rixos The Palm Dubai"", ""position"": [25.1212, 55.1535]  }, " & _
            "{ ""name"": ""Shangri-La Hotel"", ""location"": [25.2084, 55.2719] }," & _
            "{ ""name"": ""Grand Hyatt"",  ""location"": [25.2285, 55.3273]     } ] }"

    Dim objParsed As Object
    Set objParsed = oSC.Run("JSON_parse", sGoogleMapsMarkers)
    
    Dim objMarkers As Object
    Set objMarkers = CallByName(objParsed, "markers", VbGet)
    
    Dim lLoop As Long
    For lLoop = 2 To 0 Step -2 '* count backwards when deleting
                
       Call CallByName(objMarkers, "splice", VbMethod, lLoop, 1) '* intrinsic javascript array.splice method
    
    Next lLoop
    
    Dim sGutted As String
    sGutted = oSC.Run("JSON_stringify", objParsed)

    Debug.Print sGutted
    Debug.Assert sGutted = "{""markers"":[{""name"":""Shangri-La Hotel"",""location"":[25.2084,55.2719]}]}"

End Sub

Make VBA Array Literals plus some variables

So just browsing a Python tutorial currently and it is impressive how newer languages such as Python and Javascript have the ability to create tuples and data structures on the fly. VBA has an array literal syntax which can accept both numbers and strings but supplying a variable into one of the locations breaks. So I've decided to write some code and might as well share

Sub DemoMakeArrayLiteral()
    Dim v
    v = [{1,2;3,4}]
    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = 2
    Debug.Assert v(2, 1) = 3
    Debug.Assert v(2, 2) = 4
    
    Dim v2
    v2 = [{1,2;3,"foo"}] '* with a string literal
    Debug.Assert v2(1, 1) = 1
    Debug.Assert v2(1, 2) = 2
    Debug.Assert v2(2, 1) = 3
    Debug.Assert v2(2, 2) = "foo"
    
    Dim a
    a = "bar"
    Dim v3
    v3 = [{1,2;3,a}] '* WRONG WAY for a variable, contaminates whole array
    Debug.Assert IsError(v3)

    Dim v4
    v4 = MakeArrayLiteral([{1,2;3,"$0"}], a) '* RIGHT WAY for a variable
    Debug.Assert v4(1, 1) = 1
    Debug.Assert v4(1, 2) = 2
    Debug.Assert v4(2, 1) = 3
    Debug.Assert v4(2, 2) = "bar"


End Sub





Private Function MakeArrayLiteral(ByVal vSeed As Variant, ParamArray args() As Variant) As Variant
    
    If IsError(vSeed) Then GoTo SingleExit
    
    Dim lArgCount As Long
    lArgCount = UBound(args) - LBound(args) + 1
    
    If lArgCount > 0 Then
        
        Dim dicReplacements As Scripting.Dictionary
        
        Dim dicGetDimsAndBounds As Scripting.Dictionary
        Set dicGetDimsAndBounds = GetDimsAndBounds(vSeed)
        
        Dim lDollarNum As Long
        lDollarNum = -1
        
        If dicGetDimsAndBounds.Count = 0 Then
            lDollarNum = GetDollarNum(vSeed)
            If lDollarNum <> -1 And lDollarNum <= lArgCount - 1 Then
                vSeed = Replace(vSeed, "$" & lDollarNum, args(lDollarNum))
            End If
        ElseIf dicGetDimsAndBounds.Count = 1 Then
        
            'Stop
            Dim vBounds As Variant
            vBounds = dicGetDimsAndBounds.Item(1)
            Dim lIndex As Long
            For lIndex = vBounds(0) To vBounds(1)
                lDollarNum = GetDollarNum(vSeed(lIndex))
                If lDollarNum <> -1 And lDollarNum <= lArgCount - 1 Then
                    vSeed(lIndex) = Replace(vSeed(lIndex), "$" & lDollarNum, args(lDollarNum))
                End If
            Next
        
        ElseIf dicGetDimsAndBounds.Count = 2 Then
            Dim vYBounds As Variant
            vYBounds = dicGetDimsAndBounds.Item(1)
        
            Dim vXBounds As Variant
            vXBounds = dicGetDimsAndBounds.Item(2)
        
            Dim lXIndex As Long
            For lXIndex = vXBounds(0) To vXBounds(1)
                
                Dim lYIndex As Long
                For lYIndex = vYBounds(0) To vYBounds(1)
                
                    lDollarNum = GetDollarNum(vSeed(lYIndex, lXIndex))
                    If lDollarNum <> -1 And lDollarNum <= lArgCount - 1 Then
                        vSeed(lYIndex, lXIndex) = Replace(vSeed(lYIndex, lXIndex), "$" & lDollarNum, args(lDollarNum))
                    End If
        
                Next
            Next
        
        ElseIf dicGetDimsAndBounds.Count > 2 Then
            Err.Raise vbObjectError, , "#Dimensions greater than 2 not yet supported!"
        End If
        
    
    
    
    
    End If
SingleExit:
    MakeArrayLiteral = vSeed
End Function


Private Function GetDims(ByRef v) As Long
    On Error GoTo BadDimension
    GetDims = 0
    Dim lDim As Long
    For lDim = 1 To 100
        Dim vTest As Variant
        vTest = LBound(v, lDim)
        GetDims = lDim
    Next lDim
SingleExit:
    Exit Function
BadDimension:
    GoTo SingleExit
End Function


Private Function GetDimsAndBounds(v As Variant) As Scripting.Dictionary

    Dim dic As Scripting.Dictionary
    Set dic = New Scripting.Dictionary
    
    Dim lDims As Long
    lDims = GetDims(v)
    
    Dim lDimLoop As Long
    For lDimLoop = 1 To lDims
        
        ReDim bounds(0 To 1)
        bounds(0) = LBound(v, lDimLoop)
        bounds(1) = UBound(v, lDimLoop)
        dic.Add lDimLoop, bounds
    
    Next
    Set GetDimsAndBounds = dic

End Function

Private Function GetDollarNum(ByRef v) As Long

    Debug.Assert Not IsError(v)


    GetDollarNum = -1
    
    

    Static reDollarNum As VBScript_RegExp_55.RegExp
    If reDollarNum Is Nothing Then
        Set reDollarNum = New VBScript_RegExp_55.RegExp
        reDollarNum.Pattern = "\$(\d+)"
    End If

    If reDollarNum.Test(v) Then
        Dim oMatchCol As VBScript_RegExp_55.MatchCollection
        Set oMatchCol = reDollarNum.Execute(v)
        If oMatchCol.Count = 1 Then
            Dim oMatch As VBScript_RegExp_55.Match
            Set oMatch = oMatchCol.Item(0)
            If oMatch.SubMatches.Count = 1 Then
                GetDollarNum = CLng(oMatch.SubMatches(0))
            End If
        End If
    End If

End Function

'* UNIT TESTS
Private Sub TestGetDollarNum()

    Debug.Assert GetDollarNum("$456") = 456
    Debug.Assert GetDollarNum("$45.6") = 45
    Debug.Assert GetDollarNum("$6") = 6
    Debug.Assert GetDollarNum("$77") = 77
    Debug.Assert GetDollarNum("$") = -1

End Sub

Private Sub TestGetDims()
    Dim scalar As Variant
    scalar = 1
    Debug.Assert GetDims(scalar) = 0

    Dim v1
    v1 = [{1,2}]
    Debug.Assert GetDims(v1) = 1

    Dim v
    v = [{1,2;3,4}]
    Debug.Assert GetDims(v) = 2

    Dim z
    z = [{"1","2";"3","4"}]
    Debug.Assert GetDims(z) = 2
End Sub

Sub TestMakeArrayLiteral()
    Dim v As Variant
    v = MakeArrayLiteral([{1,2;3,4}])
    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = 2
    Debug.Assert v(2, 1) = 3
    Debug.Assert v(2, 2) = 4
    
End Sub


Sub TestMakeArrayLiteral0()
    Dim v As Variant
    v = MakeArrayLiteral("$0", "FOO")
    Debug.Assert v = "FOO"
    
End Sub

Sub TestMakeArrayLiteral1()
    Dim v As Variant
    v = MakeArrayLiteral([{1,2,"$0"}], "FOO")
    Debug.Assert v(3) = "FOO"
    
End Sub

Sub TestMakeArrayLiteral2()
    Dim v As Variant
    v = MakeArrayLiteral([{1,2;3,"$0"}], "FOO")
    Debug.Assert v(2, 2) = "FOO"
    
End Sub

Sub TestMakeArrayLiteral3()
    Dim v As Variant
    v = MakeArrayLiteral([{1,"$1";3,"$0"}], "FOO", "BAR")
    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = "BAR"
    Debug.Assert v(2, 1) = 3
    Debug.Assert v(2, 2) = "FOO"
    
End Sub

Sub TestMakeArrayLiteral4()
    Dim v As Variant
    v = MakeArrayLiteral([{1,"$1fly";3,"$0"}], "FOO", "BAR")
    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = "BARfly"
    Debug.Assert v(2, 1) = 3
    Debug.Assert v(2, 2) = "FOO"
    
End Sub