Full Raw Json To Properties API...

mIpParserJsonProperties.bas

Option Explicit

Public Const JSON_PATH_ROOT_NAME_DEFAULT As String = "root"
Public Const JSON_SEPARATOR_ROW As String = vbLf        'Character: Carriage Return
Public Const JSON_SEPARATOR_KEY_VALUE As String = vbTab 'Character: TAB
Public Const JSON_SEPARATOR_ESCAPED_ROW As String = "\n"
Public Const JSON_SEPARATOR_ESCAPED_KEY_VALUE As String = "\t"
Public Const JSON_PATH_SEPARATOR_OBJECT As String = "."
Public Const JSON_PATH_SEPARATOR_ARRAY_OPEN As String = "("
Public Const JSON_PATH_SEPARATOR_ARRAY_CLOSE As String = ")"

Private Const ERROR_PREFIX_BASE As String = "ERROR: "
Private Const ERROR_PREFIX_BASE_LENGTH As Long = 7
Private Const ERROR_PREFIX_F_STR_FETCH_JSON_VALUE_BY_PATH As String = ERROR_PREFIX_BASE + "fetchValue failed - "
Private Const ERROR_PREFIX_F_STR_PARSE_JSON_INTO_PATHS_TO_VALUES As String = ERROR_PREFIX_BASE + "parse failed - "
Private Const ERROR_PREFIX_F_ASTR_JSON_TOKENIZE As String = ERROR_PREFIX_BASE + "jsonTokenize failed - "
Private Const ERROR_PREFIX_F_STR_PARSE_JSON As String = ERROR_PREFIX_BASE + "parseJson failed - Invalid JSON - "
Private Const ERROR_PREFIX_F_STR_PARSE_JSON_OPEN_CURLY_BRACE_OR_SQUARE_BRACKET As String = ERROR_PREFIX_BASE + "parseJsonOpenCurlyBraceOrSquareBracket failed - Invalid JSON - "

Private Const REGEX_PATTERN_JSON = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"
Private Const EMPTY_DOUBLE_QUOTES = """"""

Public Function isValueDefined( _
    ByVal jsonAsPathsToValues As String _
  , ByVal jsonPath As String _
) As Boolean
  Dim result As Boolean
  
  Dim key As String
  Dim indexStart As Long
  
  If (LenB(jsonAsPathsToValues) <> 0) Then
    If (LenB(jsonPath) <> 0) Then
      key = JSON_SEPARATOR_ROW + LCase$(jsonPath) + JSON_SEPARATOR_KEY_VALUE
      indexStart = InStr(jsonAsPathsToValues, key)
      result = (indexStart > 0)
    End If
  End If
  
  isValueDefined = result
End Function

Public Function fetchValueSafe( _
    ByVal jsonAsPathsToValues As String _
  , ByVal jsonPath As String _
  , Optional ByVal isReturningErrorOnJsonPathNotFound As Boolean = False _
  , Optional ByVal isSuppressingUnescaping As Boolean = False _
) As String
  Dim result As String
  
  If (LenB(jsonAsPathsToValues) <> 0) Then
    If (Left$(jsonAsPathsToValues, ERROR_PREFIX_BASE_LENGTH) <> ERROR_PREFIX_BASE) Then
      result = fetchValue(jsonAsPathsToValues, jsonPath, isReturningErrorOnJsonPathNotFound, isSuppressingUnescaping)
    End If
  End If
  
  fetchValueSafe = result
End Function

