У меня такая же проблема, как в Excel VBA: Parsed JSON Object Loop, но не может найти никакого решения. У моего JSON есть вложенные объекты, поэтому предлагаемое решение вроде VBJSON и vba-json не работает для меня. Я также исправил один из них для правильной работы, но результатом было переполнение стека вызовов из-за многих рекурсий функции doProcess.
Лучшим решением является функция jsonDecode, видимая в исходном сообщении. Это очень быстро и эффективно эффективно; моя объектная структура присутствует в общем объекте VBA типа JScriptTypeInfo.
Проблема на этом этапе заключается в том, что я не могу определить, какова будет структура объектов, поэтому я заранее не знаю ключи, которые будут находиться в каждом родовом объекте. Мне нужно пропустить общий объект VBA для получения ключей/свойств.
Если моя функция разбора javascript может вызвать функцию или подпрограмму VBA, это будет отлично.
Если вы хотите построить поверх ScriptControl
, вы можете добавить несколько вспомогательных методов, чтобы получить необходимую информацию. Объект JScriptTypeInfo
немного неудачен: он содержит всю необходимую информацию (как вы можете видеть в окне "Смотреть" ), но, похоже, это невозможно с VBA. Однако механизм Javascript может помочь нам:
Option Explicit
Private ScriptEngine As ScriptControl
Public 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; } "
End Sub
Public Function DecodeJsonString(ByVal JsonString As String)
Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")")
End Function
Public Function GetProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Variant
GetProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function
Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function
Public Function GetKeys(ByVal JsonObject As Object) As String()
Dim Length As Integer
Dim KeysArray() As String
Dim KeysObject As Object
Dim Index As Integer
Dim Key As Variant
Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
Length = GetProperty(KeysObject, "length")
ReDim KeysArray(Length - 1)
Index = 0
For Each Key In KeysObject
KeysArray(Index) = Key
Index = Index + 1
Next
GetKeys = KeysArray
End Function
Public Sub TestJsonAccess()
Dim JsonString As String
Dim JsonObject As Object
Dim Keys() As String
Dim Value As Variant
Dim j As Variant
InitScriptEngine
JsonString = "{""key1"": ""val1"", ""key2"": { ""key3"": ""val3"" } }"
Set JsonObject = DecodeJsonString(CStr(JsonString))
Keys = GetKeys(JsonObject)
Value = GetProperty(JsonObject, "key1")
Set Value = GetObjectProperty(JsonObject, "key2")
End Sub
Несколько примечаний:
JScriptTypeInfo
ссылается на объект Javascript, For Each ... Next
не будет работать. Однако он работает, если он ссылается на массив Javascript (см. Функцию GetKeys
).GetProperty
и GetObjectProperty
.length
, 0
, Item 0
, 1
, Item 1
и т.д. С нотной точкой VBA (jsonObject.property
) доступно только свойство length, и только если вы объявляете переменную с именем length
со всеми строчными буквами. В противном случае случай не соответствует, и он не найдет его. Другие свойства недействительны в VBA. Поэтому лучше используйте функцию GetProperty
.InitScriptEngine
один раз, прежде чем использовать другие функции, чтобы выполнить некоторую базовую инициализацию.object variable not set
при попытке DecodeJsonString
функцию DecodeJsonString
. Есть ли какие-либо другие ссылки, которые мне нужны, кроме Microsoft Script Control?
Вот еще один метод для анализа JSON в VBA, основанный на ScriptControl
ActiveX, без внешних библиотек:
Sub JsonTest()
Dim Dict, Temp, Text, Keys, Items
' Converting JSON string to appropriate nested dictionaries structure
' Dictionaries have numeric keys for JSON Arrays, and string keys for JSON Objects
' Returns Nothing in case of any JSON syntax issues
Set Dict = GetJsonDict("{a:[[{stuff:'result'}]], b:''}")
' You can use For Each ... Next and For ... Next loops through keys and items
Keys = Dict.Keys
Items = Dict.Items
' Referring directly to the necessary property if sure, without any checks
MsgBox Dict("a")(0)(0)("stuff")
' Auxiliary DrillDown() function
' Drilling down the structure, sequentially checking if each level exists
Select Case False
Case DrillDown(Dict, "a", Temp, "")
Case DrillDown(Temp, 0, Temp, "")
Case DrillDown(Temp, 0, Temp, "")
Case DrillDown(Temp, "stuff", "", Text)
Case Else
' Structure is consistent, requested value found
MsgBox Text
End Select
End Sub
Function GetJsonDict(JsonString As String)
With CreateObject("ScriptControl")
.Language = "JScript"
.ExecuteStatement "function gettype(sample) {return {}.toString.call(sample).slice(8, -1)}"
.ExecuteStatement "function evaljson(json, er) {try {var sample = eval('(' + json + ')'); var type = gettype(sample); if(type != 'Array' && type != 'Object') {return er;} else {return getdict(sample);}} catch(e) {return er;}}"
.ExecuteStatement "function getdict(sample) {var type = gettype(sample); if(type != 'Array' && type != 'Object') return sample; var dict = new ActiveXObject('Scripting.Dictionary'); if(type == 'Array') {for(var key = 0; key < sample.length; key++) {dict.add(key, getdict(sample[key]));}} else {for(var key in sample) {dict.add(key, getdict(sample[key]));}} return dict;}"
Set GetJsonDict = .Run("evaljson", JsonString, Nothing)
End With
End Function
Function DrillDown(Source, Prop, Target, Value)
Select Case False
Case TypeName(Source) = "Dictionary"
Case Source.exists(Prop)
Case Else
Select Case True
Case TypeName(Source(Prop)) = "Dictionary"
Set Target = Source(Prop)
Value = Empty
Case IsObject(Source(Prop))
Set Value = Source(Prop)
Set Target = Nothing
Case Else
Value = Source(Prop)
Set Target = Nothing
End Select
DrillDown = True
Exit Function
End Select
DrillDown = False
End Function
ОБНОВИТЬ
Обратите внимание, что описанный выше подход делает систему уязвимой в некоторых случаях, поскольку он обеспечивает прямой доступ к дискам (и другим компонентам) для вредоносного кода JS через ActiveX. Предположим, вы анализируете ответ веб-сервера JSON, например, JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}"
. После оценки вы найдете новый созданный файл C:\Test.txt
. Поэтому анализ JSON с помощью ScriptControl
ActiveX не очень хорошая идея.
Пытаясь избежать этого, я создал JSON-парсер на основе RegEx. Объекты {}
представлены словарей, что делает возможным использование словаря свойства и методы: .Count
, .Exists()
, .Item()
, .Items
, .Keys
. Массивы []
- это обычные VB-массивы на основе нуля, поэтому UBound()
показывает количество элементов. Вот код с некоторыми примерами использования:
Option Explicit
Sub JsonTest()
Dim strJsonString As String
Dim varJson As Variant
Dim strState As String
Dim varItem As Variant
' parse JSON string to object
' root element can be the object {} or the array []
strJsonString = "{""a"":[{}, 0, ""value"", [{""stuff"":""content""}]], b:null}"
ParseJson strJsonString, varJson, strState
' checking the structure step by step
Select Case False ' if any of the checks is False, the sequence is interrupted
Case IsObject(varJson) ' if root JSON element is object {},
Case varJson.Exists("a") ' having property a,
Case IsArray(varJson("a")) ' which is array,
Case UBound(varJson("a")) >= 3 ' having not less than 4 elements,
Case IsArray(varJson("a")(3)) ' where forth element is array,
Case UBound(varJson("a")(3)) = 0 ' having the only element,
Case IsObject(varJson("a")(3)(0)) ' which is object,
Case varJson("a")(3)(0).Exists("stuff") ' having property stuff,
Case Else
MsgBox "Check the structure step by step" & vbCrLf & varJson("a")(3)(0)("stuff") ' then show the value of the last one property.
End Select
' direct access to the property if sure of structure
MsgBox "Direct access to the property" & vbCrLf & varJson.Item("a")(3)(0).Item("stuff") ' content
' traversing each element in array
For Each varItem In varJson("a")
' show the structure of the element
MsgBox "The structure of the element:" & vbCrLf & BeautifyJson(varItem)
Next
' show the full structure starting from root element
MsgBox "The full structure starting from root element:" & vbCrLf & BeautifyJson(varJson)
End Sub
Sub BeautifyTest()
' put sourse JSON string to "desktop\source.json" file
' processed JSON will be saved to "desktop\result.json" file
Dim strDesktop As String
Dim strJsonString As String
Dim varJson As Variant
Dim strState As String
Dim strResult As String
Dim lngIndent As Long
strDesktop = CreateObject("WScript.Shell").SpecialFolders.Item("Desktop")
strJsonString = ReadTextFile(strDesktop & "\source.json", -2)
ParseJson strJsonString, varJson, strState
If strState <> "Error" Then
strResult = BeautifyJson(varJson)
WriteTextFile strResult, strDesktop & "\result.json", -1
End If
CreateObject("WScript.Shell").PopUp strState, 1, , 64
End Sub
Sub ParseJson(ByVal strContent As String, varJson As Variant, strState As String)
' strContent - source JSON string
' varJson - created object or array to be returned as result
' strState - Object|Array|Error depending on processing to be returned as state
Dim objTokens As Object
Dim objRegEx As Object
Dim bMatched As Boolean
Set objTokens = CreateObject("Scripting.Dictionary")
Set objRegEx = CreateObject("VBScript.RegExp")
With objRegEx
' specification http://www.json.org/
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = """(?:\\""|[^""])*""(?=\s*(?:,|\:|\]|\}))"
Tokenize objTokens, objRegEx, strContent, bMatched, "str"
.Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)e(?:[+-])?\d+(?=\s*(?:,|\]|\}))"
Tokenize objTokens, objRegEx, strContent, bMatched, "num"
.Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)(?=\s*(?:,|\]|\}))"
Tokenize objTokens, objRegEx, strContent, bMatched, "num"
.Pattern = "\b(?:true|false|null)(?=\s*(?:,|\]|\}))"
Tokenize objTokens, objRegEx, strContent, bMatched, "cst"
.Pattern = "\b[A-Za-z_]\w*(?=\s*\:)" ' unspecified name without quotes
Tokenize objTokens, objRegEx, strContent, bMatched, "nam"
.Pattern = "\s"
strContent = .Replace(strContent, "")
.MultiLine = False
Do
bMatched = False
.Pattern = "<\d+(?:str|nam)>\:<\d+(?:str|num|obj|arr|cst)>"
Tokenize objTokens, objRegEx, strContent, bMatched, "prp"
.Pattern = "\{(?:<\d+prp>(?:,<\d+prp>)*)?\}"
Tokenize objTokens, objRegEx, strContent, bMatched, "obj"
.Pattern = "\[(?:<\d+(?:str|num|obj|arr|cst)>(?:,<\d+(?:str|num|obj|arr|cst)>)*)?\]"
Tokenize objTokens, objRegEx, strContent, bMatched, "arr"
Loop While bMatched
.Pattern = "^<\d+(?:obj|arr)>$" ' unspecified top level array
If Not (.Test(strContent) And objTokens.Exists(strContent)) Then
varJson = Null
strState = "Error"
Else
Retrieve objTokens, objRegEx, strContent, varJson
strState = IIf(IsObject(varJson), "Object", "Array")
End If
End With
End Sub
Sub Tokenize(objTokens, objRegEx, strContent, bMatched, strType)
Dim strKey As String
Dim strRes As String
Dim lngCopyIndex As Long
Dim objMatch As Object
strRes = ""
lngCopyIndex = 1
With objRegEx
For Each objMatch In .Execute(strContent)
strKey = "<" & objTokens.Count & strType & ">"
bMatched = True
With objMatch
objTokens(strKey) = .Value
strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey
lngCopyIndex = .FirstIndex + .Length + 1
End With
Next
strContent = strRes & Mid(strContent, lngCopyIndex, Len(strContent) - lngCopyIndex + 1)
End With
End Sub
Sub Retrieve(objTokens, objRegEx, strTokenKey, varTransfer)
Dim strContent As String
Dim strType As String
Dim objMatches As Object
Dim objMatch As Object
Dim strName As String
Dim varValue As Variant
Dim objArrayElts As Object
strType = Left(Right(strTokenKey, 4), 3)
strContent = objTokens(strTokenKey)
With objRegEx
.Global = True
Select Case strType
Case "obj"
.Pattern = "<\d+\w{3}>"
Set objMatches = .Execute(strContent)
Set varTransfer = CreateObject("Scripting.Dictionary")
For Each objMatch In objMatches
Retrieve objTokens, objRegEx, objMatch.Value, varTransfer
Next
Case "prp"
.Pattern = "<\d+\w{3}>"
Set objMatches = .Execute(strContent)
Retrieve objTokens, objRegEx, objMatches(0).Value, strName
Retrieve objTokens, objRegEx, objMatches(1).Value, varValue
If IsObject(varValue) Then
Set varTransfer(strName) = varValue
Else
varTransfer(strName) = varValue
End If
Case "arr"
.Pattern = "<\d+\w{3}>"
Set objMatches = .Execute(strContent)
Set objArrayElts = CreateObject("Scripting.Dictionary")
For Each objMatch In objMatches
Retrieve objTokens, objRegEx, objMatch.Value, varValue
If IsObject(varValue) Then
Set objArrayElts(objArrayElts.Count) = varValue
Else
objArrayElts(objArrayElts.Count) = varValue
End If
varTransfer = objArrayElts.Items
Next
Case "nam"
varTransfer = strContent
Case "str"
varTransfer = Mid(strContent, 2, Len(strContent) - 2)
varTransfer = Replace(varTransfer, "\""", """")
varTransfer = Replace(varTransfer, "\\", "\")
varTransfer = Replace(varTransfer, "\/", "/")
varTransfer = Replace(varTransfer, "\b", Chr(8))
varTransfer = Replace(varTransfer, "\f", Chr(12))
varTransfer = Replace(varTransfer, "\n", vbLf)
varTransfer = Replace(varTransfer, "\r", vbCr)
varTransfer = Replace(varTransfer, "\t", vbTab)
.Global = False
.Pattern = "\\u[0-9a-fA-F]{4}"
Do While .Test(varTransfer)
varTransfer = .Replace(varTransfer, ChrW(("&H" & Right(.Execute(varTransfer)(0).Value, 4)) * 1))
Loop
Case "num"
varTransfer = Evaluate(strContent)
Case "cst"
Select Case LCase(strContent)
Case "true"
varTransfer = True
Case "false"
varTransfer = False
Case "null"
varTransfer = Null
End Select
End Select
End With
End Sub
Function BeautifyJson(varJson As Variant) As String
Dim strResult As String
Dim lngIndent As Long
BeautifyJson = ""
lngIndent = 0
BeautyTraverse BeautifyJson, lngIndent, varJson, vbTab, 1
End Function
Sub BeautyTraverse(strResult As String, lngIndent As Long, varElement As Variant, strIndent As String, lngStep As Long)
Dim arrKeys() As Variant
Dim lngIndex As Long
Dim strTemp As String
Select Case VarType(varElement)
Case vbObject
If varElement.Count = 0 Then
strResult = strResult & "{}"
Else
strResult = strResult & "{" & vbCrLf
lngIndent = lngIndent + lngStep
arrKeys = varElement.Keys
For lngIndex = 0 To UBound(arrKeys)
strResult = strResult & String(lngIndent, strIndent) & """" & arrKeys(lngIndex) & """" & ": "
BeautyTraverse strResult, lngIndent, varElement(arrKeys(lngIndex)), strIndent, lngStep
If Not (lngIndex = UBound(arrKeys)) Then strResult = strResult & ","
strResult = strResult & vbCrLf
Next
lngIndent = lngIndent - lngStep
strResult = strResult & String(lngIndent, strIndent) & "}"
End If
Case Is >= vbArray
If UBound(varElement) = -1 Then
strResult = strResult & "[]"
Else
strResult = strResult & "[" & vbCrLf
lngIndent = lngIndent + lngStep
For lngIndex = 0 To UBound(varElement)
strResult = strResult & String(lngIndent, strIndent)
BeautyTraverse strResult, lngIndent, varElement(lngIndex), strIndent, lngStep
If Not (lngIndex = UBound(varElement)) Then strResult = strResult & ","
strResult = strResult & vbCrLf
Next
lngIndent = lngIndent - lngStep
strResult = strResult & String(lngIndent, strIndent) & "]"
End If
Case vbInteger, vbLong, vbSingle, vbDouble
strResult = strResult & varElement
Case vbNull
strResult = strResult & "Null"
Case vbBoolean
strResult = strResult & IIf(varElement, "True", "False")
Case Else
strTemp = Replace(varElement, "\""", """")
strTemp = Replace(strTemp, "\", "\\")
strTemp = Replace(strTemp, "/", "\/")
strTemp = Replace(strTemp, Chr(8), "\b")
strTemp = Replace(strTemp, Chr(12), "\f")
strTemp = Replace(strTemp, vbLf, "\n")
strTemp = Replace(strTemp, vbCr, "\r")
strTemp = Replace(strTemp, vbTab, "\t")
strResult = strResult & """" & strTemp & """"
End Select
End Sub
Function ReadTextFile(strPath As String, lngFormat As Long) As String
' lngFormat -2 - System default, -1 - Unicode, 0 - ASCII
With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 1, False, lngFormat)
ReadTextFile = ""
If Not .AtEndOfStream Then ReadTextFile = .ReadAll
.Close
End With
End Function
Sub WriteTextFile(strContent As String, strPath As String, lngFormat As Long)
With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 2, True, lngFormat)
.Write (strContent)
.Close
End With
End Sub
Проверьте последнюю версию VBA-JSON-parser на GitHub (импортируйте модуль JSON.bas в проект VBA для обработки JSON).
Еще одна возможность этого анализатора JSON RegEx заключается в том, что он работает в 64-разрядной версии Office, где ScriptControl недоступен.
UPDATE2
Однако, если вы хотите проанализировать JSON в 64-битном Office с помощью ScriptControl
, этот ответ может помочь вам заставить его работать.
Проще всего вы можете перейти array.myitem(0) в код VB
мой полный ответ здесь анализирует и строит (сериализует)
Используйте объект 'this' в js
ScriptEngine.AddCode "Object.prototype.myitem=function( i ) { return this[i] } ; "
Затем вы можете перейти array.myitem(0)
Private ScriptEngine As ScriptControl
Public Sub InitScriptEngine()
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"
ScriptEngine.AddCode "Object.prototype.myitem=function( i ) { return this[i] } ; "
Set foo = ScriptEngine.Eval("(" + "[ 1234, 2345 ]" + ")") ' JSON array
Debug.Print foo.myitem(1) ' method case sensitive!
Set foo = ScriptEngine.Eval("(" + "{ ""key1"":23 , ""key2"":2345 }" + ")") ' JSON key value
Debug.Print foo.myitem("key1") ' WTF
End Sub
Поскольку Json - не что иное, как струны, с ним легко можно обращаться, если мы сможем правильно им управлять, независимо от того, насколько сложна структура. Я не думаю, что для этого нужно использовать какую-либо внешнюю библиотеку или конвертер. Вот пример, где я проанализировал данные json, используя манипуляции со строками.
Sub FetchData()
Dim str As Variant, N&, R&
With New XMLHTTP60
.Open "GET", "https://oresapp.asicanada.net/ores.imis.services/api/member/?address=&callback=angular.callbacks._0&city=&companyName=&personName=", False
.send
str = Split(.responseText, ":[{""Id"":")
End With
N = UBound(str)
For R = 1 To N
Cells(R, 1) = Split(Split(str(R), "FullName"":""")(1), """")(0)
Cells(R, 2) = Split(Split(str(R), "Phone"":""")(1), """")(0)
Cells(R, 3) = Split(Split(str(R), "Email"":""")(1), """")(0)
Next R
End Sub
Split(<string>, <delimiter>, 2)
в цикл, где необходим один результат, может повысить производительность.
Это работает для меня в Excel и больших JSON файлах с использованием JSON-запроса, переведенного в нативную форму. https://github.com/VBA-tools/VBA-JSON Я могу разобрать узел типа "item.something" и получить значение с помощью простой команды:
MsgBox Json("item")("something")
Что мило.
Два небольших вклада в Codo ответ:
' "recursive" version of GetObjectProperty
Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
Dim names() As String
Dim i As Integer
names = Split(propertyName, ".")
For i = 0 To UBound(names)
Set JsonObject = ScriptEngine.Run("getProperty", JsonObject, names(i))
Next
Set GetObjectProperty = JsonObject
End Function
' shortcut to object array
Public Function GetObjectArrayProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object()
Dim a() As Object
Dim i As Integer
Dim l As Integer
Set JsonObject = GetObjectProperty(JsonObject, propertyName)
l = GetProperty(JsonObject, "length") - 1
ReDim a(l)
For i = 0 To l
Set a(i) = GetObjectProperty(JsonObject, CStr(i))
Next
GetObjectArrayProperty = a
End Function
Итак, теперь я могу делать такие вещи, как:
Dim JsonObject As Object
Dim Value() As Object
Dim i As Integer
Dim Total As Double
Set JsonObject = DecodeJsonString(CStr(request.responseText))
Value = GetObjectArrayProperty(JsonObject, "d.Data")
For i = 0 To UBound(Value)
Total = Total + Value(i).Amount
Next
Другой парсер JSON на основе Regex (только для декодирования)
Private Enum JsonStep
jsonString
jsonNumber
jsonTrue
jsonFalse
jsonNull
jsonOpeningBrace
jsonClosingBrace
jsonOpeningBracket
jsonClosingBracket
jsonComma
jsonColon
End Enum
Private regexp As Object
Private Function JsonStepName(ByVal json_step As JsonStep) As String
Select Case json_step
Case jsonString: JsonStepName = "'STRING'"
Case jsonNumber: JsonStepName = "'NUMBER'"
Case jsonTrue: JsonStepName = "true"
Case jsonFalse: JsonStepName = "false"
Case jsonNull: JsonStepName = "null"
Case jsonOpeningBrace: JsonStepName = "'{'"
Case jsonClosingBrace: JsonStepName = "'}'"
Case jsonOpeningBracket: JsonStepName = "'['"
Case jsonClosingBracket: JsonStepName = "']'"
Case jsonComma: JsonStepName = "','"
Case jsonColon: JsonStepName = "':'"
End Select
End Function
Private Function Unescape(ByVal str As String) As String
Dim match As Object
str = Replace$(str, "\""", """")
str = Replace$(str, "\\", "\")
str = Replace$(str, "\/", "/")
str = Replace$(str, "\b", vbBack)
str = Replace$(str, "\f", vbFormFeed)
str = Replace$(str, "\n", vbCrLf)
str = Replace$(str, "\r", vbCr)
str = Replace$(str, "\t", vbTab)
With regexp
.Global = True
.IgnoreCase = False
.MultiLine = False
.Pattern = "\\u([0-9a-fA-F]{4})"
For Each match In .Execute(str)
str = Replace$(str, match.value, ChrW$(Val("&H" + match.SubMatches(0))), match.FirstIndex + 1, 1)
Next match
End With
Unescape = str
End Function
Private Function ParseStep(ByVal str As String, _
ByRef index As Long, _
ByRef value As Variant, _
ByVal json_step As JsonStep, _
ByVal expected As Boolean) As Boolean
Dim match As Object
With regexp
.Global = False
.IgnoreCase = False
.MultiLine = False
Select Case json_step
'Case jsonString: .Pattern = "^\s*""(([^\\""]+|\\[""\\/bfnrt]|\\u[0-9a-fA-F]{4})*)""\s*"
Case jsonString: .Pattern = "^\s*""([^\\""]+|([^\\""]+|\\[""\\/bfnrt]|\\u[0-9a-fA-F]{4})*)""\s*"
Case jsonNumber: .Pattern = "^\s*(-?(0|[1-9]\d*)(\.\d+)?([eE][-+]?\d+)?)\s*"
Case jsonTrue: .Pattern = "^\s*(true)\s*"
Case jsonFalse: .Pattern = "^\s*(false)\s*"
Case jsonNull: .Pattern = "^\s*(null)\s*"
Case jsonOpeningBrace: .Pattern = "^\s*(\{)\s*"
Case jsonClosingBrace: .Pattern = "^\s*(\})\s*"
Case jsonOpeningBracket: .Pattern = "^\s*(\[)\s*"
Case jsonClosingBracket: .Pattern = "^\s*(\])\s*"
Case jsonComma: .Pattern = "^\s*(\,)\s*"
Case jsonColon: .Pattern = "^\s*(:)\s*"
End Select
Set match = .Execute(Mid$(str, index))
End With
If match.Count > 0 Then
index = index + match(0).Length
Select Case json_step
Case jsonString
If match(0).SubMatches(1) = Empty Then
value = match(0).SubMatches(0)
Else
value = Unescape(match(0).SubMatches(0))
End If
Case jsonNumber: value = Val(match(0).SubMatches(0))
Case jsonTrue: value = True
Case jsonFalse: value = False
Case jsonNull: value = Null
Case Else: value = Empty
End Select
ParseStep = True
ElseIf expected Then
Err.Raise 10001, "ParseJson", "Expecting " & JsonStepName(json_step) & " at char " & index & "."
End If
End Function
Private Function ParseValue(ByRef str As String, _
ByRef index As Long, _
ByRef value As Variant, _
ByVal expected As Boolean) As Boolean
ParseValue = True
If ParseStep(str, index, value, jsonString, False) Then Exit Function
If ParseStep(str, index, value, jsonNumber, False) Then Exit Function
If ParseObject(str, index, value, False) Then Exit Function
If ParseArray(str, index, value, False) Then Exit Function
If ParseStep(str, index, value, jsonTrue, False) Then Exit Function
If ParseStep(str, index, value, jsonFalse, False) Then Exit Function
If ParseStep(str, index, value, jsonNull, False) Then Exit Function
ParseValue = False
If expected Then
Err.Raise 10001, "ParseJson", "Expecting " & JsonStepName(jsonString) & ", " & JsonStepName(jsonNumber) & ", " & JsonStepName(jsonTrue) & ", " & JsonStepName(jsonFalse) & ", " & JsonStepName(jsonNull) & ", " & JsonStepName(jsonOpeningBrace) & ", or " & JsonStepName(jsonOpeningBracket) & " at char " & index & "."
End If
End Function
Private Function ParseObject(ByRef str As String, _
ByRef index As Long, _
ByRef obj As Variant, _
ByVal expected As Boolean) As Boolean
Dim key As Variant
Dim value As Variant
ParseObject = ParseStep(str, index, Empty, jsonOpeningBrace, expected)
If ParseObject Then
Set obj = CreateObject("Scripting.Dictionary")
If ParseStep(str, index, Empty, jsonClosingBrace, False) Then Exit Function
Do
If ParseStep(str, index, key, jsonString, True) Then
If ParseStep(str, index, Empty, jsonColon, True) Then
If ParseValue(str, index, value, True) Then
If IsObject(value) Then
Set obj.Item(key) = value
Else
obj.Item(key) = value
End If
End If
End If
End If
Loop While ParseStep(str, index, Empty, jsonComma, False)
ParseObject = ParseStep(str, index, Empty, jsonClosingBrace, True)
End If
End Function
Private Function ParseArray(ByRef str As String, _
ByRef index As Long, _
ByRef arr As Variant, _
ByVal expected As Boolean) As Boolean
Dim key As Variant
Dim value As Variant
ParseArray = ParseStep(str, index, Empty, jsonOpeningBracket, expected)
If ParseArray Then
Set arr = New Collection
If ParseStep(str, index, Empty, jsonClosingBracket, False) Then Exit Function
Do
If ParseValue(str, index, value, True) Then
arr.Add value
End If
Loop While ParseStep(str, index, Empty, jsonComma, False)
ParseArray = ParseStep(str, index, Empty, jsonClosingBracket, True)
End If
End Function
Public Function ParseJson(ByVal str As String) As Object
If regexp Is Nothing Then
Set regexp = CreateObject("VBScript.RegExp")
End If
If ParseObject(str, 1, ParseJson, False) Then Exit Function
If ParseArray(str, 1, ParseJson, False) Then Exit Function
Err.Raise 10001, "ParseJson", "Expecting " & JsonStepName(jsonOpeningBrace) & " or " & JsonStepName(jsonOpeningBracket) & "."
End Function
Microsoft. Поскольку VBScript является подмножеством Visual Basic для Приложения,...
Нижеприведенный код выводится из сообщения Codo, если он также полезен в форме класса и может использоваться как VBScript:
class JsonParser
' adapted from: http://stackoverflow.com/questions/6627652/parsing-json-in-excel-vba
private se
private sub Class_Initialize
set se = CreateObject("MSScriptControl.ScriptControl")
se.Language = "JScript"
se.AddCode "function getValue(jsonObj, valueName) { return jsonObj[valueName]; } "
se.AddCode "function enumKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
end sub
public function Decode(ByVal json)
set Decode = se.Eval("(" + cstr(json) + ")")
end function
public function GetValue(ByVal jsonObj, ByVal valueName)
GetValue = se.Run("getValue", jsonObj, valueName)
end function
public function GetObject(ByVal jsonObject, ByVal valueName)
set GetObjet = se.Run("getValue", jsonObject, valueName)
end function
public function EnumKeys(ByVal jsonObject)
dim length, keys, obj, idx, key
set obj = se.Run("enumKeys", jsonObject)
length = GetValue(obj, "length")
redim keys(length - 1)
idx = 0
for each key in obj
keys(idx) = key
idx = idx + 1
next
EnumKeys = keys
end function
end class
Использование:
set jp = new JsonParser
set jo = jp.Decode("{value: true}")
keys = jp.EnumKeys(jo)
value = jp.GetValue(jo, "value")
Большое спасибо Codo.
Я только что обновил и выполнил все, что вы сделали:
добавить, удалить и обновить node (кто знает)
Option Explicit
Private ScriptEngine As ScriptControl
Public Sub InitScriptEngine()
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"
ScriptEngine.AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
ScriptEngine.AddCode "function getType(jsonObj, propertyName) {return typeof(jsonObj[propertyName]);}"
ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
ScriptEngine.AddCode "function addKey(jsonObj, propertyName, value) { jsonObj[propertyName] = value; return jsonObj;}"
ScriptEngine.AddCode "function removeKey(jsonObj, propertyName) { var json = jsonObj; delete json[propertyName]; return json }"
End Sub
Public Function removeJSONProperty(ByVal JsonObject As Object, propertyName As String)
Set removeJSONProperty = ScriptEngine.Run("removeKey", JsonObject, propertyName)
End Function
Public Function updateJSONPropertyValue(ByVal JsonObject As Object, propertyName As String, value As String) As Object
Set updateJSONPropertyValue = ScriptEngine.Run("removeKey", JsonObject, propertyName)
Set updateJSONPropertyValue = ScriptEngine.Run("addKey", JsonObject, propertyName, value)
End Function
Public Function addJSONPropertyValue(ByVal JsonObject As Object, propertyName As String, value As String) As Object
Set addJSONPropertyValue = ScriptEngine.Run("addKey", JsonObject, propertyName, value)
End Function
Public Function DecodeJsonString(ByVal JsonString As String)
InitScriptEngine
Set DecodeJsonString = ScriptEngine.Eval("(" + JsonString + ")")
End Function
Public Function GetProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Variant
GetProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function
Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal propertyName As String) As Object
Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, propertyName)
End Function
Public Function SerializeJSONObject(ByVal JsonObject As Object) As String()
Dim Length As Integer
Dim KeysArray() As String
Dim KeysObject As Object
Dim Index As Integer
Dim Key As Variant
Dim tmpString As String
Dim tmpJSON As Object
Dim tmpJSONArray() As Variant
Dim tmpJSONObject() As Variant
Dim strJsonObject As String
Dim tmpNbElement As Long, i As Long
InitScriptEngine
Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
Length = GetProperty(KeysObject, "length")
ReDim KeysArray(Length - 1)
Index = 0
For Each Key In KeysObject
tmpString = ""
If ScriptEngine.Run("getType", JsonObject, Key) = "object" Then
'MsgBox "object " & SerializeJSONObject(GetObjectProperty(JsonObject, Key))(0)
Set tmpJSON = GetObjectProperty(JsonObject, Key)
strJsonObject = VBA.Replace(ScriptEngine.Run("getKeys", tmpJSON), " ", "")
tmpNbElement = Len(strJsonObject) - Len(VBA.Replace(strJsonObject, ",", ""))
If VBA.IsNumeric(Left(ScriptEngine.Run("getKeys", tmpJSON), 1)) = True Then
ReDim tmpJSONArray(tmpNbElement)
For i = 0 To tmpNbElement
tmpJSONArray(i) = GetProperty(tmpJSON, i)
Next
tmpString = "[" & Join(tmpJSONArray, ",") & "]"
Else
tmpString = "{" & Join(SerializeJSONObject(tmpJSON), ", ") & "}"
End If
Else
tmpString = GetProperty(JsonObject, Key)
End If
KeysArray(Index) = Key & ": " & tmpString
Index = Index + 1
Next
SerializeJSONObject = KeysArray
End Function
Public Function GetKeys(ByVal JsonObject As Object) As String()
Dim Length As Integer
Dim KeysArray() As String
Dim KeysObject As Object
Dim Index As Integer
Dim Key As Variant
InitScriptEngine
Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
Length = GetProperty(KeysObject, "length")
ReDim KeysArray(Length - 1)
Index = 0
For Each Key In KeysObject
KeysArray(Index) = Key
Index = Index + 1
Next
GetKeys = KeysArray
End Function