Excel VBA에서의 JSON 해석
Excel VBA와 동일한 문제: 구문 분석된 JSON Object Loop이 발생하지만 해결 방법을 찾을 수 없습니다.JSON에는 네스트된 개체가 있기 때문에 VBJSON이나 vba-json과 같은 권장 솔루션은 사용할 수 없습니다.그 중 하나가 정상적으로 동작하도록 수정했지만 doProcess 함수의 재귀가 많기 때문에 콜스택 오버플로가 발생하였습니다.
가장 좋은 솔루션은 원래 게시물에서 볼 수 있는 jsonDecode 함수인 것으로 보입니다.매우 빠르고 매우 효과적입니다.오브젝트 구조는 JScriptTypeInfo 타입의 범용 VBA 오브젝트에 모두 포함되어 있습니다.
현시점에서는 오브젝트의 구조를 결정할 수 없기 때문에 각 범용 오브젝트에 존재하는 키를 사전에 알 수 없습니다.키/속성을 취득하려면 범용 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. - 은 Javascript 속성을 합니다.
length,0,Item 0,1,Item 1VBA 도트 ).jsonObject.property할 수 .이것은 length라는 를 "length"로 또한 변수를 선언한 경우에만length모두 소문자로 표시됩니다.그렇지 않으면 케이스가 일치하지 않고 찾을 수 없습니다.VBA를 사용하다 이 글을 게 것 같아요.GetProperty★★★★★★ 。 - 이 코드는 얼리바인딩을 사용합니다.따라서 "Microsoft Script Control 1.0"에 대한 참조를 추가해야 합니다.
- 요.
InitScriptEngine기본 초기화를 수행하기 전에 다른 기능을 사용하기 전에 한 번 클릭합니다.
업데이트 3 ('17년 7월 24일)
GitHub의 VBA-JSON-parser에서 최신 버전과 예를 확인합니다.JSON.bas 모듈을 VBA 프로젝트로 Import하여 JSON 처리를 수행합니다.
업데이트 2 (2016년 10월 1일)
, 에서 JSON을 64비트 Office에서 JSON을 합니다.ScriptControl이 답변이 도움이 될 수 있습니다.ScriptControl64번입니다.
업데이트 (2015년 10월 26일)
과 같습니다.ScriptControl는 ActiveX를인 JS 및 기타 정보)에 직접 수 에 경우에 ActiveX는 JS를 통해 ActiveX에 액세스합니다.를 들어 웹 응답 JSON을.JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}"C:\Test.txt JSON을 구문ScriptControlActiveX가 있다.
JSON의 RegEx입니다. 「」{}할 수 됩니다..Count,.Exists(),.Item(),.Items,.Keys.[] VB이므로 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
이 JSON RegEx 파서는 ScriptControl을 사용할 수 없는 64비트 Office에서 사용할 수 있습니다.
초기(2015년 5월 27일)
을 하나 더 이 방법은 'VBA의 JSON의 JSON의 1의 JSON'에 근거한 것입니다.ScriptControlActiveX, "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
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
워크북 프로젝트에 대규모 라이브러리를 추가하지 않고 VBA에서 JSON을 해석하기 위해 다음과 같은 솔루션을 만들었습니다.매우 빠르고 모든 키와 값을 사전에 저장하여 쉽게 액세스할 수 있습니다.
Function ParseJSON(json$, Optional key$ = "obj") As Object
p = 1
token = Tokenize(json)
Set dic = CreateObject("Scripting.Dictionary")
If token(p) = "{" Then ParseObj key Else ParseArr key
Set ParseJSON = dic
End Function
Function ParseObj(key$)
Do: p = p + 1
Select Case token(p)
Case "]"
Case "[": ParseArr key
Case "{"
If token(p + 1) = "}" Then
p = p + 1
dic.Add key, "null"
Else
ParseObj key
End If
Case "}": key = ReducePath(key): Exit Do
Case ":": key = key & "." & token(p - 1)
Case ",": key = ReducePath(key)
Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
End Select
Loop
End Function
Function ParseArr(key$)
Dim e&
Do: p = p + 1
Select Case token(p)
Case "}"
Case "{": ParseObj key & ArrayID(e)
Case "[": ParseArr key
Case "]": Exit Do
Case ":": key = key & ArrayID(e)
Case ",": e = e + 1
Case Else: dic.Add key & ArrayID(e), token(p)
End Select
Loop
End Function
위의 코드는 몇 가지 도우미 기능을 사용하지만, 위의 코드는 그 핵심입니다.
여기서 사용하는 전략은 재귀 토큰라이저를 사용하는 것입니다.저는 이 솔루션에 대한 기사를 Medium에 쓸 만큼 충분히 흥미롭다고 생각했습니다.자세한 것은 이쪽에서 설명하겠습니다.
다음은 모든 도우미 기능을 포함한 전체(놀랍게도 짧은) 코드 목록입니다.
'-------------------------------------------------------------------
' VBA JSON Parser
'-------------------------------------------------------------------
Option Explicit
Private p&, token, dic
Function ParseJSON(json$, Optional key$ = "obj") As Object
p = 1
token = Tokenize(json)
Set dic = CreateObject("Scripting.Dictionary")
If token(p) = "{" Then ParseObj key Else ParseArr key
Set ParseJSON = dic
End Function
Function ParseObj(key$)
Do: p = p + 1
Select Case token(p)
Case "]"
Case "[": ParseArr key
Case "{"
If token(p + 1) = "}" Then
p = p + 1
dic.Add key, "null"
Else
ParseObj key
End If
Case "}": key = ReducePath(key): Exit Do
Case ":": key = key & "." & token(p - 1)
Case ",": key = ReducePath(key)
Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
End Select
Loop
End Function
Function ParseArr(key$)
Dim e&
Do: p = p + 1
Select Case token(p)
Case "}"
Case "{": ParseObj key & ArrayID(e)
Case "[": ParseArr key
Case "]": Exit Do
Case ":": key = key & ArrayID(e)
Case ",": e = e + 1
Case Else: dic.Add key & ArrayID(e), token(p)
End Select
Loop
End Function
'-------------------------------------------------------------------
' Support Functions
'-------------------------------------------------------------------
Function Tokenize(s$)
Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"
Tokenize = RExtract(s, Pattern, True)
End Function
Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)
Dim c&, m, n, v
With CreateObject("vbscript.regexp")
.Global = bGlobal
.MultiLine = False
.IgnoreCase = True
.Pattern = Pattern
If .TEST(s) Then
Set m = .Execute(s)
ReDim v(1 To m.Count)
For Each n In m
c = c + 1
v(c) = n.value
If bGroup1Bias Then If Len(n.submatches(0)) Or n.value = """""" Then v(c) = n.submatches(0)
Next
End If
End With
RExtract = v
End Function
Function ArrayID$(e)
ArrayID = "(" & e & ")"
End Function
Function ReducePath$(key$)
If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1)
End Function
Function ListPaths(dic)
Dim s$, v
For Each v In dic
s = s & v & " --> " & dic(v) & vbLf
Next
Debug.Print s
End Function
Function GetFilteredValues(dic, match)
Dim c&, i&, v, w
v = dic.keys
ReDim w(1 To dic.Count)
For i = 0 To UBound(v)
If v(i) Like match Then
c = c + 1
w(c) = dic(v(i))
End If
Next
ReDim Preserve w(1 To c)
GetFilteredValues = w
End Function
Function GetFilteredTable(dic, cols)
Dim c&, i&, j&, v, w, z
v = dic.keys
z = GetFilteredValues(dic, cols(0))
ReDim w(1 To UBound(z), 1 To UBound(cols) + 1)
For j = 1 To UBound(cols) + 1
z = GetFilteredValues(dic, cols(j - 1))
For i = 1 To UBound(z)
w(i, j) = z(i)
Next
Next
GetFilteredTable = w
End Function
Function OpenTextFile$(f)
With CreateObject("ADODB.Stream")
.Charset = "utf-8"
.Open
.LoadFromFile f
OpenTextFile = .ReadText
End With
End Function
VB 코드로 array.myitem(0)을 간단하게 실행할 수 있습니다.
여기서의 나의 완전한 답변은 해석과 스트링화(크기 조정)입니다.
js에서 'this' 개체를 사용합니다.
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
이것은 Excel과 네이티브 형식으로 번역된 JSON 쿼리를 사용하여 큰 JSON 파일을 사용할 수 있습니다.https://github.com/VBA-tools/VBA-JSON "item"과 같은 노드를 해석할 수 있습니다.something" 및 간단한 명령어를 사용하여 값을 가져옵니다.
MsgBox Json("item")("something")
뭐가 좋아요?
Microsoft: VBScript는 Visual Basic for Applications의 서브셋이기 때문에...
아래 코드는 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")
고마워요, 코도
에 대해 수행한 작업을 방금 업데이트하고 완료했습니다.
- json을 serialize(텍스트와 같은 문서에 json을 주입하려면 필요)
노드 추가, 삭제 및 업데이트(누가 알겠는가)
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
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
여기 좋은 답변들이 많이 있다 - 그냥 나 혼자만 할 수 있다.
Web-API 콜의 발신 결과를 나타내는 매우 구체적인 JSON 문자열을 해석할 필요가 있었습니다.JSON은 오브젝트 목록을 설명했는데 다음과 같이 되어 있습니다.
[
{
"property1": "foo",
"property2": "bar",
"timeOfDay": "2019-09-30T00:00:00",
"numberOfHits": 98,
"isSpecial": false,
"comment": "just to be awkward, this contains a comma"
},
{
"property1": "fool",
"property2": "barrel",
"timeOfDay": "2019-10-31T00:00:00",
"numberOfHits": 11,
"isSpecial": false,
"comment": null
},
...
]
여기에는 몇 가지 주의사항이 있습니다.
- JSON은 항상 목록을 기술해야 합니다(비어 있는 경우에도). 목록에는 객체만 포함되어야 합니다.
- 목록의 개체는 단순한 유형(문자열 / 날짜 / 숫자 / 부울 또는)의 속성만 포함해야 합니다.
null). - 속성 값에는 쉼표가 포함되어 있어 JSON 구문 분석이 다소 어려워질 수 있지만 따옴표는 포함되어 있지 않을 수 있습니다(그것은 너무 귀찮아서 처리할 수 없습니다).
그ParseListOfObjects아래 코드의 함수는 JSON 문자열을 입력으로 받아 a를 반환합니다.Collection목록의 항목을 나타냅니다.각 항목은 다음과 같이 표시됩니다.Dictionary여기서 사전의 키는 개체의 속성 이름에 해당합니다.은 자동으로 유형으로 됩니다( （ ） 。String,Date,Double,Boolean - 는 -Empty이 「」인 null를 참조해 주세요.
에서는 VBA에 합니다.Microsoft Scripting Runtime: " " " " "Dictionary- 하면 이 .object - 른른 、 른른 、 른른 、 른 object 、 - object 、 - object 、 object object 、 object object object object object object object 。
여기 .JSON.bas:
Option Explicit
' NOTE: a fully-featured JSON parser in VBA would be a beast.
' This simple parser only supports VERY simple JSON (which is all we need).
' Specifically, it supports JSON comprising a list of objects, each of which has only simple properties.
Private Const strSTART_OF_LIST As String = "["
Private Const strEND_OF_LIST As String = "]"
Private Const strLIST_DELIMITER As String = ","
Private Const strSTART_OF_OBJECT As String = "{"
Private Const strEND_OF_OBJECT As String = "}"
Private Const strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR As String = ":"
Private Const strQUOTE As String = """"
Private Const strNULL_VALUE As String = "null"
Private Const strTRUE_VALUE As String = "true"
Private Const strFALSE_VALUE As String = "false"
Public Function ParseListOfObjects(ByVal strJson As String) As Collection
' Takes a JSON string that represents a list of objects (where each object has only simple value properties), and
' returns a collection of dictionary objects, where the keys and values of each dictionary represent the names and
' values of the JSON object properties.
Set ParseListOfObjects = New Collection
Dim strList As String: strList = Trim(strJson)
' Check we have a list
If Left(strList, Len(strSTART_OF_LIST)) <> strSTART_OF_LIST _
Or Right(strList, Len(strEND_OF_LIST)) <> strEND_OF_LIST Then
Err.Raise vbObjectError, Description:="The provided JSON does not appear to be a list (it does not start with '" & strSTART_OF_LIST & "' and end with '" & strEND_OF_LIST & "')"
End If
' Get the list item text (between the [ and ])
Dim strBody As String: strBody = Trim(Mid(strList, 1 + Len(strSTART_OF_LIST), Len(strList) - Len(strSTART_OF_LIST) - Len(strEND_OF_LIST)))
If strBody = "" Then
Exit Function
End If
' Check we have a list of objects
If Left(strBody, Len(strSTART_OF_OBJECT)) <> strSTART_OF_OBJECT Then
Err.Raise vbObjectError, Description:="The provided JSON does not appear to be a list of objects (the content of the list does not start with '" & strSTART_OF_OBJECT & "')"
End If
' We now have something like:
' {"property":"value", "property":"value"}, {"property":"value", "property":"value"}, ...
' so we can't just split on a comma to get the various items (because the items themselves have commas in them).
' HOWEVER, since we know we're dealing with very simple JSON that has no nested objects, we can split on "}," because
' that should only appear between items. That'll mean that all but the last item will be missing it's closing brace.
Dim astrItems() As String: astrItems = Split(strBody, strEND_OF_OBJECT & strLIST_DELIMITER)
Dim ixItem As Long
For ixItem = LBound(astrItems) To UBound(astrItems)
Dim strItem As String: strItem = Trim(astrItems(ixItem))
If Left(strItem, Len(strSTART_OF_OBJECT)) <> strSTART_OF_OBJECT Then
Err.Raise vbObjectError, Description:="Mal-formed list item (does not start with '" & strSTART_OF_OBJECT & "')"
End If
' Only the last item will have a closing brace (see comment above)
Dim bIsLastItem As Boolean: bIsLastItem = ixItem = UBound(astrItems)
If bIsLastItem Then
If Right(strItem, Len(strEND_OF_OBJECT)) <> strEND_OF_OBJECT Then
Err.Raise vbObjectError, Description:="Mal-formed list item (does not end with '" & strEND_OF_OBJECT & "')"
End If
End If
Dim strContent: strContent = Mid(strItem, 1 + Len(strSTART_OF_OBJECT), Len(strItem) - Len(strSTART_OF_OBJECT) - IIf(bIsLastItem, Len(strEND_OF_OBJECT), 0))
ParseListOfObjects.Add ParseObjectContent(strContent)
Next ixItem
End Function
Private Function ParseObjectContent(ByVal strContent As String) As Scripting.Dictionary
Set ParseObjectContent = New Scripting.Dictionary
ParseObjectContent.CompareMode = TextCompare
' The object content will look something like:
' "property":"value", "property":"value", ...
' ... although the value may not be in quotes, since numbers are not quoted.
' We can't assume that the property value won't contain a comma, so we can't just split the
' string on the commas, but it's reasonably safe to assume that the value won't contain further quotes
' (and we're already assuming no sub-structure).
' We'll need to scan for commas while taking quoted strings into account.
Dim ixPos As Long: ixPos = 1
Do While ixPos <= Len(strContent)
Dim strRemainder As String
' Find the opening quote for the name (names should always be quoted)
Dim ixOpeningQuote As Long: ixOpeningQuote = InStr(ixPos, strContent, strQUOTE)
If ixOpeningQuote <= 0 Then
' The only valid reason for not finding a quote is if we're at the end (though white space is permitted)
strRemainder = Trim(Mid(strContent, ixPos))
If Len(strRemainder) = 0 Then
Exit Do
End If
Err.Raise vbObjectError, Description:="Mal-formed object (the object name does not start with a quote)"
End If
' Now find the closing quote for the name, which we assume is the very next quote
Dim ixClosingQuote As Long: ixClosingQuote = InStr(ixOpeningQuote + 1, strContent, strQUOTE)
If ixClosingQuote <= 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (the object name does not end with a quote)"
End If
If ixClosingQuote - ixOpeningQuote - Len(strQUOTE) = 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (the object name is blank)"
End If
Dim strName: strName = Mid(strContent, ixOpeningQuote + Len(strQUOTE), ixClosingQuote - ixOpeningQuote - Len(strQUOTE))
' The next thing after the quote should be the colon
Dim ixNameValueSeparator As Long: ixNameValueSeparator = InStr(ixClosingQuote + Len(strQUOTE), strContent, strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR)
If ixNameValueSeparator <= 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (missing '" & strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR & "')"
End If
' Check that there was nothing between the closing quote and the colon
strRemainder = Trim(Mid(strContent, ixClosingQuote + Len(strQUOTE), ixNameValueSeparator - ixClosingQuote - Len(strQUOTE)))
If Len(strRemainder) > 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (unexpected content between name and '" & strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR & "')"
End If
' What comes after the colon is the value, which may or may not be quoted (e.g. numbers are not quoted).
' If the very next thing we see is a quote, then it's a quoted value, and we need to find the matching
' closing quote while ignoring any commas inside the quoted value.
' If the next thing we see is NOT a quote, then it must be an unquoted value, and we can scan directly
' for the next comma.
' Either way, we're looking for a quote or a comma, whichever comes first (or neither, in which case we
' have the last - unquoted - value).
ixOpeningQuote = InStr(ixNameValueSeparator + Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR), strContent, strQUOTE)
Dim ixPropertySeparator As Long: ixPropertySeparator = InStr(ixNameValueSeparator + Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR), strContent, strLIST_DELIMITER)
If ixOpeningQuote > 0 And ixPropertySeparator > 0 Then
' Only use whichever came first
If ixOpeningQuote < ixPropertySeparator Then
ixPropertySeparator = 0
Else
ixOpeningQuote = 0
End If
End If
Dim strValue As String
Dim vValue As Variant
If ixOpeningQuote <= 0 Then ' it's not a quoted value
If ixPropertySeparator <= 0 Then ' there's no next value; this is the last one
strValue = Trim(Mid(strContent, ixNameValueSeparator + Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR)))
ixPos = Len(strContent) + 1
Else ' this is not the last value
strValue = Trim(Mid(strContent, ixNameValueSeparator + Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR), ixPropertySeparator - ixNameValueSeparator - Len(strOBJECT_PROPERTY_NAME_VALUE_SEPARATOR)))
ixPos = ixPropertySeparator + Len(strLIST_DELIMITER)
End If
vValue = ParseUnquotedValue(strValue)
Else ' It is a quoted value
' Find the corresponding closing quote, which should be the very next one
ixClosingQuote = InStr(ixOpeningQuote + Len(strQUOTE), strContent, strQUOTE)
If ixClosingQuote <= 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (the value does not end with a quote)"
End If
strValue = Mid(strContent, ixOpeningQuote + Len(strQUOTE), ixClosingQuote - ixOpeningQuote - Len(strQUOTE))
vValue = ParseQuotedValue(strValue)
' Re-scan for the property separator, in case we hit one that was part of the quoted value
ixPropertySeparator = InStr(ixClosingQuote + Len(strQUOTE), strContent, strLIST_DELIMITER)
If ixPropertySeparator <= 0 Then ' this was the last value
' Check that there's nothing between the closing quote and the end of the text
strRemainder = Trim(Mid(strContent, ixClosingQuote + Len(strQUOTE)))
If Len(strRemainder) > 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (there is content after the last value)"
End If
ixPos = Len(strContent) + 1
Else ' this is not the last value
' Check that there's nothing between the closing quote and the property separator
strRemainder = Trim(Mid(strContent, ixClosingQuote + Len(strQUOTE), ixPropertySeparator - ixClosingQuote - Len(strQUOTE)))
If Len(strRemainder) > 0 Then
Err.Raise vbObjectError, Description:="Mal-formed object (there is content after the last value)"
End If
ixPos = ixPropertySeparator + Len(strLIST_DELIMITER)
End If
End If
ParseObjectContent.Add strName, vValue
Loop
End Function
Private Function ParseUnquotedValue(ByVal strValue As String) As Variant
If StrComp(strValue, strNULL_VALUE, vbTextCompare) = 0 Then
ParseUnquotedValue = Empty
ElseIf StrComp(strValue, strTRUE_VALUE, vbTextCompare) = 0 Then
ParseUnquotedValue = True
ElseIf StrComp(strValue, strFALSE_VALUE, vbTextCompare) = 0 Then
ParseUnquotedValue = False
ElseIf IsNumeric(strValue) Then
ParseUnquotedValue = CDbl(strValue)
Else
Err.Raise vbObjectError, Description:="Mal-formed value (not null, true, false or a number)"
End If
End Function
Private Function ParseQuotedValue(ByVal strValue As String) As Variant
' Both dates and strings are quoted; we'll treat it as a date if it has the expected date format.
' Dates are in the form:
' 2019-09-30T00:00:00
If strValue Like "####-##-##T##:00:00" Then
' NOTE: we just want the date part
ParseQuotedValue = CDate(Left(strValue, Len("####-##-##")))
Else
ParseQuotedValue = strValue
End If
End Function
간단한 테스트:
Const strJSON As String = "[{""property1"":""foo""}]"
Dim oObjects As Collection: Set oObjects = Json.ParseListOfObjects(strJSON)
MsgBox oObjects(1)("property1") ' shows "foo"
다른 Regex 기반 JSON 파서(디코딩 전용)
Option Explicit
Private Enum JsonStep
jstUnexpected
jstString
jstNumber
jstTrue
jstFalse
jstNull
jstOpeningBrace
jstClosingBrace
jstOpeningBracket
jstClosingBracket
jstComma
jstColon
jstWhitespace
End Enum
Private gobjRegExpJsonStep As Object
Private gobjRegExpUnicodeCharacters As Object
Private gobjTokens As Object
Private k As Long
Private Function JsonStepName(ByRef jstStep As JsonStep) As String
Select Case jstStep
Case jstString: JsonStepName = "'STRING'"
Case jstNumber: JsonStepName = "'NUMBER'"
Case jstTrue: JsonStepName = "true"
Case jstFalse: JsonStepName = "false"
Case jstNull: JsonStepName = "null"
Case jstOpeningBrace: JsonStepName = "'{'"
Case jstClosingBrace: JsonStepName = "'}'"
Case jstOpeningBracket: JsonStepName = "'['"
Case jstClosingBracket: JsonStepName = "']'"
Case jstComma: JsonStepName = "','"
Case jstColon: JsonStepName = "':'"
Case jstWhitespace: JsonStepName = "'WHITESPACE'"
Case Else: JsonStepName = "'UNEXPECTED'"
End Select
End Function
Private Function Unescape(ByVal strText As String) As String
Dim objMatches As Object
Dim i As Long
strText = Replace$(strText, "\""", """")
strText = Replace$(strText, "\\", "\")
strText = Replace$(strText, "\/", "/")
strText = Replace$(strText, "\b", vbBack)
strText = Replace$(strText, "\f", vbFormFeed)
strText = Replace$(strText, "\n", vbCrLf)
strText = Replace$(strText, "\r", vbCr)
strText = Replace$(strText, "\t", vbTab)
If gobjRegExpUnicodeCharacters Is Nothing Then
Set gobjRegExpUnicodeCharacters = CreateObject("VBScript.RegExp")
With gobjRegExpUnicodeCharacters
.Global = True
.Pattern = "\\u([0-9a-fA-F]{4})"
End With
End If
Set objMatches = gobjRegExpUnicodeCharacters.Execute(strText)
For i = 0 To objMatches.Count - 1
With objMatches(i)
strText = Replace$(strText, .Value, ChrW$(Val("&H" + .SubMatches(0))), , 1)
End With
Next i
Unescape = strText
End Function
Private Sub Tokenize(ByRef strText As String)
If gobjRegExpJsonStep Is Nothing Then
Set gobjRegExpJsonStep = CreateObject("VBScript.RegExp")
With gobjRegExpJsonStep
.Pattern = "(""((?:[^\\""]+|\\[""\\/bfnrt]|\\u[0-9a-fA-F]{4})*)""|" & _
"(-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][-+]?\d+)?)|" & _
"(true)|" & _
"(false)|" & _
"(null)|" & _
"(\{)|" & _
"(\})|" & _
"(\[)|" & _
"(\])|" & _
"(\,)|" & _
"(:)|" & _
"(\s+)|" & _
"(.+?))"
.Global = True
End With
End If
Set gobjTokens = gobjRegExpJsonStep.Execute(strText)
End Sub
Private Function ErrorMessage(ByRef vntExpecting As Variant) As String
Dim lngLB As Long
Dim lngUB As Long
Dim i As Long
Dim jstJsonStep As JsonStep
Dim strResult As String
If Rank(vntExpecting) = 1 Then
lngLB = LBound(vntExpecting)
lngUB = UBound(vntExpecting)
If lngLB <= lngUB Then
strResult = "Expecting "
For i = lngLB To lngUB
jstJsonStep = vntExpecting(i)
If i > lngLB Then
If i < lngUB Then
strResult = strResult & ", "
Else
strResult = strResult & " or "
End If
End If
strResult = strResult & JsonStepName(jstJsonStep)
Next i
End If
End If
If strResult = "" Then
strResult = "Unexpected error"
End If
If gobjTokens.Count > 0 Then
If k < gobjTokens.Count Then
strResult = strResult & " at position " & (gobjTokens(k).FirstIndex + 1) & "."
Else
strResult = strResult & " at EOF."
End If
Else
strResult = strResult & " at position 1."
End If
ErrorMessage = strResult
End Function
Private Function ParseStep(ByRef vntValue As Variant) As JsonStep
Dim i As Long
k = k + 1
If k >= gobjTokens.Count Then
vntValue = Empty
Exit Function
End If
With gobjTokens(k)
For i = 1 To 12
If Not IsEmpty(.SubMatches(i)) Then
ParseStep = i
Exit For
End If
Next i
Select Case ParseStep
Case jstString
vntValue = Unescape(.SubMatches(1))
Case jstNumber
vntValue = Val(.SubMatches(2))
Case jstTrue
vntValue = True
Case jstFalse
vntValue = False
Case jstNull
vntValue = Null
Case jstWhitespace
ParseStep = ParseStep(vntValue)
Case Else
vntValue = Empty
End Select
End With
End Function
Private Function ParseObject(ByRef vntObject As Variant) As Boolean
Dim strKey As String
Dim vntValue As Variant
Dim objResult As Object
Set objResult = CreateObject("Scripting.Dictionary")
Do
Select Case ParseStep(strKey)
Case jstString
If Not ParseStep(Empty) = jstColon Then
LogError "ParseObject", ErrorMessage(Array(jstColon))
Exit Function
End If
Select Case ParseStep(vntValue)
Case jstString, jstNumber, jstTrue, jstFalse, jstNull
objResult.Item(strKey) = vntValue
Case jstOpeningBrace
If ParseObject(vntValue) Then
Set objResult.Item(strKey) = vntValue
End If
Case jstOpeningBracket
If ParseArray(vntValue) Then
Set objResult.Item(strKey) = vntValue
End If
Case Else
LogError "ParseObject", ErrorMessage(Array(jstString, jstNumber, jstTrue, jstFalse, jstNull, jstOpeningBrace, jstOpeningBracket))
Exit Function
End Select
Select Case ParseStep(Empty)
Case jstComma
'Do nothing
Case jstClosingBrace
Set vntObject = objResult
ParseObject = True
Exit Function
Case Else
LogError "ParseObject", ErrorMessage(Array(jstComma, jstClosingBrace))
Exit Function
End Select
Case jstClosingBrace
Set vntObject = objResult
ParseObject = True
Exit Function
Case Else
LogError "ParseObject", ErrorMessage(Array(jstString, jstClosingBrace))
Exit Function
End Select
Loop While True
End Function
Private Function ParseArray(ByRef vntArray As Variant) As Boolean
Dim vntValue As Variant
Dim colResult As Collection
Set colResult = New Collection
Do
Select Case ParseStep(vntValue)
Case jstString, jstNumber, jstTrue, jstFalse, jstNull
colResult.Add vntValue
Case jstOpeningBrace
If ParseObject(vntArray) Then
colResult.Add vntArray
End If
Case jstOpeningBracket
If ParseArray(vntArray) Then
colResult.Add vntArray
End If
Case jstClosingBracket
Set vntArray = colResult
ParseArray = True
Exit Function
Case Else
LogError "ParseArray", ErrorMessage(Array(jstString, jstNumber, jstTrue, jstFalse, jstNull, jstOpeningBrace, jstOpeningBracket, jstClosingBracket))
Exit Function
End Select
Select Case ParseStep(Empty)
Case jstComma
'Do nothing
Case jstClosingBracket
Set vntArray = colResult
ParseArray = True
Exit Function
Case Else
LogError "ParseArray", ErrorMessage(Array(jstComma, jstClosingBracket))
Exit Function
End Select
Loop While True
End Function
Public Function ParseJson(ByRef strText As String, _
ByRef objJson As Object) As Boolean
Tokenize strText
k = -1
Select Case ParseStep(Empty)
Case jstOpeningBrace
ParseJson = ParseObject(objJson)
Case jstOpeningBracket
ParseJson = ParseArray(objJson)
Case Else
LogError "ParseJson", ErrorMessage(Array(jstOpeningBrace, jstOpeningBracket))
End Select
End Function
언급URL : https://stackoverflow.com/questions/6627652/parsing-json-in-excel-vba
'source' 카테고리의 다른 글
| wordpress 또는 asp.net mvc에서 acme-module을 암호화합니다. (0) | 2023.03.01 |
|---|---|
| TypeScript의 'window'에서 새 속성을 명시적으로 설정하려면 어떻게 해야 합니까? (0) | 2023.03.01 |
| 도커 워드프레스 초저속 (0) | 2023.03.01 |
| 열 크기를 수정하는 방법 (0) | 2023.03.01 |
| Wordpress 하위 카테고리에 카테고리 템플릿 사용 (0) | 2023.03.01 |