search

rasc5 / vba-json

Automatically exported from code.google.com/p/vba-json
0 stars 0 forks source link

Unable to handle multi-dimensional arrays #15

Open GoogleCodeExporter opened 8 years ago

GoogleCodeExporter commented 8 years ago 
What steps will reproduce the problem?
1.  Dim theData(1,1,1)
    theData(0,0,0)=1
    Dim lib As New jsonlib
    Dim jsonStr As String
    jsonStr = lib.toString(theData)
2.
3.

What is the expected output? What do you see instead?
Should see: [[[1,],[,]],[[,],[,]]]
Actually see: [[[,],[,]],[[,],[,]]]

What version of the product are you using? On what operating system?
R2. Windows 7. Excel 2007.

Please provide any additional information below.
The problem occurs in the multiArray function.

As far as I can gather, VBA doesn't allow you to work with an array with an 
unknown number of dimensions (it would need a splat operator).

The following code provides a fudge for up to 10 dimensions (with the unneeded 
old code commented out.

Private Function multiArray(aBD, iBC, sPS, ByRef sPT)   ' Array BoDy, Integer 
BaseCount, String PoSition
    Dim iDU, iDL, i ' Integer DimensionUBound, Integer DimensionLBound
    On Error Resume Next
    iDL = LBound(aBD, iBC)
    iDU = UBound(aBD, iBC)

    Dim sPB1, sPB2, NoDimensions As Long, DimList() As Long ' String PointBuffer1, String PointBuffer2
    If Err.Number = 9 Then
        sPB1 = sPT & sPS
        NoDimensions = Len(sPB1)
        ReDim DimList(1 To NoDimensions)
        For i = 1 To Len(sPB1)
            'If i <> 1 Then sPB2 = sPB2 & ","
            'sPB2 = sPB2 & Mid(sPB1, i, 1)
            DimList(i) = CLng(Mid(sPB1, i, 1))
        Next

'        multiArray = multiArray & toString(Eval("aBD(" & sPB2 & ")"))
'        multiArray = multiArray & toString(aBD(sPB2)) 'This was the original 
line, replaced by DJM by the code Select statement below.
        Select Case NoDimensions
            Case 1
                multiArray = multiArray & toString(aBD(DimList(1)))
            Case 2
                multiArray = multiArray & toString(aBD(DimList(1), DimList(2)))
            Case 3
                multiArray = multiArray & toString(aBD(DimList(1), DimList(2), DimList(3)))
            Case 4
                multiArray = multiArray & toString(aBD(DimList(1), DimList(2), DimList(3), DimList(4)))
            Case 5
                multiArray = multiArray & toString(aBD(DimList(1), DimList(2), DimList(3), DimList(4), DimList(5)))
            Case 6
                multiArray = multiArray & toString(aBD(DimList(1), DimList(2), DimList(3), DimList(4), DimList(5), DimList(6)))
            Case 7
                multiArray = multiArray & toString(aBD(DimList(1), DimList(2), DimList(3), DimList(4), DimList(5), DimList(6), DimList(7)))
            Case 8
                multiArray = multiArray & toString(aBD(DimList(1), DimList(2), DimList(3), DimList(4), DimList(5), DimList(6), DimList(7), DimList(8)))
            Case 9
                multiArray = multiArray & toString(aBD(DimList(1), DimList(2), DimList(3), DimList(4), DimList(5), DimList(6), DimList(7), DimList(8), DimList(9)))
            Case 10
                multiArray = multiArray & toString(aBD(DimList(1), DimList(2), DimList(3), DimList(4), DimList(5), DimList(6), DimList(7), DimList(8), DimList(9), DimList(10)))
            Case Else
                'Not much point in doing anything here. The error would just leave it blank.
        End Select
    Else
        sPT = sPT & sPS
        multiArray = multiArray & "["
        For i = iDL To iDU
            multiArray = multiArray & multiArray(aBD, iBC + 1, i, sPT)
            If i < iDU Then multiArray = multiArray & ","
        Next
        multiArray = multiArray & "]"
        sPT = Left(sPT, iBC - 2)
    End If
    Err.Clear
End Function

Original issue reported on code.google.com by djm...@googlemail.com on 28 Aug 2012 at 12:14

GoogleCodeExporter commented 8 years ago 
Correction: I hadn't properly understand what the code was intended to do, so 
my fix above doesn't work. This correction works, but only works for up to 2 
dimensions.

You can extend it to more dimensions but it is a faff, and as far as I can tell 
there is no way to do call a member of an array in VBA when you have an unknown 
number of dimensions.

I have also added the small helper function HowManyDimensions(AnArray). You 
also have to change a line of the toString function to read:             
toString = multiArray(obj)

Updated multiArray function below, and the full jsonlib file attached.

Private Function multiArray(aBD)  ' Array BoDy, Integer BaseCount, String 
PoSition
    Dim NoDimensions
    Dim i1 As Long, i2 As Long
    Dim DimList(1 To 10) As Long

    NoDimensions = HowManyDimensions(aBD)
    Select Case NoDimensions
        Case 1
            multiArray = multiArray & "["
            For i1 = LBound(aBD, 1) To UBound(aBD, 1)
                multiArray = multiArray & toString(aBD(i1))
                If i1 < UBound(aBD, 1) Then multiArray = multiArray & ","
            Next i1
            multiArray = multiArray & "]"
        Case 2
            multiArray = multiArray & "["
            For i1 = LBound(aBD, 1) To UBound(aBD, 1)
                multiArray = multiArray & "["
                For i2 = LBound(aBD, 2) To UBound(aBD, 2)
                    multiArray = multiArray & toString(aBD(i1, i2))
                    If i2 < UBound(aBD, 2) Then multiArray = multiArray & ","
                Next i2
                multiArray = multiArray & "]"
                If i1 < UBound(aBD, 1) Then multiArray = multiArray & ","
            Next i1
            multiArray = multiArray & "]"
        Case Else
            'Not much point in doing anything here. The error would just leave it blank.
    End Select
End Function

Private Function HowManyDimensions(AnArray) As Long
    'find number of dimensions
    On Error GoTo DimensionOverflow
    Dim ErrorCheck As Long, DimensionNumber As Long
    For DimensionNumber = 1 To 60001
        ErrorCheck = LBound(AnArray, DimensionNumber)
    Next DimensionNumber

DimensionOverflow:
    HowManyDimensions = DimensionNumber - 1
End Function

Original comment by djm...@googlemail.com on 29 Aug 2012 at 11:36

Attachments:

GoogleCodeExporter commented 8 years ago 
I was able to make the code work for up to 7 levels of nesting by just using a 
call to "split" followed by a select case:

Private Function multiArray(aBD, iBC, sPS, ByRef sPT)   ' Array BoDy, Integer 
BaseCount, String PoSition

   Dim iDU As Long
   Dim iDL As Long
   Dim i As Long

   On Error Resume Next
   iDL = LBound(aBD, iBC)
   iDU = UBound(aBD, iBC)

   Dim SB As New cStringBuilder

   Dim sPB1 As String, sPB2 As String, aPB2 As Variant ' String PointBuffer1, String PointBuffer2
   If Err.Number = 9 Then
      sPB1 = sPT & sPS
      For i = 1 To Len(sPB1)
         If i <> 1 Then sPB2 = sPB2 & ","
         sPB2 = sPB2 & Mid(sPB1, i, 1)
      Next
      'SB.Append toString(Eval("aBD(" & sPB2 & ")"))
      aPB2 = Split(sPB2, ",")
      Select Case UBound(aPB2)
      Case 0
              SB.Append toString(aBD(aPB2(0)))
      Case 1
              SB.Append toString(aBD(aPB2(0), aPB2(1)))
      Case 2
              SB.Append toString(aBD(aPB2(0), aPB2(1), aPB2(2)))
      Case 3
              SB.Append toString(aBD(aPB2(0), aPB2(1), aPB2(2), aPB2(3)))
      Case 4
              SB.Append toString(aBD(aPB2(0), aPB2(1), aPB2(2), aPB2(3), aPB2(4)))
      Case 5
              SB.Append toString(aBD(aPB2(0), aPB2(1), aPB2(2), aPB2(3), aPB2(4), aPB2(5)))
      Case 6
              SB.Append toString(aBD(aPB2(0), aPB2(1), aPB2(2), aPB2(3), aPB2(4), aPB2(5), aPB2(6)))
      Case Else
        SB.Append "#Nesting too deep#"
      End Select
      SB.Append toString(aBD(sPB2))
   Else
      sPT = sPT & sPS
      SB.Append "["
      For i = iDL To iDU
         SB.Append multiArray(aBD, iBC + 1, i, sPT)
         If i < iDU Then SB.Append ","
      Next
      SB.Append "]"
      sPT = Left(sPT, iBC - 2)
   End If
   Err.Clear
   multiArray = SB.toString

   Set SB = Nothing
End Function

Original comment by walid.na...@gmail.com on 14 Oct 2014 at 11:25

GoogleCodeExporter commented 8 years ago 
Following is better about parseNumber function.
parseNumber = CInt(value)
↓
parseNumber = Clng(value)

Original comment by sasaki...@gmail.com on 18 May 2015 at 8:32