Option Explicit
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
Public Function JsonParse(sText As String, vResult As Variant, Optional Error As String) As Boolean
Dim uCtx As JsonContext
Dim oResult As Object
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
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 Dictionary) As Boolean
'--- note: when using collections change type of parameter oResult to Collection
#Const USE_COLLECTION = False
Dim lIdx As Long
Dim vKey As Variant
Dim vValue As Variant
Dim oValue As Object
Dim sText As String
vValue = pvJsonMissing
With uCtx
Select Case pvJsonGetChar(uCtx)
Case 34 ' "
vResult = pvJsonGetString(uCtx)
Case 91 ' [
#If USE_COLLECTION Then
Set oResult = New Collection
#Else
Set oResult = CreateObject("Scripting.Dictionary")
#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_COLLECTION Then
Set oResult = New Collection
#Else
Set oResult = CreateObject("Scripting.Dictionary")
oResult.CompareMode = 1 ' TextCompare
#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 <> 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 EH
vResult = CDbl(sText)
On Error GoTo 0
.Pos = .Pos + lIdx
Case 0
'--- return empty
Case Else
GoTo UnexpectedSymbol
End Select
pvJsonParse = True
QH:
Exit Function
UnexpectedSymbol:
.Error = "Unexpected symbol '" & ChrW$(.LastChar) & "' at position " & .Pos
Exit Function
EH:
.Error = Error$ & " at position " & .Pos
End With
End Function
Private Function pvJsonGetChar(uCtx As JsonContext) As Integer
With uCtx
If .Pos <= UBound(.Text) Then
SkipWhitespace:
.LastChar = .Text(.Pos)
.Pos = .Pos + 1
Select Case .LastChar
Case 32, 9, 10, 13 ' " ", vbTab, vbCr, vbLf
GoTo SkipWhitespace
Case 0
Exit Function
Case Else
pvJsonGetChar = .LastChar
End Select
End If
End With
End Function
Private Function pvJsonGetString(uCtx As JsonContext) As String
Dim lIdx As Long
Dim nChar As Integer
Dim sText As String
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
End Function
Public Function JsonDump(vJson As Variant, Optional ByVal lLevel As Long) As String
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 lAsc As Long
On Error GoTo EH
Select Case VarType(vJson)
Case vbObject
sCompound = IIf(vJson.CompareMode = 0, "[]", "{}")
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), lLevel + 1)
If VarType(vKeys(lIdx)) = vbString Then
vItems(lIdx) = JsonDump(vKeys(lIdx)) & ": " & vItems(lIdx)
End If
lSize = lSize + Len(vItems(lIdx))
Next
If lSize > 100 Then
JsonDump = Left$(sCompound, 1) & vbCrLf & _
Space((lLevel + 1) * INDENT) & Join(vItems, "," & vbCrLf & Space((lLevel + 1) * INDENT)) & vbCrLf & _
Space(lLevel * INDENT) & Right$(sCompound, 1)
Else
JsonDump = Left$(sCompound, 1) & " " & Join(vItems, ", ") & " " & 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:
Debug.Print Error
Resume Next
End Function
Reply With Quote
Originally Posted by wqweto
