Sunday, 8 October 2017

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

No comments:

Post a Comment