ExcelVBAでJScript経由でJSONをデコード

excelvba

消えると困るのでコピペ

■ボタンクリック部分のコード

Private Sub CommandButton1_Click()
    
    Dim obj As JSON
    Set obj = GetJSON("test.json")
    
    Do While obj.HasNext
        MsgBox obj.getValue("id") & ":" & obj.getValue("name")
    Loop
    
End Sub


■ConnectModule

'接続するURLのベース部分を指定
Private Const TARGET_URL As String = "http://www.example.com/"

Public Function CreateHttpObject() As Object
    Dim objweb As Object
    
    '各種名称でHTTPオブジェクトの生成を試みる
    Err.Clear
    Set objweb = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    If Err.Number = 0 Then
        Set CreateHttpObject = objweb
        Exit Function
    End If
    
    
    Err.Clear
    Set objweb = CreateObject("MSXML2.ServerXMLHTTP")
    If Err.Number = 0 Then
        Set CreateHttpObject = objweb
        Exit Function
    End If
    
    
    Err.Clear
    Set objweb = CreateObject("MSXML2.XMLHTTP")
    If Err.Number = 0 Then
        Set CreateHttpObject = objweb
        Exit Function
    End If
    
    Set CreateHttpObject = Nothing

End Function

Public Function GetData(ByVal url As String) As String
    Dim objweb As Object
    
    'XMLHTTPオブジェクトを生成
    Set objweb = CreateHttpObject()
    
    'オブジェクトの生成に失敗していれば処理終了
    If objweb Is Nothing Then
        GetData = ""
        Exit Function
    End If
    
    objweb.Open "GET", TARGET_URL & url, False
    objweb.Send
    
    GetData = objweb.responseText
    
End Function

Public Function GetJSON(ByVal url As String) As JSON
    Dim data As String
    Dim obj As JSON
    
    data = GetData(url)
    
    If data = "" Then
        Set GetJSON = Nothing
        Exit Function
    End If
    
    Set obj = New JSON
    Call obj.Parse(data)
    
    Set GetJSON = obj
End Function

■JSON

Private sc As Object
Private current_id As Long
Private max_id As Long

'コンストラクタ
Public Sub Class_Initialize()

    'コンストラクタで、JScriptオブジェクトを生成
    Set sc = CreateObject("ScriptControl")
    With sc
        .Language = "JScript"
        
        '指定したインデックス、名称のデータを取得する
        .AddCode "function getValue(index, name) { return ary[index][name];}"
        
        '配列数取得用
        .AddCode "function getLength() { return ary.length;}"
    End With
    
    current_id = -1
    max_id = 0
End Sub

'JSON形式のデータを解析する
Public Sub Parse(ByRef data As String)
    'aryというオブジェクトに取得したJSON形式のデータを展開
    sc.AddCode "var ary = " & data & ";"
    
    '配列数を確定
    max_id = sc.CodeObject.getLength("")
    
End Sub


Public Function HasNext() As Boolean
    current_id = current_id + 1
    HasNext = (current_id < max_id)
End Function


Public Function getValueAt(ByVal index As Long, ByVal id As String) As String
    getValueAt = sc.CodeObject.getValue(index, id)
End Function


Public Function getValue(ByVal id As String) As String
    getValue = getValueAt(current_id, id)
End Function

'デストラクタ
Public Sub Class_Terminate()
End Sub

ネタ元


※追記64bitExcelだとScriptControlが使えない。HtmlDocumentを使って無理矢理やるべし

例：

    'JSONDecode
    Dim d As Object
    Dim elm As Object

    Set d = CreateObject("htmlfile")
    Set elm = d.createElement("span")
    elm.setAttribute "id", "result"
    d.appendChild elm

    Dim code As String
    code = code + "var ary = " & json & ";"
    code = code + "function getValue(index, name) { return ary[index][name];}"
    code = code + "document.getElementById('result').innerText = getValue(""index"",""name"");"
    d.parentWindow.execScript code, "JScript"
    Dim data
    data = elm.innerText


ネタ元