Public Function fetchValue( _
    ByVal jsonAsPathsToValues As String _
  , ByVal jsonPath As String _
  , Optional ByVal isReturningErrorOnJsonPathNotFound As Boolean = False _
  , Optional ByVal isSuppressingUnescaping As Boolean = False _
) As String
  Dim result As String
  
  Dim key As String
  Dim indexStart As Long
  Dim indexEnd As Long
  
  If (LenB(jsonAsPathsToValues) <> 0) Then
    If (LenB(jsonPath) <> 0) Then
      key = JSON_SEPARATOR_ROW + LCase$(jsonPath) + JSON_SEPARATOR_KEY_VALUE
      indexStart = InStr(jsonAsPathsToValues, key)
      If (indexStart > 0) Then
        indexStart = indexStart + Len(key)
        indexEnd = InStr(indexStart, jsonAsPathsToValues, JSON_SEPARATOR_ROW)
        If (indexEnd > 0) Then
          result = Mid$(jsonAsPathsToValues, indexStart, indexEnd - indexStart)
          If (isSuppressingUnescaping = False) Then
            result = Replace(result, JSON_SEPARATOR_ESCAPED_ROW, JSON_SEPARATOR_ROW)
            result = Replace(result, JSON_SEPARATOR_ESCAPED_KEY_VALUE, JSON_SEPARATOR_KEY_VALUE)
          End If
        Else
          result = ERROR_PREFIX_F_STR_FETCH_JSON_VALUE_BY_PATH + "unable to find JSON_SEPARATOR_ROW [" + JSON_SEPARATOR_ROW + "] after successfully finding jsonPath [" + jsonPath + "]"
        End If
      Else
        If (isReturningErrorOnJsonPathNotFound = True) Then
          result = ERROR_PREFIX_F_STR_FETCH_JSON_VALUE_BY_PATH + "jsonPath [" + jsonPath + "] not found"
        End If
      End If
    Else
      result = ERROR_PREFIX_F_STR_FETCH_JSON_VALUE_BY_PATH + "jsonPath must be non-Empty"
    End If
  Else
    result = ERROR_PREFIX_F_STR_FETCH_JSON_VALUE_BY_PATH + "jsonAsPathsToValues must be non-Empty"
  End If
  
  fetchValue = result
End Function

Public Function parse( _
    ByVal jsonText As String _
  , Optional ByVal isKeepingEmptyValues As Boolean = False _
  , Optional ByVal jsonPathRootName As String = JSON_PATH_ROOT_NAME_DEFAULT _
) As String
  Dim result As String
  
  Dim tokens() As String
  Dim tokenAndKeyValuePairs() As String 'Always 2 entries; 0 is token count, 1 is key/value pairs
  
  If (LenB(jsonText) <> 0) Then
    tokens = jsonTokenize(jsonText)
    If (UBound(tokens) > 0) Then
      tokenAndKeyValuePairs = parseJson(tokens, isKeepingEmptyValues, jsonPathRootName, mIpvArrayString.fromParamArray("0", vbNullString))
      If (Left$(tokenAndKeyValuePairs(1), ERROR_PREFIX_BASE_LENGTH) <> ERROR_PREFIX_BASE) Then
        result = JSON_SEPARATOR_ROW + tokenAndKeyValuePairs(1)
      Else
        result = tokenAndKeyValuePairs(0) 'Already contains the error message
      End If
    Else
      If (Left$(tokens(0), ERROR_PREFIX_BASE_LENGTH) <> ERROR_PREFIX_BASE) Then
        result = ERROR_PREFIX_F_STR_PARSE_JSON_INTO_PATHS_TO_VALUES + "invalid JSON - insufficient tokens"
      Else
        result = tokens(0) 'Already contains the error message
      End If
    End If
  Else
    result = ERROR_PREFIX_F_STR_PARSE_JSON_INTO_PATHS_TO_VALUES + "jsonText must be non-Empty"
  End If

  parse = result
End Function

Private Function jsonTokenize(ByVal jsonText As String) As String()
  Dim regexMatches As Object
  Dim regexMatch As Object
  Dim tokens() As String
  Dim tokensIndex As Long
  Dim errorMessage As String
  
  On Error GoTo DisplayError
  
  With CreateObject("vbscript.regexp")
    .Global = True
    .MultiLine = False
    .IgnoreCase = True
    .Pattern = REGEX_PATTERN_JSON
    If .test(jsonText) Then
      Set regexMatches = .Execute(jsonText)
      ReDim tokens(0 To regexMatches.count - 1)
      For Each regexMatch In regexMatches
        If (Len(regexMatch.submatches(0)) > 0) Or (regexMatch.value = EMPTY_DOUBLE_QUOTES) Then
          tokens(tokensIndex) = regexMatch.submatches(0)
        Else
          tokens(tokensIndex) = regexMatch.value
        End If
        tokensIndex = tokensIndex + 1
      Next
    End If
  End With
  If ((tokens(0) <> "{") And (tokens(0) <> "[")) Then
    errorMessage = ERROR_PREFIX_F_ASTR_JSON_TOKENIZE + "found invalid starting token [" + tokens(0) + "] - expecting an open curly brace ['{'] or an open square brace ['[']"
    ReDim tokens(0 To 0)
    tokens(0) = errorMessage
  End If
  
