【VBA】VBAでjsonをパースする

前書き

せっかくVBAでHTTP通信が出来るんだから未だに流行のjsonでもパースしてみましょう。

とりあえず一つだけ言えることは、やめとけってことです。jsonを扱うなら素直に別の言語を使うか別のデータ形式を使った方が絶対にいいです。本当に死ぬほど面倒です。

記事を読む前に

頑張ってパースする方法を書いたんですが、~~Google謹製の~~vba-jsonを使うのが一番簡単ですし、安全です。

（2014/11/19追記：よく見たらGoogle謹製とはどこにも書かれていませんでしたね…。テスト用のjsonを見る限り日本人作なんでしょうか？何者なんでしょう…。）

と言うのも、これから説明する方法は64bit版のOfficeでは動かないからです。（互換モードなら動くらしいけど。）理由を説明してもいいんですが、「ScriptControl 64bit」で検索すれば山ほど出てくるので割愛します。

ちなみにvba-jsonの方は受け取った文字列を気合で解析しているだけなので64bit版でも余裕で動きます。

そんなわけで、これから紹介する方法は

オープンソースのライブラリなんて言語道断であると嘯く~~邪悪な~~人間にvba-jsonを否定されてしまった
実行環境は32bit版（or 64bit版の互換モード）であることが確定している

の二条件が揃ったときに試してみてください。

JScriptTypeInfoをつくる

「Excel vba json」で検索すると大体この方法です。まぁ、確かにこの段階までは楽なのでベストな選択だと思います。

発想としては「jsonなんだからjavascriptにパースさせてオブジェクトだけ貰えばいいのでは？」と言うものです。VBAからjavascriptを呼ぶためにScriptControlを使用します。

Dim js As Object
Dim json As Object

Set js = CreateObject("ScriptControl")
js.Language = "JScript"
js.AddCode "function jsonParse(str) { return eval('(' + str + ')'); };"

Set json = js.codeobject.jsonParse(str)

これだけです。さっぱりしてますね。

JScriptTypeInfoの中身を見てみる

例がないとわかりにくいので、たまたまメモしてあったaclogのjsonを例にしましょう。丁度GETだし、認証もいらないしね。

まずは/api/users/stats.jsonあたりを例にしてみますか。

{
    "favorited_count": 1214, 
    "id": 213809304, 
    "retweeted_count": 493
}

さて、先ほど受け取ったオブジェクト（function jsonParseの戻り値）の型は「Object/JScriptTypeInfo」となります。

これを適当にウォッチ式に放り込んでみるとこんなツリーになるはずです。

json　　　　　　　　：Object/JScriptTypeInfo
├favorited_count　 ：Variant/Long
├id　　　　　　　　：Variant/Long
└retweeted_count　 ：Variant/Long

JScriptTypeInfo配下にjsonのキーのメンバ（プロパティ）がいる状態です。つまり、これらの値を取得していくことになります。

jsonから値を取得する

さて、値を取得する方法ですが、プロパティなので.（ドット）で呼べば値を取得できます。

Dim favoritedCount As Long
favoritedCount = json.favorited_count

で、この説明を信じて殊勝にも試してみた人は気づくと思います。こんなエラーが出てjson.idが取得できないと。

実行時エラー ‘438’:

オブジェクトは、このプロパティまたはメソッドをサポートしていません。

理由は簡単で、VBAの予約語がキーとなっている場合、この方法では取得できないからです。

それじゃあ意味ないじゃんと思うかもしれませんが、他の方法があります。

「ScriptControlでkeyを引数にjsonからvalueを返すjavascriptを作る」か、「CallByName関数を使う」かのどちらかです。

前者はどんなコードかパッと思いつくと思うので、今回は後者の方法にしましょう。

Dim id As Long
id = CallByName(json, "id", VbGet)

これだけです。わざわざjavascript作るより圧倒的に楽なのと、CallByName関数の存在を知っていると色々なことに応用できるので、こっちをオススメします。

「なんかリフレクションみたいでキモい」と思うのであればこんな関数でも作っておきましょう。jsonをパースするだけなら定数はVbGetしか使いません。

Public Function GetJsonValue(json As Object, key As String) As Variant
    GetJsonValue = CallByName(json, key, VbGet)
End Function

jsonの配列を処理する

こっからが面倒くさい。とは言え、jsonを扱う上で配列を処理できないと意味ないので頑張りましょう。

/api/users/stats.jsonには配列がないので/api/tweets/timeline.jsonにしましょう。

