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
' clsJSONLib taken from https://code.google.com/archive/p/vba-json/
' Not stated in that source, but according to Tim Hall the original author was:
' Copyright (c) 2013, Ryo Yokoyama, All rights reserved.

Private Const INVALID_JSON      As Long = 1
Private Const INVALID_OBJECT    As Long = 2
Private Const INVALID_ARRAY     As Long = 3
Private Const INVALID_BOOLEAN   As Long = 4
Private Const INVALID_NULL      As Long = 5
Private Const INVALID_KEY       As Long = 6
Private Const Debug_Mode As Boolean = False ' TESTING

'
'   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) ' Dictionary
      Case "["
         Set parse = parseArray(str, Index)  ' Collection
      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 = CreateObject("Scripting.Dictionary")   ' requires reference to Microsoft Scripting Runtime

   ' "{"
   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
   If Debug_Mode Then Debug.Print Index & " parseObject.Count " & parseObject.Count

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
   If Debug_Mode Then Debug.Print Index & " parseArray.Count " & parseArray.Count

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
   If Debug_Mode Then Debug.Print Index & " parseValue " & TypeName(parseValue)
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
                  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 = Val(value)
         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

   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 ":"
            If Not dquote And Not sQuote Then
               Index = Index + 1
               Exit Do
            End If
         Case Else
            If InStr(vbCr & vbLf & vbTab & " ", Char) = 0 Then
               parseKey = parseKey & Char
            End If
            Index = Index + 1
      End Select
   Loop
   If Debug_Mode Then Debug.Print Index & " parseKey=" & parseKey
End Function

'
'   skip special character
'
Friend Sub skipChar(ByRef str As String, ByRef Index As Long)  '@notrace ' Dev:Friend; should be Private for prod

   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
   Wend

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
            keys = obj.keys
            For i = 0 To obj.Count - 1
               If bFI Then
                  bFI = False
               Else
                  toString = toString & ","
               End If
               Dim key
               key = keys(i)
               toString = toString & """" & key & """:" & toString(obj(key))
            Next i
            toString = toString & "}"
         ElseIf TypeName(obj) = "Collection" Then
            toString = toString & "["
            Dim value
            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(str) As String '@notrace ' converts text to json character codes like \n \r

   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)      ' " \ / BS FF LF CR TAB
               ' 34    92    47    8   12   10   13   9
   aL2 = Array(&H22, &H5C, &H2F, &H62, &H66, &H6E, &H72, &H74) ' " \ / b f n r t
              '  34    92    47    98   102   110   114   116

   For i = 1 To Len(str)
      p = True
      c = Mid$(str, 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
         Else   'was: If a > -1 Or a < 65535 Then
            If a < 0 Then 'POB handle Asian characters a<0 eg -10179 = 55357 = D83D
               a = 65536 + a
            End If
            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
   Dim lErr As Long, sPB1, sPB2  ' String PointBuffer1, String PointBuffer2
   On Error Resume Next
   iDL = LBound(aBD, iBC)
   iDU = UBound(aBD, iBC)
   lErr = Err.Number ' error 9 if unallocated array
   On Error GoTo 0
   If lErr <> 0 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 & "]"
      If iBC > 1 Then  ' POB fix case when iBC=1
         sPT = Left$(sPT, iBC - 2)
      End If
   End If
End Function