消えると困るのでコピペ
■ボタンクリック部分のコード
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
ネタ元