[
    {
        "favoriters": [
            77621446, 
            316010376
        ], 
        "favorites_count": 2, 
        "id": 383324767391981569, 
        "retweeters": [], 
        "retweets_count": 0, 
        "user_id": 213809304
    }, 
    {
        "favoriters": [
            290525151, 
            77621446, 
            316010376
        ], 
        "favorites_count": 3, 
        "id": 383324217116086272, 
        "retweeters": [], 
        "retweets_count": 0, 
        "user_id": 213809304
    }, 
    {
        "favoriters": [
            1127724600
        ], 
        "favorites_count": 1, 
        "id": 383320595124862976, 
        "retweeters": [], 
        "retweets_count": 0, 
        "user_id": 213809304
    }
]

さっきと同じ方法で取得して再度ウォッチ式に放り込みます。

json　　　　　　　　：Object/JScriptTypeInfo
├0　　　　　　　　 ：Variant/Object/JScriptTypeInfo
│├favoriters　　　：Variant/Object/JScriptTypeInfo
││├0　　　　　　 ：Variant/Long
││├1　　　　　　 ：Variant/Long
││├2　　　　　　 ：Variant/Long
││└…　　　　　　：Variant/Long
│├favorites_count ：Variant/Long
│├id　　　　　　  ：Variant/Double
│└…
├1
│├favoriters
││├0
││├1
││├2
││└…
│├favorites_count
│├id
│└…
└…

大体こんな感じになっています。下のほうに「Item 1」みたいなプロパティもあると思いますが、数字の0と全く同じオブジェクトが入っています。

さて、値の取得の方法ですが、For Eachでぐるぐる回してCallByName関数になります。

Dim v As Variant

For Each v In json
    Debug.Print CallByName(v, "id", VbGet)
Next

VariantではなくObjectで取得しても結果は同じです。
また、配列から一要素を取得する場合もCallByNameを使います。これはObjectで受け取らないと怒られます。

Dim o As Object

Set o = CallByName(json, 0, VbGet)
Debug.Print CallByName(o, "id", VbGet)

上記の例では数値で取得しましたが、文字列でも取得できます。

'文字列で数字はOK
Set o = CallByName(json, "0", VbGet)

ただし、「Item 1」のような形で取得することは出来ません。

'できない
Set o = CallByName(json, "Item 1", VbGet)

また、配列だからと言ってかっこで受け取ることもできません。

'VBAの配列じゃないのでサポートしてないっぽい
Set o = json(0)

おとなしくCallByNameで取得するのが一番いいと思います。また、配列でないjsonのキーと区別するために数値型で取得するのが可読性的にもいいんじゃないでしょうか。配列の値を取るだけのFunctionでラップしてもいいかもしれませんが、冗長すぎるような気がします。

ちなみに、先ほど例としてあげた「Public Function GetJsonValue」ではできません。戻り値がVariantだからです。ちゃんと戻り値をObjectにしてあげましょう。

Public Function GetJsonArrayValue(json As Object, index As Integer) As Object
    Set GetJsonArray = CallByName(json, index, VbGet)
End Function

jsonのキー一覧を取得する

CallByNameもリフレクションっぽいと言えばリフレクションっぽいんですが、流石にVBAで「あるオブジェクトのPublicなプロパティ一覧を取得する」みたいなことをやるのは相当厳しいです。（全く不可能と言うわけではないけど、現実的じゃない。）

と言うわけで、ここは素直にjavascriptの力を借りましょう。

Dim js As Object
Dim keys As Object

Set js = CreateObject("ScriptControl")
js.Language = "JScript"
js.AddCode "function getKeys(h) { var keys=[]; for(var k in h){keys.push(k);} return keys; };"

Set keys = js.codeobject.getKeys(json)

後はFor EachなりCallByNameなりを使ってCollectionあたりに入れておけば大分使いやすくなります。

ただし、あくまで一階層分しか取れないので、/api/tweets/timeline.jsonの例で言えば「0,1,2…」みたいなキーしか取得できません。一旦第一階層のjsonをFor Eachで回しつつ、第二階層のJScriptTypeInfoをgetKeysに投げれば「favoriters,favorites_count,id…」のようなキーをもらえます。

その辺はなんかもう上手いことやってください。（丸投げ）

jsonが配列かどうかを判断する

VBAにはIsArray関数が既にありますが、当然これでは判断できません。型名から判断しようにも全部JScriptTypeInfoになってしまってわからないので、ここもjavascriptにお任せしましょう。

Dim js As Object

