Public Function fncInfoGet() As Boolean
'変数宣言
Dim strNo As String
Dim strRecNo As String
Dim strGetJson As String
Dim strIDPW As String
Dim parser As New JsonParser
Dim objJson As Object
Dim jsObj As New JsonObject
fncInfoGet = False
On Error GoTo fncInfoGet_Err
strRecNo = Worksheets(CST_MAIN).Range(CST_MAIN_レコード番号).Value
strauNo = Worksheets(CST_MAIN).Range(CST_MAIN_番号).Value
strID = strRecNo
strAPP = CST_テストTBL
strIDPW = "" 'kintoneのログイン情報
If fncKintoneGet_ID(strAPP, strID, strIDPW, strGetJson) = False Then
MsgBox ("エラー発生 fncKintoneGet_ID " & vbCrLf & strGetJson)
Exit Function
End If
Set objJson = parser.Parse(strGetJson)
'ここでエラーとなります
Set jsObj = objJson("record")(1)
If fncSetDataSet(jsObj) = False Then
Set objJson = Nothing
Set jsObj = Nothing
Exit Function
End If
fncInfoGet = True
Exit Function
fncInfoGet_Err:
MsgBox "エラー発生 fncInfoGet_Err（" & Err.Description & ")" & vbCrLf & strGetJson
Set objJson = Nothing
End Function
Option Explicit
'##########################
'JsonParser
'Jsonパース処理
'##########################
Private m_js As Object
' ********************
'コンストラクタ
' ********************
Public Sub Class_Initialize()
Set m_js = CreateObject("ScriptControl")
m_js.Language = "JScript"
'JsonをevalするJavascript
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:JsonObjectのCollection
' ********************
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
'Json判定
Private Function IsJson(ByVal obj) As Boolean
IsJson = TypeName(obj) = "JScriptTypeInfo"
End Function
'Jsonからキーのオブジェクトを取得
Private Function GetObject(ByVal json As Object, ByVal Key As Variant) As Object
Set GetObject = CallByName(json, Key, VbGet)
End Function
'Jsonからキーの内容取得
Private Function GetValue(ByVal json As Object, ByVal Key As Variant) As Variant
GetValue = CallByName(json, Key, VbGet)
End Function