VBCommons/utility/API_JSON.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "API_JSON"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ======== JSON converter ========
' Shared module version: 20220813
' Tested in: TestCommons
' Depends on:
' Required reference: Scripting
' This code is based on rethinking VBA-JSON,  https://github.com/VBA-tools/VBA-JSON
Option Explicit

Private Const ERR_PARSE_FAIL = vbObject + 2049

' JSON states esaping '/' as optional.
' Use this flag to escape them as '\/'
Public escapeSlash_ As Boolean

' JSON doesnt require escaping of non-AscII chars.
' Use this flag to enable \u codes escape mechanics
Public escapeUnicode_ As Boolean

Private multiline_ As Boolean
Private wsCharacter_ As String
Private wsCount_ As Long

Private json_ As String
Private inputLen_ As Long
Private position_ As Long

Private Sub Class_Initialize()
  escapeSlash_ = False
  escapeUnicode_ = False
  Call DisableMultiline
End Sub

' {Integer|String} vWhitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string
Public Function SetupMultiline(ByVal vWhitespace As Variant)
  multiline_ = True
  If VBA.VarType(vWhitespace) = VBA.vbString Then
    wsCharacter_ = vWhitespace
    wsCount_ = -1
  Else
    wsCharacter_ = vbNullString
    wsCount_ = vWhitespace
  End If
End Function

Public Function DisableMultiline()
  multiline_ = False
  wsCharacter_ = vbNullString
  wsCount_ = -1
End Function

' Convert object (Dictionary/Collection/Array) to JSON
Public Function CreateJSON(ByRef vValue As Variant) As String
  CreateJSON = Generator_Process(vValue)
End Function

