如何直接在VBA中從json數據中獲取子元素的值

Question

我已經看到了可以使用JSON數據在Excel /宏中打印行的方式。那答案就在這裏 - >How to convert JSON data to xml data in excel macro or VB.Net

但是還有另外一個問題，我怎樣才能得到子元素人們從JSON數據的值，這樣我可以從它那裏得到的數據進行進一步的使用價值。

的數據我得到像：

{"properties":{"SuccessCount":1,"PendingCount":0},"People":[{"memberId":"3","memberAge":2,"memberCount":1,"memberName":"Alex"},{"memberId":"4","memberAge":5,"memberCount":1,"memberName":"Peter"},{"memberId":"5","memberAge":2,"memberCount":1,"memberName":"Kirby"}],"TotalMembers":3} 

Answer 1

這將這樣的伎倆：

Public Sub JsonTable2Range(rOut As Range, json As String) 
    Dim i&, j&, p1&, p2&, sRow$, cols, v, vp 

    p1 = InStr(json, "[") 
    p2 = InStr(json, "]") 
    If p1 And p2 Then 
     json = Mid$(json, p1, p2 - p1 + 1) 
    End If 

    i = 1 
    p1 = 1 
    Do 
     p1 = InStr(p1, json, "{"): If p1 = 0 Then Exit Do 
     p2 = InStr(p1, json, "}") 
     sRow = Mid$(json, p1 + 1, p2 - p1 - 1) 
     cols = Split(sRow, ",") 
     If i = 1 Then 
      ReDim v(0 To UBound(Split(json, "}")) + 1, 0 To UBound(cols) + 1) 
      For j = 0 To UBound(cols) 
       vp = Split(cols(j), ":") 
       v(0, j) = ProcessValuePair(vp, 0) 
      Next 
     End If 
     For j = 0 To UBound(cols) 
      vp = Split(cols(j), ":") 
      v(i, j) = ProcessValuePair(vp, 1) 
     Next 
     i = i + 1 
     p1 = p1 + 1 
    DoEvents 
    Loop 
    If i > 1 Then rOut.Resize(UBound(v), UBound(v, 2)) = v 
End Sub 

Private Function ProcessValuePair(vp, n) 
    If Asc(Mid$(vp(n), 1, 1)) = 10 Then vp(n) = Mid$(vp(n), 2) 
    vp(n) = Trim$(vp(n)) 
    If Left$(vp(n), 1) = "'" Or Left$(vp(n), 1) = """" Or Left$(vp(n), 1) = "\" Then 
     vp(n) = Mid$(vp(n), 2, Len(vp(n)) - 2) 
     If Left$(vp(n), 1) = """" And Right$(vp(n), 1) = "\" Then 
      vp(n) = Mid$(vp(n), 2, Len(vp(n)) - 2) 
     End If 
    Else 
     vp(n) = Val(vp(n)) 
    End If 
    ProcessValuePair = vp(n) 
End Function 

Answer 2

考慮這個例子：

Option Explicit 

Sub JsonPopulateCellsTest() 
    Dim strJsonString As String 
    Dim varJson As Variant 
    Dim strState As String 
    Dim varPeople() As Variant 
    Dim i As Long 
    Dim y As Long 

    ' parse JSON string 
    strJsonString = "{""properties"":{""SuccessCount"":1,""PendingCount"":0},""People"":[{""memberId"":""3"",""memberAge"":2,""memberCount"":1,""memberName"":""Alex""},{""memberId"":""4"",""memberAge"":5,""memberCount"":1,""memberName"":""Peter""},{""memberId"":""5"",""memberAge"":2,""memberCount"":1,""memberName"":""Kirby""}],""TotalMembers"":3}" 
    ParseJson strJsonString, varJson, strState 
    If strState = "Error" Then 
     MsgBox "Error" 
     Exit Sub 
    End If 

    ' show the full structure starting from root element 
    MsgBox BeautifyJson(varJson) 

    ' retrieve People array 
    varPeople = varJson("People") 

    ' show the structure of People array 
    MsgBox BeautifyJson(varPeople) 


    y = 1 ' begin row 

    ' output 
    For i = 0 To UBound(varPeople) 
     Cells(y + i, 1).Value = varPeople(i)("memberId") 
     Cells(y + i, 2).Value = varPeople(i)("memberAge") 
     Cells(y + i, 3).Value = varPeople(i)("memberCount") 
     Cells(y + i, 4).Value = varPeople(i)("memberName") 
    Next 

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 lngTokenId As Long 
    Dim objRegEx As Object 
    Dim bMatched As Boolean 

    Set objTokens = CreateObject("Scripting.Dictionary") 
    lngTokenId = 0 
    Set objRegEx = CreateObject("VBScript.RegExp") 
    With objRegEx 
     ' specification http://www.json.org/ 
     .Global = True 
     .MultiLine = True 
     .IgnoreCase = True 
     .Pattern = """(?:\\""|[^""])*""(?=\s*(?:,|\:|\]|\}))" 
     Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "str" 
     .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)e(?:[+-])?\d+(?=\s*(?:,|\]|\}))" 
     Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "num" 
     .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)(?=\s*(?:,|\]|\}))" 
     Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "num" 
     .Pattern = "\b(?:true|false|null)(?=\s*(?:,|\]|\}))" 
     Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "cst" 
     .Pattern = "\b[A-Za-z_]\w*(?=\s*\:)" ' unspecified name without quotes 
     Tokenize objTokens, objRegEx, strContent, lngTokenId, 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, lngTokenId, bMatched, "prp" 
      .Pattern = "\{(?:<\d+prp>(?:,<\d+prp>)*)?\}" 
      Tokenize objTokens, objRegEx, strContent, lngTokenId, bMatched, "obj" 
      .Pattern = "\[(?:<\d+(?:str|num|obj|arr|cst)>(?:,<\d+(?:str|num|obj|arr|cst)>)*)?\]" 
      Tokenize objTokens, objRegEx, strContent, lngTokenId, 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, lngTokenId, 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 = "<" & lngTokenId & strType & ">" 
      bMatched = True 
      With objMatch 
       objTokens(strKey) = .Value 
       strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey 
       lngCopyIndex = .FirstIndex + .Length + 1 
      End With 
      lngTokenId = lngTokenId + 1 
     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