ExcelのVBAでJSON形式のデータを解析する
WebサーバーからJSON形式のデータを取得し、セルに表示してみようと思います。・・・というのも、Webアプリのマスタ系のデータ保守を行うにあたり、
いちいち管理画面を作るのが面倒なので、サーバー側でマスタデータを
JSON形式で参照できるようにしておき、Excelで表示。
最終的には、編集後のデータをPOSTしてデータ更新を行うようにしたいです。
Excelマクロでhttp通信
Webサーバーに通信して、JSON形式のデータを取得したいので、
http通信が出来ないとお話になりません。
データ取得用のサンプルを作るにあたり、Webサーバーに「test.json」という
ファイルを作成しました。
test.jsonの内容は以下の通り。
[
{"id":1,"name":"日本語あいうえお"},
{"id":2,"name":"日本語あいうえお２"},
]
idとnameという属性を持つ簡単な内容です。
これをたとえば、
http://www.example.com/test.json
というようなURLで閲覧できるようにしておきました。
マクロでhttp通信を行うに当たり、MSXML2.XMLHTTPオブジェクトを作成して
それに通信を行わせることにしました。
※Ajaxと同じ発想です。
文末の【参考URL】に記載させていただいたサイトを参考に実装したところ、
こんなスクリプトになりました。
■ボタンクリックの処理
Private Sub CommandButton1_Click()
MsgBox (ConnectModule.GetData("test.json"))
End Sub
■ConnectModuleのソース
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
実行してみると、ちゃんとメッセージボックスに取得したデータが表示されます。
文字化けするかと思ったのですが(test.jsonはutf-8で保存)、上手くいってくれました。
ExcelマクロでJSONのデコード
Webサーバーに通信してJSON形式のデータを取得できたので、デコードして
プログラムから使用できるようにします。
これがベストなやり方ではないと思いますが、今回は「JScript」を使用して
デコードしてみることにしました。
VBAでJScriptのArrayオブジェクトのメソッドを使ってみる
http://pub.ne.jp/arihagne/?entry_id=2139805
こちらが非常に参考になりました。
プログラムをちょっと修正してみます。
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 = JSONDecode(objweb.responseText)
End Function
Private Function JSONDecode(ByVal data As String) As String
Set sc = CreateObject("ScriptControl")
With sc
.Language = "JScript"
'指定したインデックス、名称のデータを取得する
.AddCode "function getValue(index, name) { return ary[index][name];}"
'aryというオブジェクトに取得したJSON形式のデータを展開
.AddCode "var ary = " & data & ";"
End With
'サンプルとして、1番目のnameを取得してみる
'「日本語あいうえお２」が取得できるはず
JSONDecode = sc.CodeObject.getValue(1, "name")
End Function
実行してみると、ちゃんと狙い通りの文字列が表示されました。
ScriptControlオブジェクトの中に展開し、そこから値を引っ張り出すことで
データの取得を実現してみました。
これでは若干使いにくいので、JSONDecodeの部分をクラスにまとめてみたいと思います。
クラスファイル化
最終的なコードはこんな感じになりました。
■ボタンクリック部分のコード
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
実行してみると・・・
狙い通りの動作になってくれました。
【参考URL】
Web ページをダウンロードする方法～ MSXML 編～
http://www.f3.dion.ne.jp/~element/msaccess/AcTipsVbaXMLHTTP.html
ホームページデータを取得する／サイトが有効か確認する
http://www.kanaya440.com/contents/tips/vbs/007.html
気象情報の取得と記録――VBScriptでExcelを操作する
http://itpro.nikkeibp.co.jp/article/COLUMN/20060706/242691/
VBScriptでWebからファイルダウンロード
http://www.sio.no-ip.com/mt/shio/archives/2008/04/vbscriptweb.html
MSXML2.XMLHTTPでvbaからweb apiを利用
http://d.hatena.ne.jp/end0tknr/20081115/1226755041
MSXML2.XMLHTTPでファイルをPOSTする
http://webcraft.seesaa.net/article/122661267.html
VBScript で JavaScript っぽい Array を使う
http://d.hatena.ne.jp/kenkitii/20091208/p1
VBAでJScriptのArrayオブジェクトのメソッドを使ってみる
http://pub.ne.jp/arihagne/?entry_id=2139805
コメント