I'm calling a web service in VB6 which returns a json string as response. I'm able to hold the response in a string. now I want to show the each parameter separately how can I extract the values from the string ?. a sample string is here :
"aaa": {"bbb": 900,"ccc": "oke"},"result": {"count": 3,"data": [["x1, x2","x3"],["y1, y2","y3"],["z1, z2","z3"]]}}
You have 2 options 1. Write your own Json parser in VB6 2. Create a COM wrapper for Json.Net and use it in your code.
The first one is going to be quite complex, but your code will not have any runtime dependeny
The second approach is fairly easier but will require the .Net Framework to be installed in the machines where your VB6 code is running.
I've used two different solutions for this in the past and although they are not very user friendly, they get the job done well enough. I apologize for not having links to the original code and author.
This is the best one in my opinion:
Option Explicit
DefObj A-Z
Private Const MODULE_NAME As String = "mdJson"
'=========================================================================
' API
'=========================================================================
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Type JsonContext
Text() As Integer
pos As Long
Error As String
LastChar As Integer
End Type
'=========================================================================
' Error management
'=========================================================================
Private Sub RaiseError(sFunction As String)
' PushError
' PopRaiseError sFunction, MODULE_NAME
Err.Raise Err.Number, MODULE_NAME & "." & sFunction & vbCrLf & Err.Source, Err.Description
End Sub
Private Sub PrintError(sFunction As String)
' PushError
' PopPrintError sFunction, MODULE_NAME
Debug.Print MODULE_NAME & "." & sFunction & ": " & Err.Description, Timer
End Sub
'=========================================================================
' Functions
'=========================================================================
Public Function JsonParse(sText As String, vResult As Variant, Optional Error As String) As Boolean
Const FUNC_NAME As String = "JsonParse"
Dim uCtx As JsonContext
Dim oResult As Object
On Error GoTo EH
With uCtx
ReDim .Text(0 To Len(sText)) As Integer
Call CopyMemory(.Text(0), ByVal StrPtr(sText), LenB(sText))
JsonParse = pvJsonParse(uCtx, vResult, oResult)
If Not oResult Is Nothing Then
Set vResult = oResult
End If
Error = .Error
End With
Exit Function
EH:
PrintError FUNC_NAME
Resume Next
End Function
Private Function pvJsonMissing(Optional vMissing As Variant) As Variant
pvJsonMissing = vMissing
End Function
Private Function pvJsonParse(uCtx As JsonContext, vResult As Variant, oResult As Object) As Boolean
'--- note: when using collections change type of parameter oResult to Collection
#Const USE_RICHCLIENT = False
#Const USE_COLLECTION = False
Const FUNC_NAME As String = "pvJsonParse"
Dim lIdx As Long
Dim vKey As Variant
Dim vValue As Variant
Dim oValue As Object
Dim sText As String
On Error GoTo EH
vValue = pvJsonMissing
With uCtx
Select Case pvJsonGetChar(uCtx)
Case 34 ' "
vResult = pvJsonGetString(uCtx)
Case 91 ' [
#If USE_RICHCLIENT Then
#If USE_COLLECTION Then
Set oResult = New cCollection
#Else
Set oResult = New cSortedDictionary
#End If
#Else
#If USE_COLLECTION Then
Set oResult = New Collection
#Else
Set oResult = CreateObject("Scripting.Dictionary")
#End If
#End If
Do
Select Case pvJsonGetChar(uCtx)
Case 0, 44, 93 ' , ]
If Not oValue Is Nothing Then
#If USE_COLLECTION Then
oResult.Add oValue
#Else
oResult.Add lIdx, oValue
#End If
ElseIf Not IsMissing(vValue) Then
#If USE_COLLECTION Then
oResult.Add vValue
#Else
oResult.Add lIdx, vValue
#End If
End If
If .LastChar <> 44 Then ' ,
Exit Do
End If
lIdx = lIdx + 1
vValue = pvJsonMissing
Set oValue = Nothing
Case Else
.pos = .pos - 1
If Not pvJsonParse(uCtx, vValue, oValue) Then
GoTo QH
End If
End Select
Loop
Case 123 ' {
#If USE_RICHCLIENT Then
#If USE_COLLECTION Then
Set oResult = New cCollection
#Else
Set oResult = New cSortedDictionary
oResult.StringCompareMode = 1 ' TextCompare
#End If
#Else
#If USE_COLLECTION Then
Set oResult = New Collection
#Else
Set oResult = CreateObject("Scripting.Dictionary")
oResult.CompareMode = 1 ' TextCompare
#End If
#End If
Do
Select Case pvJsonGetChar(uCtx)
Case 34 ' "
vKey = pvJsonGetString(uCtx)
Case 58 ' :
If Not oValue Is Nothing Then
.Error = "Value already specified at position " & .pos
GoTo QH
ElseIf Not IsMissing(vValue) Then
vKey = vValue
vValue = pvJsonMissing
End If
lIdx = .pos
If Not pvJsonParse(uCtx, vValue, oValue) Then
.pos = lIdx
vValue = Empty
Set oValue = Nothing
End If
Case 0, 44, 125 ' , }
If IsMissing(vValue) And oValue Is Nothing Then
If IsEmpty(vKey) Then
GoTo NoProp
End If
vValue = vKey
vKey = vbNullString
End If
If IsEmpty(vKey) Then
vKey = vbNullString
ElseIf IsNull(vKey) Then
vKey = "null"
End If
If Not oValue Is Nothing Then
#If USE_COLLECTION Then
oResult.Add oValue, vKey & ""
#Else
oResult.Add vKey & "", oValue
#End If
Else
#If USE_COLLECTION Then
oResult.Add vValue, vKey & ""
#Else
oResult.Add vKey & "", vValue
#End If
End If
NoProp:
If .LastChar = 0 Then
GoTo QH
ElseIf .LastChar <> 44 Then ' ,
Exit Do
End If
vKey = Empty
vValue = pvJsonMissing
Set oValue = Nothing
Case Else
.pos = .pos - 1
If Not pvJsonParse(uCtx, vValue, oValue) Then
GoTo QH
End If
End Select
Loop
Case 116, 84 ' "t", "T"
If Not ((.Text(.pos + 0) Or &H20) = 114 And (.Text(.pos + 1) Or &H20) = 117 And (.Text(.pos + 2) Or &H20) = 101) Then
GoTo UnexpectedSymbol
End If
.pos = .pos + 3
vResult = True
Case 102, 70 ' "f", "F"
If Not ((.Text(.pos + 0) Or &H20) = 97 And (.Text(.pos + 1) Or &H20) = 108 And (.Text(.pos + 2) Or &H20) = 115 And (.Text(.pos + 3) Or &H20) = 101) Then
GoTo UnexpectedSymbol
End If
.pos = .pos + 4
vResult = False
Case 110, 78 ' "n", "N"
If Not ((.Text(.pos + 0) Or &H20) = 117 And (.Text(.pos + 1) Or &H20) = 108 And (.Text(.pos + 2) Or &H20) = 108) Then
GoTo UnexpectedSymbol
End If
.pos = .pos + 3
vResult = Null
Case 48 To 57, 43, 45, 46 ' 0-9 + - .
For lIdx = 0 To 1000
Select Case .Text(.pos + lIdx)
Case 48 To 57, 43, 45, 46, 101, 69, 120, 88, 97 To 102, 65 To 70 ' 0-9 + - . e E x X a-f A-F
Case Else
Exit For
End Select
Next
sText = Space$(lIdx + 1)
Call CopyMemory(ByVal StrPtr(sText), .Text(.pos - 1), LenB(sText))
If LCase$(Left$(sText, 2)) = "0x" Then
sText = "&H" & Mid$(sText, 3)
End If
On Error GoTo ErrorConvert
vResult = CDbl(sText)
On Error GoTo 0
.pos = .pos + lIdx
Case 0
If LenB(.Error) <> 0 Then
GoTo QH
End If
Case Else
GoTo UnexpectedSymbol
End Select
pvJsonParse = True
QH:
Exit Function
UnexpectedSymbol:
.Error = "Unexpected symbol '" & ChrW$(.LastChar) & "' at position " & .pos
Exit Function
ErrorConvert:
.Error = Err.Description & " at position " & .pos
End With
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Private Function pvJsonGetChar(uCtx As JsonContext) As Integer
Const FUNC_NAME As String = "pvJsonGetChar"
Dim lIdx As Long
On Error GoTo EH
With uCtx
Do While .pos <= UBound(.Text)
.LastChar = .Text(.pos)
.pos = .pos + 1
Select Case .LastChar
Case 0
Exit Function
Case 9, 10, 13, 32 ' vbTab, vbCr, vbLf, " "
'--- do nothing
Case 47 ' /
Select Case .Text(.pos)
Case 47 ' //
.pos = .pos + 1
Do
.LastChar = .Text(.pos)
.pos = .pos + 1
If .LastChar = 0 Then
Exit Function
End If
Loop While Not (.LastChar = 10 Or .LastChar = 13) ' vbLf or vbCr
Case 42 ' /*
lIdx = .pos + 1
Do
.LastChar = .Text(lIdx)
lIdx = lIdx + 1
If .LastChar = 0 Then
.Error = "Unterminated comment at position " & .pos
Exit Function
End If
Loop While Not (.LastChar = 42 And .Text(lIdx) = 47) ' */
.LastChar = .Text(lIdx)
.pos = lIdx + 1
Case Else
pvJsonGetChar = .LastChar
Exit Do
End Select
Case Else
pvJsonGetChar = .LastChar
Exit Do
End Select
Loop
End With
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Private Function pvJsonGetString(uCtx As JsonContext) As String
Const FUNC_NAME As String = "pvJsonGetString"
Dim lIdx As Long
Dim nChar As Integer
Dim sText As String
On Error GoTo EH
With uCtx
For lIdx = 0 To &H7FFFFFFF
nChar = .Text(.pos + lIdx)
Select Case nChar
Case 0, 34, 92 ' " \
sText = Space$(lIdx)
Call CopyMemory(ByVal StrPtr(sText), .Text(.pos), LenB(sText))
pvJsonGetString = pvJsonGetString & sText
If nChar <> 92 Then ' \
.pos = .pos + lIdx + 1
Exit For
End If
lIdx = lIdx + 1
nChar = .Text(.pos + lIdx)
Select Case nChar
Case 0
Exit For
Case 98 ' b
pvJsonGetString = pvJsonGetString & Chr$(8)
Case 102 ' f
pvJsonGetString = pvJsonGetString & Chr$(12)
Case 110 ' n
pvJsonGetString = pvJsonGetString & vbLf
Case 114 ' r
pvJsonGetString = pvJsonGetString & vbCr
Case 116 ' t
pvJsonGetString = pvJsonGetString & vbTab
Case 117 ' u
pvJsonGetString = pvJsonGetString & ChrW$(CLng("&H" & ChrW$(.Text(.pos + lIdx + 1)) & ChrW$(.Text(.pos + lIdx + 2)) & ChrW$(.Text(.pos + lIdx + 3)) & ChrW$(.Text(.pos + lIdx + 4))))
lIdx = lIdx + 4
Case 120 ' x
pvJsonGetString = pvJsonGetString & ChrW$(CLng("&H" & ChrW$(.Text(.pos + lIdx + 1)) & ChrW$(.Text(.pos + lIdx + 2))))
lIdx = lIdx + 2
Case Else
pvJsonGetString = pvJsonGetString & ChrW$(nChar)
End Select
.pos = .pos + lIdx + 1
lIdx = -1
End Select
Next
End With
Exit Function
EH:
RaiseError FUNC_NAME
End Function
Public Function JsonDump(vJson As Variant, Optional ByVal Level As Long, Optional ByVal Minimize As Boolean) As String
Const FUNC_NAME As String = "JsonDump"
Const STR_CODES As String = "\u0000|\u0001|\u0002|\u0003|\u0004|\u0005|\u0006|\u0007|\b|\t|\n|\u000B|\f|\r|\u000E|\u000F|\u0010|\u0011|\u0012|\u0013|\u0014|\u0015|\u0016|\u0017|\u0018|\u0019|\u001A|\u001B|\u001C|\u001D|\u001E|\u001F"
Const INDENT As Long = 4
Static vTranscode As Variant
Dim vKeys As Variant
Dim vItems As Variant
Dim lIdx As Long
Dim lSize As Long
Dim sCompound As String
Dim sSpace As String
Dim lAsc As Long
On Error GoTo EH
Select Case VarType(vJson)
Case vbObject
sCompound = IIf(vJson.CompareMode = 0, "[]", "{}")
sSpace = IIf(Minimize, vbNullString, " ")
If vJson.Count = 0 Then
JsonDump = sCompound
Else
vKeys = vJson.Keys
vItems = vJson.Items
For lIdx = 0 To vJson.Count - 1
vItems(lIdx) = JsonDump(vItems(lIdx), Level + 1, Minimize)
If vJson.CompareMode = 1 Then
vItems(lIdx) = JsonDump(vKeys(lIdx)) & ":" & sSpace & vItems(lIdx)
End If
lSize = lSize + Len(vItems(lIdx))
Next
If lSize > 100 And Not Minimize Then
JsonDump = Left$(sCompound, 1) & vbCrLf & _
Space$((Level + 1) * INDENT) & Join(vItems, "," & vbCrLf & Space$((Level + 1) * INDENT)) & vbCrLf & _
Space$(Level * INDENT) & Right$(sCompound, 1)
Else
JsonDump = Left$(sCompound, 1) & sSpace & Join(vItems, "," & sSpace) & sSpace & Right$(sCompound, 1)
End If
End If
Case vbNull
JsonDump = "Null"
Case vbEmpty
JsonDump = "Empty"
Case vbString
'--- one-time initialization of transcoding array
If IsEmpty(vTranscode) Then
vTranscode = Split(STR_CODES, "|")
End If
For lIdx = 1 To Len(vJson)
lAsc = AscW(Mid$(vJson, lIdx, 1))
If lAsc = 92 Or lAsc = 34 Then '--- \ and "
JsonDump = JsonDump & "\" & Chr$(lAsc)
ElseIf lAsc >= 32 And lAsc < 256 Then
JsonDump = JsonDump & Chr$(lAsc)
ElseIf lAsc >= 0 And lAsc < 32 Then
JsonDump = JsonDump & vTranscode(lAsc)
ElseIf Asc(Mid$(vJson, lIdx, 1)) <> 63 Then '--- ?
JsonDump = JsonDump & Chr$(Asc(Mid$(vJson, lIdx, 1)))
Else
JsonDump = JsonDump & "\u" & Right$("0000" & Hex(lAsc), 4)
End If
Next
JsonDump = """" & JsonDump & """"
Case Else
JsonDump = vJson & ""
End Select
Exit Function
EH:
PrintError FUNC_NAME
Resume Next
End Function
You use it by providing a Variant to the JsonParse function:
Dim objJSON As Variant
Dim sJSON as String
Dim fParseSuccess As Boolean
fParseSuccess = JsonParse(sJSON, objJSON)
You can then navigate through the Collection and Dictionary objects it creates. This part is not very user-friendly but you'll get the hang of it. Here's an example:
For iCounter = 0 To objJSON.Item("dates").Count - 1
Dim tmp as Variant
tmp = objJSON.Item("dates").Item(iCounter).Item("date")
For iIndex = 0 To objJSON.Item("dates").Item(iCounter).Item("games").Count - 1
With objJSON.Item("dates").Item(iCounter).Item("games")
iVisID = .Item(iIndex).Item("teams").Item("away").Item("team").Item("id")
iHomeID = .Item(iIndex).Item("teams").Item("home").Item("team").Item("id")
Hope this helps.
Here's another solution I found. This one was less performant parsing a large amount of data but is a little more user friendly. This is a Class:
Option Explicit
'Not a real (fractional) number, but Major.Minor integers:
Private Const CLASS_VERSION As String = "1.6"
'Character constants.
Private Const LBRACE As String = "{"
Private Const RBRACE As String = "}"
Private Const LBRACKET As String = "["
Private Const RBRACKET As String = "]"
Private Const COLON As String = ":"
Private Const COMMA As String = ","
Private Const QUOTE As String = """"
Private Const PLUS As String = "+"
Private Const MINUS As String = "-"
Private Const RADIXPOINT As String = "." 'Always a period since we're locale-blind.
Private Const ZERO As String = "0"
Private Const NINE As String = "9"
Private Const REVSOLIDUS As String = "\"
Private Const WHITE_SPACE As String = vbTab & vbLf & vbCr & " "
Private Const S_OK As Long = 0
Private Const VARIANT_ALPHABOOL As Long = &H2&
Private Const LOCALE_INVARIANT As Long = 127& 'Used to do VT conversions with the invariant locale.
Private Declare Function HashData Lib "shlwapi" ( _
ByVal pbData As Long, _
ByVal cbData As Long, _
ByVal pbHash As Long, _
ByVal cbHash As Long) As Long
Private Declare Function StrSpn Lib "shlwapi" Alias "StrSpnW" ( _
ByVal psz As Long, _
ByVal pszSet As Long) As Long
Private Declare Function VariantChangeTypeEx Lib "oleaut32" ( _
ByRef vargDest As Variant, _
ByRef varSrc As Variant, _
ByVal lcid As Long, _
ByVal wFlags As Integer, _
ByVal vt As VbVarType) As Long
Private TypeNameOfMe As String 'Used in raising exceptions.
Private Names As Collection
Private Values As Collection
Private CursorIn As Long 'Scan position within JSON input string.
Private LengthIn As Long 'Length of JSON input string.
Private TextOut As String 'Buffer to build JSON output string in.
Private CursorOut As Long 'Append position within JSON output string.
Private NumberType As VbVarType
Private vbUS As String 'Pseudo-const ChrW$(&H1F&).
Private mIsArray As Boolean
Private mDecimalMode As Boolean
'=== Public Properties =================================================================
Public Whitespace As Boolean 'True to use indenting and newlines on JSON Get.
Public Property Get Count() As Long
Count = Values.Count
End Property
Public Property Get DecimalMode() As Boolean
DecimalMode = mDecimalMode
End Property
Public Property Let DecimalMode(ByVal RHS As Boolean)
mDecimalMode = RHS
If mDecimalMode Then
NumberType = vbDecimal
Else
NumberType = vbDouble
End If
End Property
Public Property Let IsArray(ByVal RHS As Boolean)
If Values.Count > 0 Then
Err.Raise 5, TypeNameOfMe, "Cannot change IsArray setting after items have been added"
Else
mIsArray = RHS
If mIsArray Then Set Names = Nothing
End If
End Property
Public Property Get IsArray() As Boolean
IsArray = mIsArray
End Property
'Default property.
Public Property Get Item(ByVal Key As Variant) As Variant
'Retrieval works either by key or index for "objects" but only
'by index for "arrays."
Dim PrefixedKey As String
If IsNull(Key) Then Err.Raise 94, TypeNameOfMe, "Key must be String or an index)"
If VarType(Key) = vbString Then
If mIsArray Then
Err.Raise 5, TypeNameOfMe, "Array values can only be acessed by index"
End If
PrefixedKey = PrefixHash(Key)
If IsObject(Values.Item(PrefixedKey)) Then
Set Item = Values.Item(PrefixedKey)
Else
Item = Values.Item(PrefixedKey)
End If
Else
If IsObject(Values.Item(Key)) Then
Set Item = Values.Item(Key)
Else
Item = Values.Item(Key)
End If
End If
End Property
Public Property Let Item(Optional ByVal Key As Variant = Null, ByVal RHS As Variant)
'Add new Item or change existing Item's value.
'
'When IsArray = True:
'
' Pass a Null as Key to add a new item at the end of the "array."
'
' Pass an index (Long) as Key to assign a new value to an
' existing Item. However if the index is greater than .Count
' the value is added as a new entry at the end of the "array."
'
'When IsArray = False:
'
' Pass a name (String) as Key. If the named Item exists its
' value is updated. If it does not exist a new Item is added.
'
'Item reassignment for existing items (assign new value) is
'implemented as remove and re-add. This means changing the value
'of an "object's" Item moves it to the end of the list.
Dim PrefixedKey As String
With Values
If mIsArray Then
If VarType(Key) = vbString Then
Err.Raise 5, TypeNameOfMe, "Array values can only be changed by index or added via Null"
End If
If IsNull(Key) Then
.Add RHS 'Add at end.
Else
If Key > .Count Then
.Add RHS 'Add at end.
Else
.Remove Key
.Add RHS, , Key 'Insert into position.
End If
End If
Else
If VarType(Key) <> vbString Then
Err.Raise 5, TypeNameOfMe, "Object values can only be changed or added by key not by index"
End If
PrefixedKey = PrefixHash(Key)
On Error Resume Next
.Add RHS, PrefixedKey
If Err Then
On Error GoTo 0
'Add failed, Key must already exist. Remove/re-add. Remove Name.
.Remove PrefixedKey
.Add RHS, PrefixedKey
Names.Remove PrefixedKey
Else
On Error GoTo 0
End If
'Add Name.
Names.Add Key, PrefixedKey
End If
End With
End Property
Public Property Set Item(ByVal Key As Variant, ByVal RHS As Variant)
'This is just an alias for Let since we don't have to do anything
'different.
'
'This allows either Let or Set to be used by client logic.
Item(Key) = RHS
End Property
Public Property Get JSON() As String
CursorOut = 1
SerializeItem vbNullString, Me
JSON = Left$(TextOut, CursorOut - 1)
'Clear for next reuse. Do it here to reclaim space.
TextOut = ""
End Property
Public Property Let JSON(ByRef RHS As String)
Clear
CursorIn = 1
LengthIn = Len(RHS)
SkipWhitespace RHS
Select Case Mid$(RHS, CursorIn, 1)
Case LBRACE
CursorIn = CursorIn + 1
ParseObject RHS, CursorIn, Len(RHS)
Case LBRACKET
CursorIn = CursorIn + 1
ParseArray RHS, CursorIn, Len(RHS)
Case Else
Error13A "either " & LBRACE & " or " & LBRACKET, CursorIn
End Select
End Property
Public Property Get Name(ByVal Index As Long) As String
If mIsArray Then Err.Raise 5, TypeNameOfMe, "Array items do not have names"
Name = Names.Item(Index)
End Property
Public Property Get Version() As String()
Version = Split(CLASS_VERSION)
End Property
'=== Public Methods ====================================================================
Public Function AddNewArray(Optional ByVal Key As Variant = Null) As clsJSONBag
Dim NewArray As clsJSONBag
Set NewArray = New clsJSONBag
NewArray.IsArray = True
Set Item(Key) = NewArray
Set AddNewArray = NewArray
End Function
Public Function AddNewObject(Optional ByVal Key As Variant = Null) As clsJSONBag
Dim NewObject As clsJSONBag
Set NewObject = New clsJSONBag
Set Item(Key) = NewObject
Set AddNewObject = NewObject
End Function
Public Sub Clear()
Set Names = New Collection
Set Values = New Collection
mIsArray = False
End Sub
Public Function Exists(ByVal Key As Variant) As Boolean
Dim Name As String
On Error Resume Next
Name = Names.Item(Key)
Exists = Err.Number = 0
Err.Clear
End Function
'Marked as hidden and ProcedureID = -4
Public Function NewEnum() As IUnknown
If mIsArray Then Err.Raise 5, TypeNameOfMe, "Arrays must be iterated using index values"
Set NewEnum = Names.[_NewEnum]
End Function
Public Sub Remove(ByVal Key As Variant)
'Allow remove by Key or Index (only by Index for arrays). If the item
'does not exist return silently.
Dim PrefixedKey As String
If VarType(Key) = vbString Then
If mIsArray Then Err.Raise 5, TypeNameOfMe, "Must remove by index for arrays"
PrefixedKey = PrefixHash(Key)
On Error Resume Next
Names.Remove PrefixedKey
If Err Then
Exit Sub
End If
On Error GoTo 0
Values.Remove PrefixedKey
Else
If Key < Values.Count Then
Values.Remove Key
If Not IsArray Then Names.Remove Key
End If
End If
End Sub
'=== Friend Methods (do not call from client logic) ====================================
Friend Sub ParseArray(ByRef Text As String, ByRef StartCursor As Long, ByVal TextLength As Long)
'This call is made within the context of the instance at hand.
Dim ArrayValue As Variant
CursorIn = StartCursor
LengthIn = TextLength
mIsArray = True
Do
SkipWhitespace Text
Select Case Mid$(Text, CursorIn, 1)
Case COMMA
CursorIn = CursorIn + 1
Case RBRACKET
CursorIn = CursorIn + 1
Exit Do
Case Else
ParseValue Text, ArrayValue
Values.Add ArrayValue
End Select
Loop
StartCursor = CursorIn
End Sub
Friend Sub ParseObject(ByRef Text As String, ByRef StartCursor As Long, ByVal TextLength As Long)
'This call is made within the context of the instance at hand.
Dim Char As String
Dim ItemName As String
Dim Value As Variant
Dim FoundFirstItem As Boolean
CursorIn = StartCursor
LengthIn = TextLength
Do
SkipWhitespace Text
Char = Mid$(Text, CursorIn, 1)
CursorIn = CursorIn + 1
Select Case Char
Case QUOTE
ItemName = ParseName(Text)
ParseValue Text, Value
Item(ItemName) = Value
FoundFirstItem = True
Case COMMA
If Not FoundFirstItem Then
Err.Raise 13, TypeNameOfMe, "Found "","" before first item at character " & CStr(CursorIn - 1)
End If
Case RBRACE
Exit Do
Case Else
Error13A ", or }", CursorIn - 1
End Select
Loop
StartCursor = CursorIn
End Sub
'=== Private Methods ===================================================================
Private Sub Cat(ByRef NewText As String)
Const TEXT_CHUNK As Long = 512 'Allocation size for destination buffer Text.
Dim LenNew As Long
LenNew = Len(NewText)
If LenNew > 0 Then
If CursorOut + LenNew - 1 > Len(TextOut) Then
If LenNew > TEXT_CHUNK Then
TextOut = TextOut & Space$(LenNew + TEXT_CHUNK)
Else
TextOut = TextOut & Space$(TEXT_CHUNK)
End If
End If
Mid$(TextOut, CursorOut, LenNew) = NewText
CursorOut = CursorOut + LenNew
End If
End Sub
Private Sub Error13A(ByVal Symbol As String, ByVal Position As Long)
Err.Raise 13, TypeNameOfMe, "Expected " & Symbol & " at character " & CStr(Position)
End Sub
Private Sub Error13B(ByVal Position As Long)
Err.Raise 13, TypeNameOfMe, "Bad string character escape at character " & CStr(Position)
End Sub
Private Function ParseName(ByRef Text As String) As String
ParseName = ParseString(Text)
SkipWhitespace Text
If Mid$(Text, CursorIn, 1) <> COLON Then
Error13A COLON, CursorIn
End If
CursorIn = CursorIn + 1
End Function
Private Function ParseNumber(ByRef Text As String) As Variant
Dim SaveCursor As Long
Dim BuildString As String
Dim BuildCursor As Long
Dim Char As String
Dim GotDecPoint As Boolean
Dim GotExpSign As Boolean
SaveCursor = CursorIn 'Saved for "bad number format" error.
BuildString = Space$(LengthIn - CursorIn + 1)
'We know 1st char has been validated by the caller.
BuildCursor = 1
Mid$(BuildString, 1, 1) = Mid$(Text, CursorIn, 1)
For CursorIn = CursorIn + 1 To LengthIn
Char = LCase$(Mid$(Text, CursorIn, 1))
Select Case Char
Case RADIXPOINT
If GotDecPoint Then
Err.Raise 13, TypeNameOfMe, "Second decimal point at character " & CStr(CursorIn)
End If
If Mid$(BuildString, BuildCursor, 1) = MINUS Then
Err.Raise 13, TypeNameOfMe, "Digit expected at character " & CStr(CursorIn)
End If
GotDecPoint = True
Case ZERO To NINE
'Do nothing.
Case "e"
CursorIn = CursorIn + 1
Exit For
Case Else
Exit For
End Select
BuildCursor = BuildCursor + 1
Mid$(BuildString, BuildCursor, 1) = Char
Next
If Char = "e" Then
BuildCursor = BuildCursor + 1
Mid$(BuildString, BuildCursor, 1) = Char
For CursorIn = CursorIn To LengthIn
Char = Mid$(Text, CursorIn, 1)
Select Case Char
Case PLUS, MINUS
If GotExpSign Then
Err.Raise 13, TypeNameOfMe, "Second exponent sign at character " & CStr(CursorIn)
End If
GotExpSign = True
Case ZERO To NINE
'Do nothing.
Case Else
Exit For
End Select
BuildCursor = BuildCursor + 1
Mid$(BuildString, BuildCursor, 1) = Char
Next
End If
If CursorIn > LengthIn Then
Err.Raise 13, TypeNameOfMe, "Ran off end of string while parsing a number"
End If
ParseNumber = Left$(BuildString, BuildCursor)
If VariantChangeTypeEx(ParseNumber, ParseNumber, LOCALE_INVARIANT, 0, NumberType) <> S_OK Then
Err.Raise 6, TypeNameOfMe, "Number overflow or parse error at character " & CStr(SaveCursor)
End If
End Function
Private Function ParseString(ByRef Text As String) As String
Dim BuildCursor As Long
Dim Char As String
ParseString = Space$(LengthIn - CursorIn + 1)
For CursorIn = CursorIn To LengthIn
Char = Mid$(Text, CursorIn, 1)
Select Case Char
Case vbNullChar To vbUS
Err.Raise 13, TypeNameOfMe, "Invalid string character at " & CStr(CursorIn)
Case REVSOLIDUS
CursorIn = CursorIn + 1
If CursorIn > LengthIn Then
Error13B CursorIn
End If
Char = LCase$(Mid$(Text, CursorIn, 1)) 'Accept uppercased escape symbols.
Select Case Char
Case QUOTE, REVSOLIDUS, "/"
'Do nothing.
Case "b"
Char = vbBack
Case "f"
Char = vbFormFeed
Case "n"
Char = vbLf
Case "r"
Char = vbCr
Case "t"
Char = vbTab
Case "u"
CursorIn = CursorIn + 1
If LengthIn - CursorIn < 3 Then
Error13B CursorIn
End If
On Error Resume Next
Char = ChrW$(CLng("&H0" & Mid$(Text, CursorIn, 4)))
If Err Then
On Error GoTo 0
Error13B CursorIn
End If
On Error GoTo 0
CursorIn = CursorIn + 3 'Not + 4 because For loop will increment again.
Case Else
Error13B CursorIn
End Select
Case QUOTE
CursorIn = CursorIn + 1
Exit For
'Case Else
'Do Nothing, i.e. pass Char unchanged.
End Select
BuildCursor = BuildCursor + 1
Mid$(ParseString, BuildCursor, 1) = Char
Next
If CursorIn > LengthIn Then
Error13A QUOTE, LengthIn + 1
End If
ParseString = Left$(ParseString, BuildCursor)
End Function
Private Sub ParseValue(ByRef Text As String, ByRef Value As Variant)
Dim SubBag As clsJSONBag
Dim Token As String
SkipWhitespace Text
Select Case Mid$(Text, CursorIn, 1)
Case QUOTE
CursorIn = CursorIn + 1
Value = ParseString(Text)
Case LBRACE
CursorIn = CursorIn + 1
Set SubBag = New clsJSONBag
SubBag.DecimalMode = DecimalMode
SubBag.ParseObject Text, CursorIn, LengthIn
Set Value = SubBag
Case LBRACKET
CursorIn = CursorIn + 1
Set SubBag = New clsJSONBag
SubBag.DecimalMode = DecimalMode
SubBag.ParseArray Text, CursorIn, LengthIn
Set Value = SubBag
Case MINUS, ZERO To NINE
Value = ParseNumber(Text)
Case Else
'Special value tokens.
Token = LCase$(Mid$(Text, CursorIn, 4))
If Token = "null" Then
Value = Null
CursorIn = CursorIn + 4
ElseIf Token = "true" Then
Value = True
CursorIn = CursorIn + 4
Else
Token = LCase$(Mid$(Text, CursorIn, 5))
If Token = "false" Then
Value = False
CursorIn = CursorIn + 5
Else
Err.Raise 13, TypeNameOfMe, "Bad value at character " & CStr(CursorIn)
End If
End If
End Select
End Sub
Private Function PrefixHash(ByVal KeyString As String) As String
'This is used to make Collection access by key case-sensitive.
Dim Hash As Long
HashData StrPtr(KeyString), 2 * Len(KeyString), VarPtr(Hash), 4
PrefixHash = Right$("0000000" & Hex$(Hash), 8) & KeyString
End Function
Private Sub SerializeItem( _
ByVal ItemName As String, _
ByRef Item As Variant, _
Optional ByVal Level As Integer)
'For outer level call set CursorOut = 1 before calling. For outer level call
'or array calls pass vbNullString as ItemName for "anonymity."
Const TEXT_CHUNK As Long = 64
Dim INDENT As String
Dim Anonymous As Boolean
Dim Name As Variant
Dim ItemIndex As Long
Dim TempItem As Variant
Dim ItemBag As clsJSONBag
Dim SubBag As clsJSONBag
Dim ItemText As String
Dim ArrayItem As Variant
If Whitespace Then
INDENT = Space$(4 * Level)
End If
Anonymous = StrPtr(ItemName) = 0 'Check for vbNullString.
If Not Anonymous Then
'Not vbNullString so we have a named Item.
If Whitespace Then Cat INDENT
Cat SerializeString(ItemName) & COLON
End If
Select Case VarType(Item)
Case vbEmpty, vbNull 'vbEmpty case should actually never occur.
If Whitespace And Anonymous Then Cat INDENT
Cat "null"
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal, vbByte, vbBoolean
If Whitespace And Anonymous Then Cat INDENT
If VariantChangeTypeEx(TempItem, _
Item, _
LOCALE_INVARIANT, _
VARIANT_ALPHABOOL, _
vbString) <> S_OK Then
Err.Raise 51, TypeNameOfMe, ItemName & ", value " & CStr(Item) & " failed to serialize"
End If
Cat LCase$(TempItem) 'Convert to lowercase "true" and "false" and "1.234e34" and such.
Case vbString
If Whitespace And Anonymous Then Cat INDENT
Cat SerializeString(Item)
Case vbObject
Set ItemBag = Item
If ItemBag.IsArray Then
If Whitespace And Anonymous Then Cat INDENT
Cat LBRACKET
If ItemBag.Count < 1 Then
Cat RBRACKET
Else
If Whitespace Then Cat vbNewLine
With ItemBag
For ItemIndex = 1 To .Count
If IsObject(.Item(ItemIndex)) Then
Set TempItem = .Item(ItemIndex)
Else
TempItem = .Item(ItemIndex)
End If
SerializeItem vbNullString, TempItem, Level + 1
Cat COMMA
If Whitespace Then Cat vbNewLine
Next
End With
If Whitespace Then
CursorOut = CursorOut - 3
Cat vbNewLine & INDENT & RBRACKET
Else
Mid$(TextOut, CursorOut - 1) = RBRACKET
End If
End If
Else
If Whitespace And Anonymous Then Cat INDENT
Cat LBRACE
If ItemBag.Count < 1 Then
Cat RBRACE
Else
If Whitespace Then Cat vbNewLine
For Each Name In ItemBag
If IsObject(ItemBag.Item(Name)) Then
Set TempItem = ItemBag.Item(Name)
Else
TempItem = ItemBag.Item(Name)
End If
SerializeItem Name, TempItem, Level + 1
Cat COMMA
If Whitespace Then Cat vbNewLine
Next
If Whitespace Then
CursorOut = CursorOut - 3
Cat vbNewLine & INDENT & RBRACE
Else
Mid$(TextOut, CursorOut - 1) = RBRACE
End If
End If
End If
Case Else
Err.Raise 51, TypeNameOfMe, ItemName & ", unknown/unsupported type = " & CStr(VarType(Item))
End Select
End Sub
Private Function SerializeString(ByVal Text As String) As String
Dim BuildString As String
Dim BuildCursor As Long
Dim TextCursor As Long
Dim Char As String
Dim intChar As Integer
BuildString = Space$(3 * Len(Text) \ 2)
BuildCursor = 1
StringCat BuildString, BuildCursor, QUOTE
For TextCursor = 1 To Len(Text)
Char = Mid$(Text, TextCursor, 1)
Select Case Char
Case QUOTE, REVSOLIDUS
StringCat BuildString, BuildCursor, REVSOLIDUS & Char
Case vbBack
StringCat BuildString, BuildCursor, REVSOLIDUS & "b"
Case vbFormFeed
StringCat BuildString, BuildCursor, REVSOLIDUS & "f"
Case vbLf
StringCat BuildString, BuildCursor, REVSOLIDUS & "n"
Case vbCr
StringCat BuildString, BuildCursor, REVSOLIDUS & "r"
Case vbTab
StringCat BuildString, BuildCursor, REVSOLIDUS & "t"
Case " " To "!", "#" To LBRACKET, RBRACKET To "~"
StringCat BuildString, BuildCursor, Char
Case Else
intChar = AscW(Char)
Select Case intChar
Case 0 To &H1F, &H7F To &H9F, &H34F, &H200B To &H200F, _
&H2028 To &H202E, &H2060, &HFE01 To &HFE0F, _
&HFEFF, &HFFFD, &HD800 To &HDFFF
StringCat BuildString, BuildCursor, _
REVSOLIDUS & "u" & Right$("000" & Hex$(intChar), 4)
Case Else
StringCat BuildString, BuildCursor, Char
End Select
End Select
Next
StringCat BuildString, BuildCursor, QUOTE
SerializeString = Left$(BuildString, BuildCursor - 1)
End Function
Private Sub SkipWhitespace(ByRef Text As String)
CursorIn = CursorIn + StrSpn(StrPtr(Text) + 2 * (CursorIn - 1), StrPtr(WHITE_SPACE))
End Sub
Private Sub StringCat(ByRef TextOut As String, ByRef CursorOut, ByRef NewText As String)
Const TEXT_CHUNK As Long = 64 'Allocation size for destination buffer Text.
Dim LenNew As Long
LenNew = Len(NewText)
If LenNew > 0 Then
If CursorOut + LenNew - 1 > Len(TextOut) Then
If LenNew > TEXT_CHUNK Then
TextOut = TextOut & Space$(LenNew + TEXT_CHUNK)
Else
TextOut = TextOut & Space$(TEXT_CHUNK)
End If
End If
Mid$(TextOut, CursorOut, LenNew) = NewText
CursorOut = CursorOut + LenNew
End If
End Sub
'=== Private Events ====================================================================
Private Sub Class_Initialize()
TypeNameOfMe = TypeName(Me)
vbUS = ChrW$(&H1F&)
DecimalMode = False
Clear
End Sub
I apologize once again for not having a link to the original code and author.
There's a post on VBForums about this class, perhaps a newer version: Another-JSON-Parser-Generator