Set js = CreateObject("ScriptControl")
js.Language = "JScript"
js.AddCode "function isArray(o) { return o instanceof Array; };"

If CallByName(js.codeobject, "isArray", VbMethod, json) Then
    'Array
Else
    'Not Array
End if

今回のメソッドはCallByNameを経由して呼んでます。何故か。さっきも言った通り、IsArrayは既に存在するため、「js.codeobject.isArray」だとエラーが出るからです。当然別の関数名にリネームすれば普通に呼べます。

JScriptTypeInfoかVariantかを判定する

パーサを自作しよう！と思うなら大事です。と言うのも、JScriptTypeInfoはObjectのため、受け取るときにSetをつけないといけないんですが、Variantの時にSetがついてるとエラーで死にます。逆もまた然り。

TypeNameを駆使して選り分けてあげましょう。

If TypeName(CallByName(json, key, VbGet)) = "JScriptTypeInfo" Then
    'JScriptTypeInfo (Object)
Else
    'Not JScriptTypeInfo (Variant)
End If

とは言え、For Eachで回しているときにJScriptTypeInfoが来るのは配列以外ない（と思ってるんだけど、どうでしょう）ので、パーサの一番最初に組み込むだけでいいかもしれないですね。

配列の長さを取得する

Lengthも当然VBAの予約語なので、CallByNameです。

CallByName(json, "length", VbGet)

まとめ

jsonやるならVBAはやめとけ。

つづき

実際にパーサを作ってみた編

2014/11/19追記：おまけ - vba-jsonを使ってみる

折角だからvba-jsonの使い方も説明しておきましょう。

trunk/json.xlsを拾ってきてVBEを開き、「jsonlib」と言うクラスモジュールをエクスポートすればOKです。

JSONLibクラスは二つのPublic Functionしか持っていません。parseとtoStringのみです。parseがデシリアライズ、toStringがシリアライズです。

具体的な使用法も同梱されているtestモジュールを読めば大体わかると思います。

シリアライズ

'
'   jsonlib.toString tests
'
Sub toString_test1()

    Dim a As String
    Dim b As Date
    Dim lib As New JSONLib
    
    b = Now()
    
    Debug.Print lib.toString(Array("a", "b", Array(1, b, "3")))
    ' => ["a","b",[1,"2014/11/19 15:13:56","3"]]
    Debug.Assert Err.Number = 0

    Set lib = Nothing

End Sub
Sub toString_test2()

    Dim a As Object
    Dim b As Object
    Dim c As New Collection
    Dim lib As New JSONLib
    
    Set a = CreateObject("Scripting.Dictionary")
    Set b = CreateObject("Scripting.Dictionary")
    
    a("aaa") = "abc"
    a("bbb") = Array(0, 1, b)
    b("ccc") = "def"
    Set b("ddd") = c
    c.Add "ghi"
    c.Add 999
    
    Debug.Print lib.toString(a)
    ' => {"aaa":"abc","bbb":[0,1,{"ccc":"def","ddd":["ghi",999]}]}
    Debug.Assert Err.Number = 0
    
    Set lib = Nothing
    Set c = Nothing
    Set b = Nothing
    Set a = Nothing
    
End Sub

デシリアライズ

'
'   jsonlib.parse tests
'
Sub parse_test1()

    Dim lib As New JSONLib
    Dim json As Object

    Set json = lib.parse(" " & vbCrLf & vbTab & " {}")
    Debug.Assert TypeName(json) = "Dictionary"
    Debug.Assert Err.Number = 0
    
    Debug.Print TypeName(json), json.Count
    ' => Dictionary     0
    
    Set json = Nothing
    
    Set json = lib.parse(" " & vbCrLf & vbTab & " []")
    Debug.Assert TypeName(json) = "Collection"
    Debug.Assert Err.Number = 0
    
    Debug.Print TypeName(json), json.Count
    ' => Collection     0

    Set json = Nothing
    Set lib = Nothing
    
End Sub
Sub parse_test2()

    Dim lib As New JSONLib
    Dim json As Object

    Set json = lib.parse(" " & vbCrLf & vbTab & " {}")
    
    Debug.Print lib.toString(json)
    ' => {}
    Debug.Assert Err.Number = 0
    
    Set json = Nothing
    Set lib = Nothing
    
