Парсер JSON в Excel VBA с использованием JavaScript

Как известно, в Microsoft Excel отсутствут стандартные возможности для разбора строки json-файла. Тем не менее, для этой цели возможно использовать стандартные библиотеки Excel и функции javascript. Код для разбора строки json прилагается.

Пример использования:

Private Sub Example()
Dim J As New JsonObject, S: S = "json string"
Dim d As Dictionary: J.Run S: Set d = J.DicObject
PrintJSON d
Set J = Nothing: Set d = Nothing
End Sub

Private Sub PrintJSON(d As Dictionary, Optional index = "")
Dim k, i, keys, items: keys = d.keys: k = d.Count - 1: items = d.items
For i = 0 To k
If Not IsObject(items(i)) Then
Debug.Print Trim(index & " " & i), keys(i), items(i)
Else
Debug.Print i, keys(i), TypeName(items(i))
Dim dd As New Dictionary: Set dd = items(i)
PrintJSON dd, i
End If
Next
End Sub

Модуль класса JSONObject для разбора строки json и получения стандартного объекта Dictionary


Option Explicit
'Need Microsoft Script Control and Microsoft Scripting Runtime

Private ScriptEngine As ScriptControl
Private jObject As Object
Private dObject As Object
'===Public===============
Public Sub Run(ByVal JsonString As String)
Set jObject = DecodeJsonString(JsonString)
Dim d As New Dictionary
ParseJSON jObject, d, "json"
End Sub
Public Property Get DicObject() As Object
Set DicObject = dObject
End Property
'===Private===============
Private Sub Class_Initialize()
Set ScriptEngine = Nothing: Set jObject = Nothing: Set dObject = Nothing
InitScriptEngine
End Sub
Private Sub Class_Terminate()
Set jObject = Nothing: Set dObject = Nothing: Set ScriptEngine = Nothing
End Sub
'=========================
Private Sub InitScriptEngine()
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"
ScriptEngine.AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
ScriptEngine.AddCode "function getType(jsonObj, propertyName) {return typeof(jsonObj[propertyName]);}"
End Sub
Private Function DecodeJsonString(ByVal JsonString As String)
InitScriptEngine
Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")")
End Function
Private Function GetProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Variant
GetProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function
Private Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
On Error GoTo ErJson
Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
Exit Function
ErJson:
Set GetObjectProperty = Nothing
End Function
Private Function GetObjectPropertyType(ByVal JsonObject As Object, ByVal propertyName As String) As Variant
GetObjectPropertyType = ScriptEngine.Run("getType", JsonObject, propertyName)
End Function

Private Sub ParseJSON(JSObject As Object, DCObj As Dictionary, OldKey)
Dim Length As Integer, KeysObject As Object: Set KeysObject = ScriptEngine.Run("getKeys", JSObject)
Length = GetProperty(KeysObject, "length")
If Length ≠ 0 Then
Dim Key As Variant, newDCObj As New Dictionary, DCObj_k

For Each Key In KeysObject
If InStr(1, GetObjectPropertyType(JSObject, Key), "bject") = 0 Then
Dim val: val = GetProperty(JSObject, Key)
DCObj_k = Key: newDCObj.Add DCObj_k, val
Else
Dim a As Object: Set a = GetObjectProperty(JSObject, Key)
ParseJSON a, DCObj, Key
End If
Next
DCObj.Add OldKey, newDCObj
End If
Set dObject = DCObj
End Sub