VBA парсер JSON без сторонних библиотек

Парсер JSON разбором строки. Без сторонних библиотек и java-script

Использование

dim s as String: s=“{json}”

Dim p as New JsonParser, o as Object: Set o=p.Parse(s)

Модуль класса JsonParser

Private mSourceStr As String
Private mPosition As Long
Private mLength As Long

Public Function Parse(ByVal sourceString As String) As Object
If Len(sourceString) = 0 Then
Exit Function
End If
mSourceStr = sourceString
mLength = Len(sourceString)

For mPosition = 1 To mLength
Select Case Mid$(sourceString, mPosition, 1)
Case "["
Set Parse = ParseArray2Collection()
Case "{"
Set Parse = ParseHash2Dictionary()
End Select
Next mPosition

End Function

Private Function ParseArray2Collection() As Collection

Dim returnCol As Collection
Set returnCol = New Collection

For mPosition = (mPosition + 1) To mLength
Select Case Mid$(mSourceStr, mPosition, 1)
Case " ", vbTab, vbCr, vbLf
Case "]"
Exit For
Case "["
Dim col As Collection
Set col = ParseArray2Collection()
returnCol.Add col
Case "{"
Dim hash As Scripting.Dictionary
Set hash = ParseHash2Dictionary()
returnCol.Add hash
Case ","
Case """", "'"
Dim dstr As String
dstr = ParseQuotedString()
returnCol.Add dstr
Case Else
Dim str As String
str = ParseString()
returnCol.Add str
End Select
Next mPosition

Set ParseArray2Collection = returnCol
End Function

Private Function ParseHash2Dictionary() As Scripting.Dictionary

Dim returnDic As Scripting.Dictionary
Set returnDic = New Scripting.Dictionary
Dim currentKey As String: currentKey = ""
Dim atKey As Boolean: atKey = True

For mPosition = (mPosition + 1) To mLength
Select Case Mid$(mSourceStr, mPosition, 1)
Case " ", vbTab, vbCr, vbLf
Case "}"
Exit For
Case "["
Dim col As Collection
Set col = ParseArray2Collection()
returnDic.Add currentKey, col
currentKey = ""
atKey = Not atKey
Case "{"
Dim dic As Scripting.Dictionary
Set dic = ParseHash2Dictionary()
returnDic.Add currentKey, dic
currentKey = ""
atKey = Not atKey
Case ":", ","
Case """", "'"
Dim dstr As String
dstr = ParseQuotedString()
If Not atKey Then
returnDic.Add currentKey, dstr
currentKey = ""
Else
currentKey = dstr
End If
atKey = Not atKey
Case Else
Dim str As String
str = ParseString()
If Not atKey Then
returnDic.Add currentKey, str
currentKey = ""
Else
currentKey = str
End If
atKey = Not atKey
End Select
Next mPosition

Set ParseHash2Dictionary = returnDic
End Function

Private Function ParseString() As String

Dim startPosition As Long: startPosition = mPosition
Dim currentStr As String
For mPosition = (mPosition + 1) To mLength

currentStr = Mid$(mSourceStr, mPosition, 1)
Select Case currentStr
Case ",", ":", "}", "]"
mPosition = mPosition - 1
Exit For
End Select
Next mPosition

If mPosition > mLength Then
ParseString = Mid$(mSourceStr, startPosition)
Exit Function
End If

ParseString = Mid$(mSourceStr, startPosition, mPosition - startPosition + 1)
End Function

Private Function ParseQuotedString() As String

Dim startPosition As Long: startPosition = mPosition
Dim doubleQuoted As Boolean: doubleQuoted = (Mid$(mSourceStr, mPosition, 1) = """")
Dim singleQuoted As Boolean: singleQuoted = (Mid$(mSourceStr, mPosition, 1) = "'")
Dim escaped As Boolean: escaped = False
Dim currentStr As String

For mPosition = (mPosition + 1) To mLength
currentStr = Mid$(mSourceStr, mPosition, 1)
If Not escaped Then
If doubleQuoted Then
If currentStr = """" Then
Exit For
End If
ElseIf singleQuoted Then
If currentStr = "'" Then
Exit For
End If
End If
If currentStr = "\" Then
escaped = True
End If
Else
escaped = False
End If
Next mPosition
If mPosition > mLength Then
ParseQuotedString = Mid$(mSourceStr, startPosition + 1)
Exit Function
End If

ParseQuotedString = Mid$(mSourceStr, startPosition + 1, mPosition - startPosition - 1)
End Function