NormalExit:
  jsonTokenize = tokens
  Exit Function

DisplayError:
  errorMessage = ERROR_PREFIX_F_ASTR_JSON_TOKENIZE + Err.Description
  MsgBox errorMessage
  ReDim tokens(0 To 0)
  tokens(0) = errorMessage
  Resume NormalExit

End Function

Private Function isTokenAvailable( _
    ByRef r_tokens() As String _
  , ByVal tokenIndex As Long _
) As Boolean
  isTokenAvailable = UBound(r_tokens) >= tokenIndex
End Function

Private Function parseJson( _
    ByRef r_tokens() As String _
  , ByVal isKeepingEmptyValues As Boolean _
  , ByVal jsonPath As String _
  , ByRef r_accumulator() As String _
) As String()
  Dim result() As String
  
  Dim tokenIndex As Long
  Dim tokenNext As String
  Dim isContextArray As Boolean
  Dim contextClose As String
  Dim isComplete As Boolean
  Dim arrayIndex As Long
  
  tokenIndex = CLng(r_accumulator(0))
  If (isTokenAvailable(r_tokens, tokenIndex)) Then
    tokenNext = r_tokens(tokenIndex)
    result = r_accumulator
    Select Case tokenNext
      Case "{", "[":
        isContextArray = tokenNext = "["
        If (isContextArray = False) Then
          contextClose = "}"
        Else
          contextClose = "]"
        End If
        If (isTokenAvailable(r_tokens, tokenIndex + 1)) Then
          If (r_tokens(tokenIndex + 1) <> contextClose) Then
            While (isComplete = False)
              If (isContextArray = False) Then
                result = parseJsonOpenCurlyBraceOrSquareBracket(r_tokens, isKeepingEmptyValues, jsonPath, updateAccumulator(result, 1)) 'consume the open curly brace or comma
              Else
                result = parseJsonOpenCurlyBraceOrSquareBracket(r_tokens, isKeepingEmptyValues, jsonPath, updateAccumulator(result, 1), arrayIndex) 'consume the open square brace or comma
              End If
              If (Left$(result(1), ERROR_PREFIX_BASE_LENGTH) <> ERROR_PREFIX_BASE) Then
                tokenIndex = CLng(result(0))
                If (isTokenAvailable(r_tokens, tokenIndex)) Then
                  tokenNext = r_tokens(tokenIndex)
                  If (tokenNext = contextClose) Then
                    result = updateAccumulator(result, 1)
                    isComplete = True
                  Else
                    If (tokenNext <> ",") Then
                      If (isContextArray = False) Then
                        result(1) = "curly bracket"
                      Else
                        result(1) = "square brace"
                      End If
                      result(1) = ERROR_PREFIX_F_STR_PARSE_JSON + "invalid token [" + tokenNext + "] at token index [" + CStr(tokenIndex) + "] - expecting comma [','] or " + result(1) + " ['" + contextClose + "']"
                      isComplete = True
                    End If
                  End If
                Else
                  result(1) = ERROR_PREFIX_F_STR_PARSE_JSON + "tokens prematurely terminated at token index [" + CStr(tokenIndex) + "]"
                End If
                arrayIndex = arrayIndex + 1
              Else
                isComplete = True
              End If
            Wend
          Else
            result = updateAccumulator(result, 2)
          End If
        Else
          result(1) = ERROR_PREFIX_F_STR_PARSE_JSON + "tokens prematurely terminated at token index [" + CStr(tokenIndex) + "]"
        End If
      Case Else:
        result(1) = ERROR_PREFIX_F_STR_PARSE_JSON + "invalid token [" + r_tokens(tokenIndex) + "] at token index [" + CStr(tokenIndex) + "] - expecting open curly bracket ['{'] or open square bracket ['[']"
    End Select
  Else
    result(1) = ERROR_PREFIX_F_STR_PARSE_JSON + "tokens prematurely terminated at token index [" + CStr(tokenIndex) + "]"
  End If
  
  parseJson = result
End Function

