【VBA】VBAでjsonのパーサを作ってみよう
JsonObjectの方でItemプロパティを使うようにしました。
前書き
なんとかVBAでjsonをパースすることが出来るようになったのはいいけれど、なんでjsonごときにここまで苦戦せにゃならんのだと思うのは正しいし、汎用的なパーサを作ってしまうのがいいのでは?と思うのも当然と言えば当然の流れ。
で、作りました。読むだけで出力は出来ません。てか、それならもうJavascriptで全部書けって話ですよ。
とりあえずもう暫くVBAは書きたくないです。
1.今回使うjson
コードを紹介する前に、今回テストしてみたハチャメチャなjsonを紹介し、これをどう言うオブジェクトに変換したらいいのかを考えて見ます。
今回テストしてみたjsonはこれです。
[{"hoge":{ "piyo":{"fugapiyo":[{"foo":1},{"bar":2}]}, "fuga":[3,4], "hogepiyo":[5,6], "hogefuga":7 }}]
整形するとこんな感じ。
[ { "hoge": { "piyo": { "fugapiyo": [ { "foo": 1 }, { "bar": 2 } ] } "fuga": [ 3, 4 ], "hogefuga": 7, "hogepiyo": [ 5, 6 ], } } ]
整形するとキー以外は思ったよりハチャメチャじゃないですね。
2.作ってみたコード
とりあえず、パースするためのクラスと、パースした結果をラップするためのクラスを作ってみました。
JsonParser
Option Explicit '******************** 'JsonParser ' 'Jsonパース処理 'パースした結果はJsonObjectでラップされる ' '注意:JsonObject→自作したJsonObjectと言うDictionaryのラッパークラス ' Json(JScriptTypeInfo)→Javascriptでevalした結果のObject '******************** Private m_js As Object 'javascript実行用オブジェクト '******************** 'コンストラクタ '処理中で使用するJavascriptの定義を行う '******************** Public Sub Class_Initialize() Set m_js = CreateObject("ScriptControl") m_js.Language = "JScript" 'JsonをevalするJavactipt m_js.AddCode "function jsonParse(str) { return eval('(' + str + ')'); };" 'Jsonからキーの配列を取得するJavascript m_js.AddCode "function getKeys(h) { var keys=[]; for(var k in h){keys.push(k);} return keys; };" 'Jsonが配列かどうかを確認するJavascript m_js.AddCode "function isArray(o) { return o instanceof Array; };" End Sub '******************** 'デストラクタ '******************** Private Sub Class_Terminate() Set m_js = Nothing End Sub '******************** 'パース処理呼び出し ' 'Argument:Jsonの形式になっている文字列(String) 'Return :Collection(JsonObject)もしくはJsonObject ' 引数がJson形式でなかった場合はNothing '******************** Public Function Parse(ByVal strJson As String) As Object Dim json As Object On Error GoTo ParseError Set json = m_js.codeobject.jsonParse(strJson) On Error GoTo 0 'valueを解析した結果がJScriptTypeInfoかどうかを判定する 'JScriptTypeInfo以外の場合はNothingを返す If IsJson(json) Then If IsJsonArray(json) Then Set Parse = JsonArrayToCollection(json) Else Set Parse = JsonToDictionary(json) End If Else Set Parse = Nothing End If Exit Function ParseError: Debug.Print Err.Description Set Parse = Nothing End Function '******************** 'Jsonの配列をCollectionに変換する ' 'Argument:Jsonの配列(JScriptTypeInfo) 'Return :Key:Jsonで使用されているキー Value:JsonObjectのCollection '******************** Private Function JsonArrayToCollection(ByVal json As Object) As Collection Dim col As New Collection Dim key As Variant Dim objJson As Object Dim varJson As Variant Dim jsonObj As JsonObject Dim jsonData As Dictionary For Each key In GetKeys(json) On Error GoTo VariantPattern Set objJson = GetObject(json, key) If IsJsonArray(objJson) Then '配列だった場合は再帰させる Call col.Add(JsonArrayToCollection(objJson), key) Else '一要素だった場合はJsonObjectをCollectionに追加する Call col.Add(JsonToDictionary(objJson), key) End If GoTo Continue VariantPattern: On Error GoTo 0 varJson = GetValue(json, key) Set jsonObj = New JsonObject Set jsonData = New Dictionary Call jsonData.Add(key, varJson) Call jsonObj.Init(jsonData) Call col.Add(jsonObj, key) Resume Continue Continue: Next On Error GoTo 0 Set JsonArrayToCollection = col End Function '******************** 'Jsonの配列をDictionaryに変換する ' 'Argument:Json(JScriptTypeInfo) 'Return :Key:Jsonで使用されているキー Value:Json.keyのJsonObject '******************** Private Function JsonToDictionary(ByVal json As Object) As JsonObject Dim jsonDictionary As New Dictionary Dim col As New Collection Dim collectionValue As Variant Dim jsonObj As New JsonObject Dim key As Variant Dim objJson As Object Dim varJson As Variant Dim obj As Object Dim var As Variant For Each key In GetKeys(json) On Error GoTo VariantPattern Set objJson = GetObject(json, key) On Error GoTo 0 If IsJsonArray(objJson) Then '配列だった場合はKey:Jsonのキー Value:Collection(JsonObject)となるDictionaryを作成 'Collection(JsonObject)の作成 For Each collectionValue In objJson 'Collection作成中にJsonの配列が現れた場合は再帰させる If IsJson(collectionValue) Then Call col.Add(JsonToDictionary(collectionValue)) Else Call col.Add(collectionValue) End If Next Call jsonDictionary.Add(key, col) Else On Error GoTo ObjectPattern var = GetValue(objJson, key) On Error GoTo 0 Call jsonDictionary.Add(key, var) GoTo Continue End If GoTo Continue ObjectPattern: Call jsonDictionary.Add(key, JsonToDictionary(objJson)) Resume Continue VariantPattern: On Error GoTo 0 Call jsonDictionary.Add(key, GetValue(json, key)) Resume Continue Continue: Next '作成し終わったDictionaryでJsonObjectを作る Call jsonObj.Init(jsonDictionary) Set JsonToDictionary = jsonObj End Function '******************** '配列チェック ' 'Argument:Json(JScriptTypeInfo) 'Return :引数が配列ならばTrue、配列でなければFalse '******************** Private Function IsJsonArray(ByVal json As Object) As Boolean IsJsonArray = CallByName(m_js.codeobject, "isArray", VbMethod, json) End Function '******************** 'キー取得 ' 'Argument:Json(JScriptTypeInfo) 'Return :引数のキーの配列 '******************** Private Function GetKeys(ByVal json As Object) As Object Set GetKeys = CallByName(m_js.codeobject, "getKeys", VbMethod, json) End Function Private Function IsJson(ByVal obj) As Boolean IsJson = TypeName(obj) = "JScriptTypeInfo" End Function Private Function GetObject(ByVal json As Object, ByVal key As Variant) As Object Set GetObject = CallByName(json, key, VbGet) End Function Private Function GetValue(ByVal json As Object, ByVal key As Variant) As Variant GetValue = CallByName(json, key, VbGet) End Function
JsonObject
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "JsonObject" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit '******************** 'JsonObject ' 'JsonParserによって作成されたDictionaryを使いやすくしたラッパ '******************** Private m_keys As New Collection '所有しているキー Private m_data As Dictionary 'ラップしているデータ Private m_inited As Boolean '初期化済み判定 Public Property Get JsonKeys() As Collection Set JsonKeys = m_keys End Property Public Property Get Item(ByVal key As String) Attribute Item.VB_UserMemId = 0 ' "."が含まれているかどうかを調べる If InStr(key, ".") = 0 Then ' "."が含まれていない場合はそのままキーとして使用し、データを返す If IsObject(m_data(key)) Then Set Item = m_data(key) Else Item = m_data(key) End If Else Dim keys() As String Dim i As Long Dim tmp ' キーを分解する keys = Split(key, ".") Set tmp = m_data(keys(0)) ' キーを一つ一つ調査していき、最後に取得した何かしらを返す For i = 1 To UBound(keys) If i = UBound(keys) Then If IsObject(tmp(keys(i))) Then Set Item = tmp(keys(i)) Else Item = tmp(keys(i)) End If Else Set tmp = tmp(keys(i)) End If Next End If End Property '******************** 'デストラクタ '******************** Private Sub Class_Terminate() Set m_keys = Nothing Set m_data = Nothing End Sub '******************** '初期化 'Argument:JsonParserでパースし終わったDictionary '******************** Public Sub Init(ByVal jsonData As Dictionary) Dim key As Variant '一度でもInitが呼ばれていたら何もしない If m_inited Then Exit Sub For Each key In jsonData.keys m_keys.Add (key) Next Set m_data = jsonData m_inited = True End Sub '******************** 'キー存在チェック 'Argument:チェックしたいキー 'Return :引数のキーが存在したらTrue、しなければFalse '******************** Public Function HasKey(ByVal key As String) As Boolean Dim keyCache As Variant For Each keyCache In m_keys If key = keyCache Then HasKey = True Exit Function End If Next HasKey = False End Function '******************** '配列チェック 'Argument:チェックしたいキー 'Return :引数のキーから取得できるItemがCollectionならTrue、それ以外ならFalse ' また、キーそのものがない場合もFalseを返す '******************** Public Function IsArray(ByVal key As String) As Boolean Dim obj As Object IsArray = False If Not HasKey(key) Then Exit Function If TypeName(m_data.Item(key)) = "Collection" Then IsArray = True End If End Function
えー、コメントと変数名に関しては力尽きました。
JsonParserの方はそのままコピペで大丈夫ですが、JsonObjectの方はAttributeを設定しているので一旦ファイルに保存してインポートしてください。お手数おかけします。
3.使い方
もう一度今回使うjsonを紹介しておきましょう。
[ { "hoge": { "piyo": { "fugapiyo": [ { "foo": 1 }, { "bar": 2 } ] } "fuga": [ 3, 4 ], "hogefuga": 7, "hogepiyo": [ 5, 6 ], } } ]
JsonParserを呼び出します。
Dim parser As New JsonParser Dim objJson As Object Set objJson = parser.Parse("[{""hoge"":{ ""piyo"":{""fugapiyo"":[{""foo"":1},{""bar"":2}]}, ""fuga"":[3,4], ""hogepiyo"":[5,6], ""hogefuga"":7 }}]")
今回はrootが配列のjsonを渡しているので、objJsonにCollectionが返ってきます。配列でない場合は直接JsonObjectが返ってきます。
とりあえず、hogeを取ってみましょう。
配列部分はCollectionになっているので普通に添字です。
JsonObjectはItemプロパティを設定しているので、普通にDictionaryから取得するような感じでいけます。
Dim hoge As JsonObject: Set hoge = objJson(1)("hoge")
'7がイミディエイトウィンドウに出力される Debug.Print objJson(1)("hoge")("hogefuga")
これだと流石にキモいので、最初からJsonライクなキーを渡してもOKです。
'7がイミディエイトウィンドウに出力される Debug.Print objJson(1)("hoge.hogefuga")
fooの値をワンライナーで取ろうとすると途中でコレクションが挟まってしまうので中々キモいです。
'1がイミディエイトウィンドウに出力される Debug.Print objJson(1)("hoge.piyo.fugapiyo")(1)("foo")
Collectionなので当然For Eachも出来ます。中身がJsonObjectだとわかっているならそれで受けた方が楽です。
Dim jsObj As JsonObject For Each jsObj In objJson(1)("hoge.piyo.fugapiyo") If jsObj.HasKey("foo") Then '1がイミディエイトウィンドウに出力される Debug.Print jsObj("foo") ElseIf jsObj.HasKey("bar") Then '2がイミディエイトウィンドウに出力される Debug.Print jsObj("bar") End If Next
Dim jsObj As JsonObject Dim tmpCollection As Collection Dim key As Variant Set tmpCollection = objJson(1)("hoge.piyo.fugapiyo") For Each jsObj In tmpCollection For Each key In jsObj.JsonKeys '1と2がイミディエイトウィンドウに出力される Debug.Print jsObj(key) Next Next
配列の中にキーがなく、普通に値が入っている場合はCollectionの添字で取り出します。
'3がイミディエイトウィンドウに表示される Debug.Print objJson(1)("hoge.fuga")(1)