Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
JSON parsing and dumping functions in VB6
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.