Private Function parseJsonOpenCurlyBraceOrSquareBracket( _
    ByRef r_tokens() As String _
  , ByVal isKeepingEmptyValues As Boolean _
  , ByVal jsonPath As String _
  , ByRef r_accumulator() As String _
  , Optional ByVal arrayIndex As Long = -1 _
) As String()
  Dim result() As String

  Dim tokenIndex As Long
  Dim token As String
  Dim jsonPathNew As String
  Dim accumulatorNew() As String
  Dim tokensConsumed As Long
  Dim errorMessage As String
  
  tokenIndex = CLng(r_accumulator(0))
  If (isTokenAvailable(r_tokens, tokenIndex)) Then
    If (arrayIndex = -1) Then
      'Object
      If (isTokenAvailable(r_tokens, tokenIndex + 1)) Then
        token = r_tokens(tokenIndex + 1)
        If (token = ":") Then
          If (isTokenAvailable(r_tokens, tokenIndex + 2)) Then
            jsonPathNew = jsonPath + JSON_PATH_SEPARATOR_OBJECT + r_tokens(tokenIndex)
            token = r_tokens(tokenIndex + 2)
            If ((token = "{") Or (token = "[")) Then
              accumulatorNew = updateAccumulator(r_accumulator, 2)
            Else
              tokensConsumed = 3
            End If
          Else
            errorMessage = ERROR_PREFIX_F_STR_PARSE_JSON_OPEN_CURLY_BRACE_OR_SQUARE_BRACKET + "tokens prematurely terminated prior to value at token index [" + CStr(tokenIndex) + "]"
          End If
        Else
          errorMessage = ERROR_PREFIX_F_STR_PARSE_JSON_OPEN_CURLY_BRACE_OR_SQUARE_BRACKET + "invalid token [" + token + "] at token index [" + CStr(tokenIndex + 1) + "] - expecting colon [':']"
        End If
      Else
        errorMessage = ERROR_PREFIX_F_STR_PARSE_JSON_OPEN_CURLY_BRACE_OR_SQUARE_BRACKET + "tokens prematurely terminated prior to colon at token index [" + CStr(tokenIndex) + "]"
      End If
    Else
      'Array
      jsonPathNew = jsonPath + JSON_PATH_SEPARATOR_ARRAY_OPEN + CStr(arrayIndex) + JSON_PATH_SEPARATOR_ARRAY_CLOSE
      token = r_tokens(tokenIndex)
      If ((token = "{") Or (token = "[")) Then
        accumulatorNew = r_accumulator
      Else
        tokensConsumed = 1
      End If
    End If
    If (LenB(errorMessage) = 0) Then
      Select Case token
        Case "{", "[":
          result = parseJson(r_tokens, isKeepingEmptyValues, jsonPathNew, accumulatorNew)
        Case Else:
          result = updateAccumulator(r_accumulator, tokensConsumed, isKeepingEmptyValues, jsonPathNew, token)
      End Select
    Else
      result(1) = errorMessage
    End If
  Else
    result(1) = ERROR_PREFIX_F_STR_PARSE_JSON_OPEN_CURLY_BRACE_OR_SQUARE_BRACKET + "tokens prematurely terminated at token index [" + CStr(tokenIndex) + "]"
  End If
  
  parseJsonOpenCurlyBraceOrSquareBracket = result
End Function

Private Function updateAccumulator( _
    ByRef r_accumulator() As String _
  , ByVal tokensConsumed As Long _
  , Optional ByVal isKeepingEmptyValues As Boolean = False _
  , Optional ByVal jsonPath As String = vbNullString _
  , Optional ByVal value As String = vbNullString _
) As String()
  Dim result() As String

  Dim valueTemp As String
  
  ReDim result(0 To 1)
  result(0) = CStr(CLng(r_accumulator(0)) + tokensConsumed)
  If ((isKeepingEmptyValues = True) Or (LenB(value) <> 0)) Then
    valueTemp = Replace(value, JSON_SEPARATOR_ROW, JSON_SEPARATOR_ESCAPED_ROW)
    valueTemp = Replace(valueTemp, JSON_SEPARATOR_KEY_VALUE, JSON_SEPARATOR_ESCAPED_KEY_VALUE)
    result(1) = r_accumulator(1) + LCase$(jsonPath) + JSON_SEPARATOR_KEY_VALUE + valueTemp + JSON_SEPARATOR_ROW
  Else
    result(1) = r_accumulator(1)
  End If
  
  updateAccumulator = result
End Function