VBA で kintone レコードを取得し json 変換

VBA で kintone からレコード取得し json 変換する例です。
json 変換に、cJobject ライブラリを使用します。
だいぶ期間が空きましたが、前回　VBA で JSON 変換する cJobject ライブラリの続きです。

環境

Windows 10 Pro
Excel 2016

cjobject ライブラリの準備

cJobject の機能を使うには、下記からexcel ファイルをダウンロードします。
ダウンロードページ で、Data Manipulation　を展開すると、最後にvanillacJobject.xlsm があります。

今回は、ダウンロードしたファイルに、VBA IDE で、Module を追加して処理を記述します。

kintone REST API レコード取得

レコード取得方法は、第2回 Excelとkintoneを連携させよう　とほとんど同じです。

ただし、例とXMLHTTP オブジェクトのバージョンが違っていたので、変更しました。

 Dim objHttpReq As XMLHTTP60   ' XMLHTTP オブジェクト

ログイン認証のBase64変換

cJobject ライブラリに、Base64Encode関数があるので、それを使います。

.vba

Dim strAuthorization As String     ' Authorization
strAuthorization = Base64Encode("USER:PASS")

レスポンス情報を json 変換

JSONParse 関数でレスポンス情報を、cjobject に変換できます。

.vba

    Dim resp As cJobject           ' json data
    Dim records As cJobject           ' json data
    ...
    Set resp = JSONParse(strJSON)
    Set records = resp.child("records")

レコード内の項目値を取り出す

レコードからユーザー選択項目を取り出します。

.vba

    Dim strTemp As String
    
    For Each record In records.children
        Dim users As cJobject
        Dim user As cJobject
        Set users = record.child("ユーザー選択").child("value")
        strTemp = ""
        If users.children.Count > 0 Then
            
            ' ユーザーの１番目
            Debug.Print "ユーザー選択(1) " & users.child(1).child("name").value
            
            ' 全ユーザー
            For Each user In users.children
                If strTemp <> "" Then
                    strTemp = strTemp & ", "
                End If
                strTemp = strTemp & user.child("code").value & ":" & user.child("name").value
            Next user
            Debug.Print "ユーザー選択: " & strTemp
        End If
    Next record

Access shortcut

cJobject では、下記の JavaScript のような、書き方で、項目の値を取得できます。

JavaScript.js

    Console.log("Access shortcut: ", records[0]["ユーザー選択"].value[0].code;

cJobject の Access shortcut 機能

cJobject.vba

    Debug.Print "Access shortcut: " & records.child("1.ユーザー選択.value.1.code").value

VBA コード全体

module1.vba

Sub kintoneGetTest1()
    
    '--------------------------------------------------------------------
    '  変数定義
    '--------------------------------------------------------------------
    Dim objHttpReq As XMLHTTP60   ' XMLHTTP オブジェクト
    Dim strJSON As String              ' レスポンスで受け取るJSONデータ
    Dim strURL As String               ' アクセス先URL
    Dim strQuery As String             ' 検索文字列
    Dim strAuthorization As String     ' Authorization
    
    strAuthorization = Base64Encode("USER:PASS")
    
    '------------------------------------------------------------------
    ' 検索文字付きURLを作成する
    '------------------------------------------------------------------
    strQuery = "ユーザー選択 in ( ""Alex2013"" )"
    strQuery = URL_Encode(strQuery)
    
    strURL = "https://<サブドメイン>.cybozu.com/k/v1/records.json?&app=846&query=" & strQuery
    
    '------------------------------------------------------------------
    ' XMLHTTP オブジェクトを生成する
    '------------------------------------------------------------------
    Set objHttpReq = CreateObject("MSXML2.XMLHTTP")
    objHttpReq.Open "GET", strURL, False
    '------------------------------------------------------------------
    ' XMLHTTP のリクエストヘッダーを指定する
    '------------------------------------------------------------------
    ' ログイン認証
    objHttpReq.setRequestHeader "X-Cybozu-Authorization", strAuthorization
    ' Basic 認証
    'objHttpReq.setRequestHeader "Authorization", "Basic " & <ベーシック認証情報>
    'ドメイン名：ポート番号
    objHttpReq.setRequestHeader "Host", "<サブドメイン>.cybozu.com" + ":443"
    'キャッシュ対策（常にレスポンスが取得できる状態にする）
    objHttpReq.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
    
    '------------------------------------------------------------------
    ' リクエストを送信する
    '------------------------------------------------------------------
    objHttpReq.send (Null)
    
    '------------------------------------------------------------------
    ' レスポンスを取得する
    '------------------------------------------------------------------
    'レスポンス情報を変数に格納する
    
    Dim resp As cJobject           ' json data
    Dim records As cJobject           ' json data
    Dim record As cJobject           ' json data
    
    strJSON = objHttpReq.responseText
    'Debug.Print "resp: " & strJSON
    Set resp = JSONParse(strJSON)
    Set records = resp.child("records")
    
    Dim strTemp As String
    
    For Each record In records.children
        Dim users As cJobject
        Dim user As cJobject
        Set users = record.child("ユーザー選択").child("value")
        strTemp = ""
        If users.children.Count > 0 Then
            
            ' ユーザーの１番目
            Debug.Print "ユーザー選択(1) " & users.child(1).child("name").value
            
            ' 全ユーザー
            For Each user In users.children
                If strTemp <> "" Then
                    strTemp = strTemp & ", "
                End If
                strTemp = strTemp & user.child("code").value & ":" & user.child("name").value
            Next user
            Debug.Print "ユーザー選択: " & strTemp
        End If
    Next record

    Debug.Print
    Debug.Print "Access shortcut: " & records.child("1.ユーザー選択.value.1.code").value

End Sub


'--------------------------------------
'URLエンコード用関数
'--------------------------------------
Function URL_Encode(ByVal strOrg As String) As String
  Dim d As Object
  Dim elm As Object
  
  strOrg = Replace(strOrg, "\", "\\")
  strOrg = Replace(strOrg, "'", "\'")
  Set d = CreateObject("htmlfile")
  Set elm = d.createElement("span")
  elm.setAttribute "id", "result"
  d.appendChild elm
  d.parentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & strOrg & "');", "JScript"
  URL_Encode = elm.innerText
End Function

実行結果

イミディエイトウィンドウ

ユーザー選択(1) Alex2013
ユーザー選択: Alex2013:Alex2013, Alex2014:Alex2014

Access shortcut: Alex2013

関連

VBA で kintone レコードを取得し json 変換
VBA で kintone ユーザー情報を取得し json 変換
VBA で kintone 新規レコード作成、json 文字列変換