' Convert JSON string to object (Dictionary/Collection)
Public Function Parse(sJson$) As Object
  json_ = VBA.Replace(VBA.Replace(VBA.Replace(sJson, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "")
  position_ = 1
  inputLen_ = VBA.Len(json_)

  Call Parser_SkipWS
  
  Select Case Parser_ViewAny()
  Case "{": Set Parse = Parser_Object()
  Case "[": Set Parse = Parser_Array()
  Case Else: Call Parser_RaiseError("Expected '{' or '['")
  End Select
  
  If position_ <= inputLen_ Then _
    Call Parser_RaiseError("Some part of input is out of main object scope")
  
  json_ = vbNullString
End Function

Public Function SaveToFile(sFile$, iData As Object) As Boolean
  Const DO_OVERWRITE& = 2

  SaveToFile = False
  On Error GoTo EXIT_ERROR
  
  Dim adoStream As Object: Set adoStream = CreateObject("ADODB.Stream")
  adoStream.Charset = "utf-8"
  Call adoStream.Open
  Call adoStream.WriteText(CreateJSON(iData))
  Call adoStream.SaveToFile(sFile, DO_OVERWRITE)
  
  SaveToFile = True
  
EXIT_ERROR:
  On Error GoTo 0
  Call adoStream.Close
End Function

Public Function LoadFromFile(sFile$) As Object
  Dim sJson$: sJson = ReadFile(sFile)
  If sJson = vbNullString Then _
    Exit Function
  Set LoadFromFile = Parse(sJson)
End Function

' =============================================
Private Function ReadFile(sFile$) As String
  Dim adoStream As Object: Set adoStream = CreateObject("ADODB.Stream")
  adoStream.Charset = "utf-8"
  Call adoStream.Open
  
  On Error GoTo ERROR_FILE
  Call adoStream.LoadFromFile(sFile)
  On Error GoTo 0
  
  ReadFile = adoStream.ReadText
  
ERROR_FILE:
  Call adoStream.Close
  On Error GoTo 0
End Function

Private Function Generator_Process(ByRef vValue As Variant, Optional nIdent& = 0) As String
  Select Case VBA.VarType(vValue)
  Case VBA.vbNull: Generator_Process = "null"
  Case VBA.vbBoolean: Generator_Process = IIf(vValue, "true", "false")
  Case VBA.vbDate: Generator_Process = """" & CDbl(vValue) & """"
  Case VBA.vbString
    If IsLargeNumber(vValue) Then
      Generator_Process = vValue ' Large number encoded as string
    Else
      Generator_Process = """" & EncodeStr(vValue) & """"
    End If
    
  Case VBA.vbArray To VBA.vbArray + VBA.vbByte: Generator_Process = Generator_Array(vValue, nIdent)
  
  Case VBA.vbObject
    If VBA.TypeName(vValue) = "Dictionary" Then
      Generator_Process = Generator_Dictionary(vValue, nIdent)
    ElseIf VBA.TypeName(vValue) = "Collection" Then
      Generator_Process = Generator_Collection(vValue, nIdent)
    Else ' TODO: call custom object function to generate JSON!
      Call Err.Raise(1000, Description:="Unknown object type. Please use Dictionary or Collection")
    End If

  Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal
    Generator_Process = VBA.Replace(vValue, ",", ".") ' Number (use decimals for numbers)
  Case Else ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType
    On Error Resume Next
    Generator_Process = vValue
    On Error GoTo 0
  End Select
End Function

Private Function Generator_Array(ByRef vValue As Variant, nIdent&) As String
  Dim sBuffer$
  Dim nBufferPosition&
  Dim nBufferLen&
  Call BufferAppend(sBuffer, "[", nBufferPosition, nBufferLen)
  
  Dim nSize1&: nSize1 = ArraySize(vValue, 1)
  If nSize1 <= 0 Then _
    GoTo PRINT_TO_STR
  Dim nIndex1Start&: nIndex1Start = LBound(vValue, 1)
  
  Dim nSize2&: nSize2 = ArraySize(vValue, 2)
  Dim nIndex2Start&
  If nSize2 > 0 Then _
    nIndex2Start = LBound(vValue, 2)

  Dim sIndentLevel1$: sIndentLevel1 = GetWS(nIdent + 1)
  Dim sIndentLevel2$: sIndentLevel2 = GetWS(nIdent + 2)

  Dim bIsFirst: bIsFirst = True
  Dim json_Converted$
  Dim nIndex1&
  For nIndex1 = nIndex1Start To nIndex1Start + nSize1 - 1 Step 1
    If Not bIsFirst Then
      Call BufferAppend(sBuffer, ",", nBufferPosition, nBufferLen)
    Else
      bIsFirst = False
    End If

    If nSize2 <= 0 Then  ' 1D Array
      json_Converted = Generator_Nullable(vValue(nIndex1), nIdent + 1)
      If multiline_ Then _
        json_Converted = vbNewLine & sIndentLevel1 & json_Converted
      Call BufferAppend(sBuffer, json_Converted, nBufferPosition, nBufferLen)
    Else ' 2D Array
      If multiline_ Then _
        Call BufferAppend(sBuffer, vbNewLine, nBufferPosition, nBufferLen)
      Call BufferAppend(sBuffer, sIndentLevel1 & "[", nBufferPosition, nBufferLen)
      
      Dim nIndex2&
      Dim bIsFirst2 As Boolean: bIsFirst2 = True
      For nIndex2 = nIndex2Start To nIndex2Start + nSize2 - 1 Step 1
        If Not bIsFirst2 Then
          Call BufferAppend(sBuffer, ",", nBufferPosition, nBufferLen)
        Else
          bIsFirst2 = False
        End If
        json_Converted = Generator_Nullable(vValue(nIndex1, nIndex2), nIdent + 2)
        If multiline_ Then _
          json_Converted = vbNewLine & sIndentLevel2 & json_Converted
        Call BufferAppend(sBuffer, json_Converted, nBufferPosition, nBufferLen)
      Next nIndex2

      If multiline_ Then _
        Call BufferAppend(sBuffer, vbNewLine, nBufferPosition, nBufferLen)
      Call BufferAppend(sBuffer, sIndentLevel1 & "]", nBufferPosition, nBufferLen)
    End If
  Next nIndex1

PRINT_TO_STR:
  On Error GoTo 0
  
  If multiline_ Then
    Call BufferAppend(sBuffer, vbNewLine & GetWS(nIdent) & "]", nBufferPosition, nBufferLen)
  Else
    Call BufferAppend(sBuffer, "]", nBufferPosition, nBufferLen)
  End If
  Generator_Array = BufferToString(sBuffer, nBufferPosition)
End Function

Private Function Generator_Collection(ByRef vValue As Variant, nIdent&) As String
  Dim sBuffer$
  Dim nBufferPosition&
  Dim nBufferLen&
  Call BufferAppend(sBuffer, "[", nBufferPosition, nBufferLen)
  
  Dim bIsFirst As Boolean: bIsFirst = True
  Dim anElement As Variant
  For Each anElement In vValue
    If Not bIsFirst Then
      Call BufferAppend(sBuffer, ",", nBufferPosition, nBufferLen)
    Else
      bIsFirst = False
    End If

    Dim json_Converted$: json_Converted = Generator_Nullable(anElement, nIdent + 1)
    If multiline_ Then _
      json_Converted = vbNewLine & GetWS(nIdent + 1) & json_Converted
    Call BufferAppend(sBuffer, json_Converted, nBufferPosition, nBufferLen)
  Next anElement

  If multiline_ Then
    Call BufferAppend(sBuffer, vbNewLine & GetWS(nIdent) & "]", nBufferPosition, nBufferLen)
  Else
    Call BufferAppend(sBuffer, "]", nBufferPosition, nBufferLen)
  End If
  Generator_Collection = BufferToString(sBuffer, nBufferPosition)
End Function

Private Function Generator_Dictionary(ByRef vValue As Variant, nIdent&) As String
  Dim sBuffer$
  Dim nBufferPosition&
  Dim nBufferLen&
  Call BufferAppend(sBuffer, "{", nBufferPosition, nBufferLen)
  
  Dim bIsFirst As Boolean: bIsFirst = True
  Dim aKey As Variant
  For Each aKey In vValue.Keys
    Dim json_Converted$: json_Converted = Generator_Process(vValue(aKey), nIdent + 1)
    If json_Converted = vbNullString Then _
      If IsUndefined(vValue(aKey)) Then _
        GoTo NEXT_KEY ' For Objects, undefined (Empty/Nothing) is not added to object

    If Not bIsFirst Then
      Call BufferAppend(sBuffer, ",", nBufferPosition, nBufferLen)
    Else
      bIsFirst = False
    End If
    
    If multiline_ Then
      json_Converted = vbNewLine & GetWS(nIdent + 1) & """" & aKey & """: " & json_Converted
    Else
      json_Converted = """" & aKey & """:" & json_Converted
    End If

    Call BufferAppend(sBuffer, json_Converted, nBufferPosition, nBufferLen)
NEXT_KEY:
  Next aKey

  If multiline_ Then
    Call BufferAppend(sBuffer, vbNewLine & GetWS(nIdent) & "}", nBufferPosition, nBufferLen)
  Else
    Call BufferAppend(sBuffer, "}", nBufferPosition, nBufferLen)
  End If
  Generator_Dictionary = BufferToString(sBuffer, nBufferPosition)
End Function

Private Function Generator_Nullable(ByVal vValue As Variant, nIdent&)
  Generator_Nullable = Generator_Process(vValue, nIdent)
  If Generator_Nullable = vbNullString Then _
    If IsUndefined(vValue) Then _
      Generator_Nullable = "null"
End Function

Private Function Parser_Object() As Scripting.Dictionary
  If Parser_ConsumeChar() <> "{" Then _
    Call Parser_RaiseError("Expected '{'")
    
  Set Parser_Object = New Scripting.Dictionary
  Do
    Call Parser_SkipWS
    Dim sNextChar$: sNextChar = Parser_ViewChar()
    If sNextChar = "}" Then
      Call Parser_Increment
      Exit Function
    ElseIf sNextChar = "," Then
      Call Parser_Increment
      Call Parser_SkipWS
    End If

    Dim sKey$: sKey = Parser_Key()
    If Parser_ConsumeChar(1) <> ":" Then _
      Call Parser_RaiseError("Expected ':'")
    sNextChar = Parser_ViewChar()
    If sNextChar = "[" Or sNextChar = "{" Then
      Set Parser_Object.Item(sKey) = Parser_Value()
    Else
      Parser_Object.Item(sKey) = Parser_Value()
    End If
  Loop
End Function

Private Function Parser_Array() As Collection
  If Parser_ConsumeChar() <> "[" Then _
    Call Parser_RaiseError("Expected '['")
  
  Set Parser_Array = New Collection
  Do
    Call Parser_SkipWS
    Dim sChar$: sChar = Parser_ViewChar(1)
    If sChar = "]" Then
      Call Parser_Increment
      Exit Function
    ElseIf sChar = "," Then
      Call Parser_Increment
    End If
    Call Parser_Array.Add(Parser_Value())
  Loop
End Function

Private Function Parser_Value() As Variant
  Call Parser_SkipWS
  Dim sValue$: sValue = Parser_ViewAny(1)
  Select Case sValue
  Case "{": Set Parser_Value = Parser_Object()
  Case "[": Set Parser_Value = Parser_Array()
  Case """", "'": Parser_Value = Parser_String()
  Case Else
    If VBA.InStr("+-0123456789", sValue) Then
      Parser_Value = Parser_Numbers()
      Exit Function
    End If
    
    If inputLen_ - position_ + 1 > 4 Then
      sValue = Parser_ViewAny(4)
      If sValue = "true" Then
        Parser_Value = True
        Call Parser_Increment(4)
        Exit Function
      ElseIf sValue = "null" Then
        Parser_Value = Null
        Call Parser_Increment(4)
        Exit Function
      End If
    End If
    
    If inputLen_ - position_ + 1 > 5 Then
      sValue = Parser_ViewAny(5)
      If sValue = "false" Then
        Parser_Value = False
        Call Parser_Increment(5)
        Exit Function
      End If
    End If
      
    Call Parser_RaiseError("Expected 'STRING', 'NUMBER', null, true, false, '{', or '['")
  End Select
End Function

Private Function Parser_String() As String
  Dim sBuffer$
  Dim nBufferPosition&
  Dim nBufferLen&
  
  Dim sChar$
  Dim json_Quote$: json_Quote = Parser_ConsumeChar()
  Do While position_ <= inputLen_
    sChar = Parser_ConsumeAny(1)
    If sChar = json_Quote Then
      Parser_String = BufferToString(sBuffer, nBufferPosition)
      Exit Function
    ElseIf sChar = "\" Then
    ' Escaped string, \\, or \/
      sChar = Parser_ConsumeAny(1)
      Select Case sChar
      Case """", "\", "/", "'": Call BufferAppend(sBuffer, sChar, nBufferPosition, nBufferLen)
      Case "b": Call BufferAppend(sBuffer, vbBack, nBufferPosition, nBufferLen)
      Case "f": Call BufferAppend(sBuffer, vbFormFeed, nBufferPosition, nBufferLen)
      Case "n": Call BufferAppend(sBuffer, vbCrLf, nBufferPosition, nBufferLen)
      Case "r": Call BufferAppend(sBuffer, vbCr, nBufferPosition, nBufferLen)
      Case "t": Call BufferAppend(sBuffer, vbTab, nBufferPosition, nBufferLen)
      Case "u"
        Dim sUTF8Char$: sUTF8Char = Parser_ViewAny(4)
        Call BufferAppend(sBuffer, VBA.ChrW(VBA.val("&h" + sUTF8Char)), nBufferPosition, nBufferLen)
        Call Parser_Increment(4)
      Case Else: Call Parser_Increment(-1)
      End Select
    Else
      Call BufferAppend(sBuffer, sChar, nBufferPosition, nBufferLen)
    End If
  Loop
End Function

Private Function Parser_Numbers() As Variant
  Call Parser_SkipWS
  Dim sChar$
  Dim sValue$: sValue = vbNullString
  Do While position_ <= inputLen_
    sChar = Parser_ViewAny(1)
    If VBA.InStr("+-0123456789.eE", sChar) Then
      sValue = sValue & sChar
      Call Parser_Increment(1)
    Else
      ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number
      Dim bIsLarge As Boolean: bIsLarge = IIf(VBA.InStr(sValue, "."), VBA.Len(sValue) >= 17, VBA.Len(sValue) >= 16)
      If bIsLarge Then
        Parser_Numbers = sValue
      Else
        Parser_Numbers = VBA.val(sValue)
      End If
      Exit Function
    End If
  Loop
End Function

Private Function Parser_Key() As String
  Dim sChar$: sChar = Parser_ViewAny(1)
  If sChar = """" Or sChar = "'" Then
    Parser_Key = Parser_String
  Else
    Call Parser_RaiseError("Expected '""' or '''")
  End If
End Function

' View nChars from input
Private Function Parser_ViewAny(Optional nChars& = 1) As String
  If position_ + nChars - 1 > inputLen_ Then _
    Call Parser_RaiseError("Unexpected end of input")
  Parser_ViewAny = VBA.Mid$(json_, position_, nChars)
End Function

' View nChar symboms (skipping spaces)
Private Function Parser_ViewChar(Optional nChars& = 1) As String
  Dim nPosition&: nPosition = position_
  Do While nPosition > 0 And nPosition <= inputLen_ And VBA.Mid$(json_, nPosition, 1) = " "
    nPosition = nPosition + 1
  Loop
  If nPosition + nChars - 1 > inputLen_ Then _
    Call Parser_RaiseError("Unexpected end of input")
  Parser_ViewChar = VBA.Mid$(json_, nPosition, nChars)
End Function

' Consumne nChars symbols from input
Private Function Parser_ConsumeAny(Optional nChars& = 1) As String
  If position_ + nChars - 1 > inputLen_ Then _
    Call Parser_RaiseError("Unexpected end of input")
  Parser_ConsumeAny = VBA.Mid$(json_, position_, nChars)
  Call Parser_Increment(nChars)
End Function

' Consume nChars from input (skipping spaces)
Private Function Parser_ConsumeChar(Optional nChars& = 1) As String
  Call Parser_SkipWS
  If position_ + nChars - 1 > inputLen_ Then _
    Call Parser_RaiseError("Unexpected end of input")
  Parser_ConsumeChar = VBA.Mid$(json_, position_, nChars)
  Call Parser_Increment(nChars)
End Function

Private Function Parser_Increment(Optional nIncrement& = 1)
  position_ = position_ + nIncrement
End Function

Private Function Parser_SkipWS()
  Do While position_ <= inputLen_ And VBA.Mid$(json_, position_, 1) = " "
    Call Parser_Increment
  Loop
End Function

Private Function Parser_RaiseError(sMessage$)
  Dim nStart&: nStart = position_ - 10
  If nStart <= 0 Then _
    nStart = 1
    
  Dim nEnd&: nEnd = position_ + 10
  If nEnd > inputLen_ Then _
    nEnd = inputLen_
  
  Dim sErrorMsg$: sErrorMsg = "Error parsing JSON:" & VBA.vbNewLine & _
              VBA.Mid$(json_, nStart, nEnd - nStart + 1) & VBA.vbNewLine & _
              VBA.Space$(position_ - nStart) & "^" & VBA.vbNewLine & _
              sMessage
  Call Err.Raise(ERR_PARSE_FAIL, "JSONConverter", sErrorMsg)
End Function

Private Function ArraySize(target As Variant, Optional nDimension% = 1) As Long
  On Error GoTo INVALID_SIZE
  
  ArraySize = UBound(target, nDimension) - LBound(target, nDimension) + 1
  Exit Function

INVALID_SIZE:
  ArraySize = -1
End Function

Private Function IsUndefined(ByVal vValue As Variant) As Boolean
  ' Empty / Nothing -> undefined
  Select Case VBA.VarType(vValue)
  Case VBA.vbEmpty
    IsUndefined = True
  Case VBA.vbObject
    Select Case VBA.TypeName(vValue)
    Case "Empty", "Nothing"
      IsUndefined = True
    End Select
  End Select
End Function

Private Function EncodeStr(ByVal sText As Variant) As String
  Dim sBuffer$: sBuffer = vbNullString
  Dim nBufferPosition&
  Dim nBufferLen&
  
  Dim sChar$
  Dim nCharCode&
  Dim nPosition&
  For nPosition = 1 To VBA.Len(sText)
    sChar = VBA.Mid$(sText, nPosition, 1)
    nCharCode = VBA.AscW(sChar)

    ' Convert negative complement into char code, see: https://support.microsoft.com/en-us/kb/272138
    If nCharCode < 0 Then _
      nCharCode = nCharCode + 65536

    Select Case nCharCode
    Case 34: sChar = "\"""
    Case 92: sChar = "\\"
    Case 47: If escapeSlash_ Then sChar = "\/"
    Case 8: sChar = "\b"
    Case 12: sChar = "\f"
    Case 10: sChar = "\n"
    Case 13: sChar = "\r"
    Case 9: sChar = "\t"
    Case 0 To 31, 127 To 65535: If escapeUnicode_ Then sChar = "\u" & VBA.Right$("0000" & VBA.Hex$(nCharCode), 4)
    End Select

    Call BufferAppend(sBuffer, sChar, nBufferPosition, nBufferLen)
  Next nPosition

  EncodeStr = BufferToString(sBuffer, nBufferPosition)
End Function

Private Function IsLargeNumber(sJson As Variant) As Boolean
  Dim nLength&: nLength = VBA.Len(sJson)
  If nLength < 16 Or nLength >= 100 Then _
    Exit Function
    
  IsLargeNumber = True
  Dim nIndex&
  For nIndex = 1 To nLength Step 1
    Select Case VBA.Asc(VBA.Mid$(sJson, nIndex, 1))
    Case 46, 48 To 57, 69, 101 ' Look for .|0-9|E|e
      ' Continue through characters
    Case Else
      IsLargeNumber = False
      Exit Function
    End Select
  Next nIndex
End Function

Private Function GetWS(nIdent&) As String
  If Not multiline_ Then _
    Exit Function
  If wsCount_ <> -1 Then
    GetWS = VBA.Space$(nIdent * wsCount_)
  Else
    GetWS = VBA.String$(nIdent, wsCharacter_)
  End If
End Function

Private Function BufferAppend(ByRef sBuffer$, ByRef vAppendage As Variant, ByRef nBufferPosition&, ByRef nBufferLen&)
  ' Allocate a large empty string and then copy string at append position instead of allocating for each append
  Dim nAppendLen&: nAppendLen = VBA.Len(vAppendage)

  If nAppendLen + nBufferPosition > nBufferLen Then
    Dim nAddedLength&: nAddedLength = IIf(nAppendLen > nBufferLen, nAppendLen, nBufferLen)
    sBuffer = sBuffer & VBA.Space$(nAddedLength)
    nBufferLen = nBufferLen + nAddedLength
  End If
  
  ' Access and modify buffer using Mid$
  Mid$(sBuffer, nBufferPosition + 1, nAppendLen) = CStr(vAppendage)
  nBufferPosition = nBufferPosition + nAppendLen
End Function

Private Function BufferToString(ByRef sBuffer$, nBufferPosition&) As String
  If nBufferPosition > 0 Then _
    BufferToString = VBA.Left$(sBuffer, nBufferPosition)
End Function