VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ClsJSONLib"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
' original source https://code.google.com/archive/p/vba-json, with fixes.
Const INVALID_JSON      As Long = 1
Const INVALID_OBJECT    As Long = 2
Const INVALID_ARRAY     As Long = 3
Const INVALID_BOOLEAN   As Long = 4
Const INVALID_NULL      As Long = 5
Const INVALID_KEY       As Long = 6

'
'   parse string and create JSON object (Dictionary or Collection in VB)
'
Public Function parse(ByRef str As String) As Object '@notrace
  
   Dim index As Long
   index = 1
   skipChar str, index
   Select Case Mid$(str, index, 1)
      Case "{"
         Set parse = parseObject(str, index)
      Case "["
         Set parse = parseArray(str, index)
      Case Else
         Err.Raise vbObjectError + INVALID_JSON, Description:="char " & index & " : " & Mid$(str, index, 1)
   End Select

End Function

'
'   parse collection of key/value (Dictionary in VB)
'
Private Function parseObject(ByRef str As String, ByRef index As Long) As Object '@notrace
  
   Set parseObject = New Scripting.Dictionary  '  CreateObject("Scripting.Dictionary")

   ' "{"
   skipChar str, index
   If Mid$(str, index, 1) <> "{" Then Err.Raise vbObjectError + INVALID_OBJECT, Description:="char " & index & " : " & Mid$(str, index)
   index = index + 1

   Do

      skipChar str, index
      If "}" = Mid$(str, index, 1) Then
         index = index + 1
         Exit Do
      ElseIf "," = Mid$(str, index, 1) Then
         index = index + 1
         skipChar str, index
      End If

      ' add key/value pair
      parseObject.Add Key:=parseKey(str, index), Item:=parseValue(str, index)

   Loop

End Function

'
'   parse list (Collection in VB)
'
Private Function parseArray(ByRef str As String, ByRef index As Long) As Collection '@notrace
  
   Set parseArray = New Collection

   ' "["
   skipChar str, index
   If Mid$(str, index, 1) <> "[" Then Err.Raise vbObjectError + INVALID_ARRAY, Description:="char " & index & " : " + Mid$(str, index)
   index = index + 1

   Do

      skipChar str, index
      If "]" = Mid$(str, index, 1) Then
         index = index + 1
         Exit Do
      ElseIf "," = Mid$(str, index, 1) Then
         index = index + 1
         skipChar str, index
      End If

      ' add value
      parseArray.Add parseValue(str, index)

   Loop

End Function

'
'   parse string / number / object / array / true / false / null
'
Private Function parseValue(ByRef str As String, ByRef index As Long) As Variant '@notrace
  
   skipChar str, index

   Select Case Mid$(str, index, 1)
      Case "{"
         Set parseValue = parseObject(str, index)
      Case "["
         Set parseValue = parseArray(str, index)
      Case """", "'" ' double, single quotes
         parseValue = parseString(str, index)
      Case "t", "f"
         parseValue = parseBoolean(str, index)
      Case "n"
         parseValue = parseNull(str, index)
      Case Else
         parseValue = parseNumber(str, index)
   End Select

End Function

'
'   parse string
'
Private Function parseString(ByRef str As String, ByRef index As Long) As String '@notrace
  
   Dim quote   As String
   Dim Char    As String
   Dim code    As String

   skipChar str, index
   quote = Mid$(str, index, 1)
   index = index + 1
   Do While index > 0 And index <= Len(str)
      Char = Mid$(str, index, 1)
      Select Case (Char)
         Case "\"
            index = index + 1
            Char = Mid$(str, index, 1)
            Select Case (Char)
               Case """", "\", "/"   ' POB fix issue 22 in lib
                  'https://code.google.com/archive/p/vba-json/issues
                  parseString = parseString & Char
                  index = index + 1
               Case "b"
                  parseString = parseString & vbBack
                  index = index + 1
               Case "f"
                  parseString = parseString & vbFormFeed
                  index = index + 1
               Case "n"
                  parseString = parseString & vbNewLine
                  index = index + 1
               Case "r"
                  parseString = parseString & vbCr
                  index = index + 1
               Case "t"
                  parseString = parseString & vbTab
                  index = index + 1
               Case "u"
                  index = index + 1
                  code = Mid$(str, index, 4)
                  parseString = parseString & ChrW$(Val("&h" + code))
                  index = index + 4
            End Select
         Case quote
            index = index + 1
            Exit Function
         Case Else
            parseString = parseString & Char
            index = index + 1
      End Select
   Loop

End Function

'
'   parse number
'
Private Function parseNumber(ByRef str As String, ByRef index As Long) As Double '@notrace
  
   Dim Value   As String
   Dim Char    As String

   skipChar str, index
   Do While index > 0 And index <= Len(str)
      Char = Mid$(str, index, 1)
      If InStr("+-0123456789.eE", Char) Then
         Value = Value & Char
         index = index + 1
      Else
         parseNumber = CDbl(Value)
          '4.27 POB always Double, not Int, need not be decimal point in long number eg 623478675
          ' in VB could use CDec()
         Exit Function
      End If
   Loop


End Function

'
'   parse true / false
'
Private Function parseBoolean(ByRef str As String, ByRef index As Long) As Boolean '@notrace
  
   skipChar str, index
   If Mid$(str, index, 4) = "true" Then
      parseBoolean = True
      index = index + 4
   ElseIf Mid$(str, index, 5) = "false" Then
      parseBoolean = False
      index = index + 5
   Else
      Err.Raise vbObjectError + INVALID_BOOLEAN, Description:="char " & index & " : " & Mid$(str, index)
   End If

