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
No comments:
Post a Comment