準備

kintoneでの準備

kintoneで以下の二つを用意する。

アプリ番号
APIトークン

JSON用モジュールのインポート

JsonConverter.basとDictionary.clsをインポートする

モジュール

レコード取得

get_kintone()

'検索条件に合致したレコードを取得
Sub get_kintone()

    Dim AppID As Integer 'アプリID用変数
    Dim APItoken As String 'APIトークン用変数
    Dim Domain As String '個別ドメイン用変数
    Dim URL As String 'URL用変数

    Dim Query As String 'クエリ用変数
    
    Dim objHttpReq As Object 'XMLオブジェクト用変数
    Dim strJSON As String 'レスポンス用変数
        
    Dim record As Variant
    Dim RowNum As Long
    
    Dim objJSON As Object
        
    Set objHttpReq = CreateObject("MSXML2.XMLHTTP")
    
    AppID = APP-NUMBER 'アプリ番号
    APItoken = "API-TOKEN" 'APIトークン
    Domain = "my-domain.cybozu.com" '個別ドメイン
    
    URL = "https://" & Domain & "/k/v1/records.json?app=" & AppID ' URL
    
    Query = "field_code_01 =""" & "req1" & """" & " and field_code_02 = """ & "req2" & """" & " order by $id asc limit 500" '検索条件
    
    Query = WorksheetFunction.EncodeURL(Query)
    URL = URL & "&query=" & Query
    
    objHttpReq.Open "GET", URL, False
    objHttpReq.setRequestHeader "X-Cybozu-Api-Token", APItoken 'APIトークンで認証
    objHttpReq.setRequestHeader "Host", Domain + ":443" 'ドメイン：ポート番号
    objHttpReq.setRequestHeader "If-Modified-Since", "Thu,01 Jun 1970 00:00:00 GMT" 'キャッシュ対策
    
    objHttpReq.send ("Null")
        
    strJSON = objHttpReq.responseText
    
    '取得したレコードをセルに転記
    Set objJSON = ParseJson(strJSON)
    
    Rows("2:1000").ClearContents
    
    If objJSON("records").Count = 0 Then
    
        End
        
    Else
    
        RowNum = 2 'レコードの転記開始行
        
        For Each record In objJSON("records")
        
            Cells(RowNum, 1) = record.Item("$id").Item("value")
            Cells(RowNum, 2) = record.Item("field_code_01").Item("value")
            Cells(RowNum, 3) = record.Item("field_code_02").Item("value")
            Cells(RowNum, 4) = record.Item("field_code_03").Item("value")
            Cells(RowNum, 5) = record.Item("field_code_04").Item("value")
            Cells(RowNum, 6) = record.Item("field_code_05").Item("value")
            Cells(RowNum, 7) = record.Item("field_code_06").Item("value")
            Cells(RowNum, 8) = record.Item("field_code_07").Item("value")
            Cells(RowNum, 9) = record.Item("field_code_08").Item("value")
            Cells(RowNum, 10) = record.Item("field_code_09").Item("value")
            Cells(RowNum, 11) = record.Item("field_code_10").Item("value")
                    
            RowNum = RowNum + 1
    
        Next
        
    End If
    
    objHttpReq.abort
    
End Sub

データ書き込み

post_kintone()

'レコード登録
Sub post_kintone()

    Dim AppID As Integer 'アプリID用変数
    Dim APItoken As String 'APIトークン用変数
    Dim Domain As String '個別ドメイン用変数
    Dim URL As String 'URL用変数

    Dim objHttpReq As Object 'XMLオブジェクト用変数
    Dim strJSON As String 'レスポンス用変数
    
    Dim jd As String 'Json作成用テキスト
    Dim Json As Object 'Jsonデータ
    
    Dim records As String
        
    Set objHttpReq = CreateObject("MSXML2.XMLHTTP")
    
    AppID = APP-NUMBER 'アプリ番号
    APItoken = "API-TOKEN" 'APIトークン
    Domain = "my-domain.cybozu.com" '個別ドメイン
    
    URL = "https://" & Domain & "/k/v1/record.json?"
    
    '登録データ
    jd = ""
    jd = jd & "{'app':" & AppID
    jd = jd & ",'record':{"
    jd = jd & " 'field_code_01':{'value':" & "'data01'" & "}"
    jd = jd & ",'field_code_02':{'value':" & "'data02'" & "}"
    jd = jd & ",'field_code_03':{'value':" & "'data03'" & "}"
    jd = jd & ",'field_code_04':{'value':" & "'data04'" & "}"
    jd = jd & ",'field_code_05':{'value':" & "'data05'" & "}"
    jd = jd & ",'field_code_06':{'value':" & "'data06'" & "}"
    jd = jd & ",'field_code_07':{'value':" & "'data07'" & "}"
    jd = jd & ",'field_code_08':{'value':" & "'data08'" & "}"
    jd = jd & ",'field_code_09':{'value':" & "'data09'" & "}"
    jd = jd & ",'field_code_10':{'value':" & "'data10'" & "}"
    jd = jd & "}}"
    
    Set Json = JsonConverter.ParseJson(jd)
    
    records = JsonConverter.ConvertToJson(Json)
    
    objHttpReq.Open "POST", URL, False
       
    objHttpReq.setRequestHeader "X-Cybozu-Api-Token", APItoken 'APIトークンで認証
    objHttpReq.setRequestHeader "Content-Type", "application/json"
    objHttpReq.setRequestHeader "Host", Domain + ":443" 'ドメイン：ポート番号
    objHttpReq.setRequestHeader "If-Modified-Since", "Thu,01 Jun 1970 00:00:00 GMT" 'キャッシュ対策
    
    objHttpReq.send records
    
    objHttpReq.abort
    
End Sub

レコード更新

put_kintone()

'レコード更新
Sub put_kintone()

    Dim AppID As Integer 'アプリID用変数
    Dim APItoken As String 'APIトークン用変数
    Dim Domain As String '個別ドメイン用変数
    Dim URL As String 'URL用変数

    Dim objHttpReq As Object 'XMLオブジェクト用変数
    Dim strJSON As String 'レスポンス用変数
    
    Dim jd As String 'Json作成用テキスト
    Dim Json As Object 'Jsonデータ
    
    Dim records As String
        
    Set objHttpReq = CreateObject("MSXML2.XMLHTTP")
    
    AppID = APP-NUMBER 'アプリ番号
    APItoken = "API-TOKEN" 'APIトークン
    Domain = "my-domain.cybozu.com" '個別ドメイン
    
    URL = "https://" & Domain & "/k/v1/record.json?"
    
    '登録データ
    jd = ""
    jd = jd & "{'app':" & AppID
    jd = jd & ",'record':{"
    jd = jd & " 'field_code_01':{'value':" & "'data01'" & "}"
    jd = jd & ",'field_code_02':{'value':" & "'data02'" & "}"
    jd = jd & ",'field_code_03':{'value':" & "'data03'" & "}"
    jd = jd & ",'field_code_04':{'value':" & "'data04'" & "}"
    jd = jd & ",'field_code_05':{'value':" & "'data05'" & "}"
    jd = jd & ",'field_code_06':{'value':" & "'data06'" & "}"
    jd = jd & ",'field_code_07':{'value':" & "'data07'" & "}"
    jd = jd & ",'field_code_08':{'value':" & "'data08'" & "}"
    jd = jd & ",'field_code_09':{'value':" & "'data09'" & "}"
    jd = jd & ",'field_code_10':{'value':" & "'data10'" & "}"
    jd = jd & "}}"
    
    Set Json = JsonConverter.ParseJson(jd)
    
    records = JsonConverter.ConvertToJson(Json)
    
    objHttpReq.Open "PUT", URL, False
        
    objHttpReq.setRequestHeader "X-Cybozu-Api-Token", APItoken 'APIトークンで認証
    objHttpReq.setRequestHeader "Content-Type", "application/json"
    objHttpReq.setRequestHeader "Host", Domain + ":443" 'ドメイン：ポート番号
    objHttpReq.setRequestHeader "If-Modified-Since", "Thu,01 Jun 1970 00:00:00 GMT" 'キャッシュ対策
    
    objHttpReq.send records
    
    objHttpReq.abort
    
End Sub

レコード削除

del_kintone()

'レコード削除
Sub del_kintone()

    Dim AppID As Integer 'アプリID用変数
    Dim APItoken As String 'APIトークン用変数
    Dim Domain As String '個別ドメイン用変数
    Dim URL As String 'URL用変数

    Dim DelID As String '削除するレコードID

    Dim jd As String 'Json作成用テキスト
    Dim Json As Object 'Jsonデータ
        
    Set objHttpReq = CreateObject("MSXML2.XMLHTTP")
    
    AppID = APP-NUMBER 'アプリ番号
    APItoken = "API-TOKEN" 'APIトークン
    Domain = "my-domain.cybozu.com" '個別ドメイン
    
    URL = "https://" & Domain & "/k/v1/records.json?app=" & AppID
    
    DelID = 000 '削除するID番号
        
    URL = URL & "&ids[0]=" & DelID

    Debug.Print (URL) 'URL確認用
    
    objHttpReq.Open "DELETE", URL, False
    
    objHttpReq.setRequestHeader "X-Cybozu-Api-Token", APItoken 'APIトークンで認証
    objHttpReq.setRequestHeader "Host", Domain + ":443" 'ドメイン：ポート番号
    objHttpReq.setRequestHeader "If-Modified-Since", "Thu,01 Jun 1970 00:00:00 GMT" 'キャッシュ対策
    
    objHttpReq.send ("Null")
   
    objHttpReq.abort
    
End Sub