End Sub
Sub parse_test3()

    Dim lib As New JSONLib
    Dim json As Object

    Set json = lib.parse(" " & vbCrLf & vbTab & " [[], {""test1"":'v1', 'test2':'v222', test3:""v33333""}, null , ""test"", 123, 567.8910, 4.7e+10, true,  false]")
    Debug.Assert Err.Number = 0
    
    Debug.Print lib.toString(json)
    ' => [[],{"test1":"v1","test2":"v222","test3":"v33333"},null,"test",123,567.891,47000000000,true,false]
    
    Set json = Nothing
    Set lib = Nothing
    
End Sub
Sub parse_test4()
    
    Dim lib As New JSONLib
    Dim json As Object

    Set json = lib.parse("[{""type"":""t1"",""title"":""データ1"",""attr"":[""1-1"",""1-2""]},{""type"":""t2"",""title"":""データ2"",""attr"":[""2-1"",""2-2""]}]")
    Debug.Assert Err.Number = 0
    
    Debug.Print lib.toString(json)
    ' =>[{"type":"t1","title":"\u30C7\u30FC\u30BF1","attr":["1-1","1-2"]},{"type":"t2","title":"\u30C7\u30FC\u30BF2","attr":["2-1","2-2"]}]
    
    Set json = Nothing
    Set lib = Nothing

End Sub
Sub parse_test5()
    
    Dim lib As New JSONLib
    Dim json As Object
    Dim text As String
    Dim res1 As String
    Dim res2 As String

    With CreateObject("ADODB.Stream")
        .Open
        .Charset = "UTF-8"
        .LoadFromFile ActiveWorkbook.Path & "\\test.json"
        text = .ReadText(-1)
        .Close
    End With
    
    Debug.Print text
    ' =>
    '[
    '    {
    '        "type" : "t1",
    '        "title" : "型1",
    '        "attr" : [
    '            {
    '                "name" : "attr1",
    '                "title" : "属性1"
    '            },
    '            {
    '                "name" : "attr2",
    '                "title" : "属性2"
    '            },
    '            {
    '                "name" : "attr3",
    '                "title" : "属性3"
    '            }
    '        ]
    '    },
    '    {
    '        "type" : "t2",
    '        "title" : "型2",
    '        "attr" : [
    '            {
    '                "name" : "create_date",
    '                "title" : "作成日"
    '            },
    '            {
    '                "name" : "update_date",
    '                "title" : "更新日"
    '            },
    '            {
    '                "name" : "attr1",
    '                "title" : "属性1"
    '            },
    '            {
    '                "name" : "attr2",
    '                "title" : "属性2"
    '            },
    '            {
    '                "name" : "attr3",
    '                "title" : "属性3"
    '            }
    '        ]
    '    }
    ']

    
    Set json = lib.parse(text)
    Debug.Assert Err.Number = 0
    res1 = lib.toString(json)
    
    Set json = lib.parse(lib.toString(json))
    Debug.Assert Err.Number = 0
    res2 = lib.toString(json)
    
    Debug.Print res1
    ' => [{"type":"t1","title":"\u578B1","attr":[{"name":"attr1","title":"\u5C5E\u60271"},{"name":"attr2","title":"\u5C5E\u60272"},{"name":"attr3","title":"\u5C5E\u60273"}]},{"type":"t2","title":"\u578B2","attr":[{"name":"create_date","title":"\u4F5C\u6210\u65E5"},{"name":"update_date","title":"\u66F4\u65B0\u65E5"},{"name":"attr1","title":"\u5C5E\u60271"},{"name":"attr2","title":"\u5C5E\u60272"},{"name":"attr3","title":"\u5C5E\u60273"}]}]
    
    Debug.Print res2
    ' => [{"type":"t1","title":"\u578B1","attr":[{"name":"attr1","title":"\u5C5E\u60271"},{"name":"attr2","title":"\u5C5E\u60272"},{"name":"attr3","title":"\u5C5E\u60273"}]},{"type":"t2","title":"\u578B2","attr":[{"name":"create_date","title":"\u4F5C\u6210\u65E5"},{"name":"update_date","title":"\u66F4\u65B0\u65E5"},{"name":"attr1","title":"\u5C5E\u60271"},{"name":"attr2","title":"\u5C5E\u60272"},{"name":"attr3","title":"\u5C5E\u60273"}]}]
    
    Debug.Assert (res1 = res2)
    
    Set json = Nothing
    Set lib = Nothing

End Sub

とまぁ、このようにDictionary / Collection ⇔ jsonの変換が自由自在に出来ます。ライセンスはBSDライセンスとのことなので商用利用もいけますね。ただ、肝心のライセンス条文がどこにも見当たらないのが若干不安ですが。

Tumbling Dice