Excel VBA에서 JSON 구문 분석

code

Excel VBA에서 JSON 구문 분석

codestyles 2020. 11. 12. 08:14

Excel VBA에서 JSON 구문 분석

Excel VBA : Parsed JSON Object Loop 와 동일한 문제가 있지만 솔루션을 찾을 수 없습니다. 내 JSON에는 중첩 개체가 있으므로 VBJSON 및 vba-json과 같은 제안 된 솔루션이 작동하지 않습니다. 나는 또한 그들 중 하나가 제대로 작동하도록 수정했지만 결과는 doProcess 함수의 많은 재귀로 인해 호출 스택 오버플로였습니다.

가장 좋은 해결책은 원본 게시물에서 볼 수있는 jsonDecode 함수로 보입니다. 매우 빠르고 효과적입니다. 내 개체 구조는 JScriptTypeInfo 형식의 일반 VBA 개체에 모두 있습니다.

이 시점에서 문제는 객체의 구조를 결정할 수 없기 때문에 각 일반 객체에 상주 할 키를 미리 알지 못한다는 것입니다. 키 / 속성을 얻기 위해 일반 VBA 개체를 반복해야합니다.

내 구문 분석 자바 스크립트 함수가 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인스턴스가 자바 스크립트 객체를 참조, For Each ... Next작동하지 않습니다. 그러나 Javascript 배열을 참조하면 작동합니다 ( GetKeys함수 참조 ).
이름이 런타임에만 알려진 액세스 속성은 GetProperty및 함수를 사용합니다 GetObjectProperty.
자바 스크립트 배열이 속성 제공 length, 0, Item 0, 1, Item 1VBA를 점 표기법 (로 등 jsonObject.property), 단지 길이 속성을 사용하면라는 변수 선언 할 경우에만 액세스 할 수 있으며 length모든 소문자 문자로합니다. 그렇지 않으면 케이스가 일치하지 않고 찾을 수 없습니다. 다른 속성은 VBA에서 유효하지 않습니다. 따라서 GetProperty기능을 더 잘 사용하십시오 .
코드는 초기 바인딩을 사용합니다. 따라서 "Microsoft Script Control 1.0"에 대한 참조를 추가해야합니다.
InitScriptEngine기본 초기화를 수행하려면 다른 함수를 사용하기 전에 한 번 호출해야합니다 .

업데이트 3 ('17 년 9 월 24 일)

최신 버전 및 예제는 GitHub의 VBA-JSON-parser를 확인하십시오 . JSON 처리를 위해 JSON.bas 모듈을 VBA 프로젝트로 가져 옵니다 .

업데이트 2 ('16 년 10 월 1 일)

당신이 64 비트 오피스 JSON을 구문 분석하고 싶어하지만 경우에 ScriptControl, 다음 이 대답은 당신이 얻을하는 데 도움이 될 수 있습니다 ScriptControl64 비트에 대한 작업에.

업데이트 ('15 년 10 월 26 일)

• 그래도 참고 ScriptControl가 액티브 X의를 통해 악성 JS 코드에 대한 드라이브 (및 기타 물건)에 직접 액세스 할 수 있기 때문에 기반 approachs은, 어떤 경우에는 취약한 시스템을 만든다. .NET과 같은 웹 서버 응답 JSON을 구문 분석한다고 가정 해 보겠습니다 JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}". 평가 후 새로 생성 된 파일을 찾을 수 있습니다 C:\Test.txt. 따라서 ScriptControlActiveX를 사용한 JSON 구문 분석 은 좋은 생각이 아닙니다.

이를 피하기 위해 RegEx를 기반으로 JSON 파서를 만들었습니다. 객체는 {}사전의 속성과 메서드를 사용할 수있게하는, 사전으로 표현된다 : .Count, .Exists(), .Item(), .Items, .Keys. 배열 []은 기존의 0 기반 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에서 작동한다는 것입니다.

초기 ('15 년 5 월 27 일)

다음은 ScriptControl외부 라이브러리없이 ActiveX를 기반으로 VBA에서 JSON을 구문 분석하는 또 다른 방법입니다 .

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

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

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

이것은 Excel 및 네이티브 형식으로 번역 된 JSON 쿼리를 사용하는 큰 JSON 파일에서 저에게 적합합니다. https://github.com/VBA-tools/VBA-JSON "item.something"과 같은 노드를 구문 분석하고 간단한 명령을 사용하여 값을 가져올 수 있습니다.

MsgBox Json("item")("something")

좋은게 뭐야.

코도 감사합니다.

방금 업데이트하고 완료 한 작업 :

json 직렬화 (텍스트와 같은 문서에 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

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 파서 (디코딩 전용)

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

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

참고 URL : https://stackoverflow.com/questions/6627652/parsing-json-in-excel-vba

'code' 카테고리의 다른 글

null 대신 EventArgs.Empty를 사용하는 이유는 무엇입니까? (0)	2020.11.12
EventTrigger로 속성 설정 (0)	2020.11.12
HTTP 헤더의 Set-Cookie는 AngularJS에서 무시됩니다. (0)	2020.11.12
YouTube의 오류 500 페이지 디코딩 (0)	2020.11.12
무한 스크롤 또는 많은 dom 요소로 성능? (0)	2020.11.11

현재글Excel VBA에서 JSON 구문 분석

codestyle

Excel VBA에서 JSON 구문 분석

Excel VBA에서 JSON 구문 분석

'code' 카테고리의 다른 글

'code'의 다른글

티스토리툴바

Excel VBA에서 JSON 구문 분석

Excel VBA에서 JSON 구문 분석

'code' 카테고리의 다른 글

'code'의 다른글

관련글

티스토리툴바