Symfoware

Symfowareについての考察blog

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":"日本語あいうえお2"},
]



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





実行してみると、ちゃんとメッセージボックスに取得したデータが表示されます。

06_001_20100917172045.png

文字化けするかと思ったのですが(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を取得してみる
    '「日本語あいうえお2」が取得できるはず
    JSONDecode = sc.CodeObject.getValue(1, "name")
    
End Function




実行してみると、ちゃんと狙い通りの文字列が表示されました。

06_002_20100917172045.png



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





実行してみると・・・

06_003_20100917172045.png

06_004_20100917172045.png

狙い通りの動作になってくれました。






【参考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










関連記事

テーマ:プログラミング - ジャンル:コンピュータ

  1. 2010/09/17(金) 17:21:52|
  2. 備忘録
  3. | トラックバック:1
  4. | コメント:0
  5. | 編集
<<Pythonフレームワーク「Tornado」を使用し、JSON形式のデータを公開する | ホーム | Redis Command - SRANDMEMBER(指定したキーのセットからランダムに値を取得)>>

コメント

コメントの投稿


管理者にだけ表示を許可する

トラックバック

トラックバック URL
https://symfoware.blog.fc2.com/tb.php/579-ccfdcd05
この記事にトラックバックする(FC2ブログユーザー)

[Excel][VBA][Redmine]Excel から Redmine の情報を取得する方法

Excel マクロ(VBA)で Redmine の情報を取得して、表にまとめる方法を考えてみました。 よくあるかもしれない質問 Q. なんで Excel でやろうと思った? A. そこに Excel があったから。 手っ取り早
  1. 2013/04/21(日) 20:29:40 |
  2. 地平線に行く