End Function

'
'   parse null
'
Private Function parseNull(ByRef str As String, ByRef index As Long) As Variant '@notrace
  
   skipChar str, index
   If Mid$(str, index, 4) = "null" Then
      parseNull = Null
      index = index + 4
   Else
      Err.Raise vbObjectError + INVALID_NULL, Description:="char " & index & " : " & Mid$(str, index)
   End If

End Function

Private Function parseKey(ByRef str As String, ByRef index As Long) As String '@notrace
  
   Dim dQuote  As Boolean
   Dim sQuote  As Boolean
   Dim Char    As String
   Const WHITESPACE As String = vbCr & vbLf & vbTab & " "
   skipChar str, index
   Do While index > 0 And index <= Len(str)
      Char = Mid$(str, index, 1)
      Select Case (Char)
         Case """"
            dQuote = Not dQuote
            index = index + 1
            If Not dQuote Then
               skipChar str, index
               If Mid$(str, index, 1) <> ":" Then
                  Err.Raise vbObjectError + INVALID_KEY, Description:="char " & index & " : " & parseKey
               End If
            End If
         Case "'"
            sQuote = Not sQuote
            index = index + 1
            If Not sQuote Then
               skipChar str, index
               If Mid$(str, index, 1) <> ":" Then
                  Err.Raise vbObjectError + INVALID_KEY, Description:="char " & index & " : " & parseKey
               End If
            End If
         Case ":"
            index = index + 1
            If dQuote Or sQuote Then
               parseKey = parseKey & Char
               ' POB do not Exit Do, this is a colon inside a key eg "configGlossary:installationAt"
            Else
               Exit Do
            End If
            
         Case Else
            If InStr(WHITESPACE, Char) = 0 Then
               parseKey = parseKey & Char
            End If
            index = index + 1
      End Select
   Loop

End Function

'
'   skip special character
'
Friend Sub skipChar(ByRef str As String, ByRef index As Long)  '@notrace ' Dev:Friend; should be Private for prod
  
   Do While index > 0 And index <= Len(str) And InStr(vbCr & vbLf & vbTab & " ", Mid$(str, index, 1))  '4.27 POB don't need vbCrLf as well
      index = index + 1
   Loop

End Sub

Public Function toString(ByRef obj As Variant) As String '@notrace
  
   Select Case VarType(obj)
      Case vbNull
         toString = "null"
      Case vbDate
         toString = """" & CStr(obj) & """"
      Case vbString
         toString = """" & encode(obj) & """"
      Case vbObject
         Dim bFI As Boolean, i As Long
         bFI = True
         If TypeName(obj) = "Dictionary" Then
            toString = toString & "{"
            Dim keys As Variant
            keys = obj.keys
            For i = 0 To obj.Count - 1
               If bFI Then
                  bFI = False
               Else
                  toString = toString & ","
               End If
               Dim Key As Variant
               Key = keys(i)
               toString = toString & """" & Key & """:" & toString(obj(Key))
            Next i
            toString = toString & "}"
         ElseIf TypeName(obj) = "Collection" Then
            toString = toString & "["
            Dim Value As Variant
            For Each Value In obj
               If bFI Then bFI = False Else toString = toString & ","
               toString = toString & toString(Value)
            Next Value
            toString = toString & "]"
         End If
      Case vbBoolean
         If obj Then toString = "true" Else toString = "false"
      Case vbVariant, vbArray, vbArray + vbVariant
         Dim sEB As String
         toString = multiArray(obj, 1, vbNullString, sEB)
      Case Else
         toString = Replace(obj, ",", ".")
   End Select

End Function

Private Function encode(ByVal StringToEncode As String) As String '@notrace
  
   Dim i As Long, j As Long, aL1 As Variant, aL2 As Variant, c As String, p As Boolean

   aL1 = Array(&H22, &H5C, &H2F, &H8, &HC, &HA, &HD, &H9)
   aL2 = Array(&H22, &H5C, &H2F, &H62, &H66, &H6E, &H72, &H74)
   For i = 1 To Len(StringToEncode)
      p = True
      c = Mid$(StringToEncode, i, 1)
      For j = 0 To 7
         If c = Chr$(aL1(j)) Then
            encode = encode & "\" & Chr$(aL2(j))
            p = False
            Exit For
         End If
      Next

      If p Then
         Dim a As Long
         a = AscW(c)
         If a > 31 And a < 127 Then
            encode = encode & c
         ElseIf a > -1 Or a < 65535 Then
            encode = encode & "\u" & String(4 - Len(Hex$(a)), "0") & Hex$(a)
         End If
      End If
   Next
End Function

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

   Dim sPB1 As String, sPB2 As String ' 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
      multiArray = multiArray & toString(aBD(sPB2))
   Else
      sPT = sPT & sPS
      multiArray = multiArray & "["
      For i = iDL To iDU
         multiArray = multiArray & multiArray(aBD, iBC + 1, CStr(i), sPT)
         If i < iDU Then multiArray = multiArray & ","
      Next
      multiArray = multiArray & "]"
      sPT = Left$(sPT, iBC - 2)
   End If
   On Error GoTo 0
End Function