VBAからkintoneデータをOAuth2.0認証で読み書きする - 実戦編
前回の記事にて、kintoneのOAuth2.0認証周りを実装しました。これにより、あとはAPIを叩いて、データを取得したり、kintone側のデータを更新する事が可能になります。この仕組を使う事で、kintone側で装備したりプラグイン開発といった事をする必要がなく、使い慣れたExcelやAccess側で制御が可能になります。また、JSは使い手なら大量のライブラリを使いこなせますが、そうではない中小企業の場合VBA側のほうがしっかりしたGUIを構築できるメリットもあります。
今回は取得したAccess Tokenを用いて、APIを実際に叩いてみてkintoneのデータの処理をしてみたいと思います。まずは、データの一括取得、そして実際に承認作業をしてkintone側の対象のレコードを更新する、対象のレコードを削除する、新規レコードの追加という最も重要な部分を実装します。
リンク
目次
今回使用するファイル等
kintone側へ更新用データを送る為にJSONを組み立てる必要があるため、VBA-JSONを今回は利用しています。また引き続き、暗号化のためのモジュールも前回に引き続き含まれています。
新方式が登場しました
IE11の廃止に伴い、SeleniumやNode.jsやらといった手段を使わず、またPuppeteerと同様の手法（CDPを叩く）でVBAとEdge/ChromeのみでOAuth2.0認証する手段が登場しました。スクレイピングも可能になっています。以下のエントリーを参考にしてみてください。この手法は最も制限が無く、もっともすぐれた選択肢になると思います。
事前準備
参照設定
本プログラムは今回、DictionaryやOutlookを使う為に参照設定が必要です。
- Microsoft Outlook 16.0 Object Library – Outlookを遠隔操作するために必要
- Microsoft Scripting Runtime – Dictionaryを使うために必要
APP IDの取得と保存
今回から予め作成しておいた「アプリ」のAPP IDが別途必要になります。このAPP IDは、アプリのURLにある数字がそれになりますので、これを前回の設定用UIに新たな項目として、レジストリに保存できるように追加してあげましょう。URLは以下のような感じになります。
https://ドメイン名.cybozu.com/k/999/
この999の部分がAPP IDとなり、アプリ毎に異なります。
Private Sub CommandButton1_Click()
'入力内容を取得する
Dim apikey As String
Dim apitoken As String
Dim subdomain As String
Dim redirect As String
Dim userid As String
Dim regpass As String
Dim appid As String
Dim lRet As Variant
subdomain = Me.TextBox3.Value
redirect = Me.TextBox4.Value
userid = Me.TextBox5.Value
regpass = Me.TextBox6.Value
appid = Me.TextBox7.Value
'入力内容でもってレジストリにデータを登録
lRet = RegSetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"subdomain", _
REG_SZ, _
subdomain)
lRet = RegSetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"redirect", _
REG_SZ, _
redirect)
lRet = RegSetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"userid", _
REG_SZ, _
userid)
lRet = RegSetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"appid", _
REG_SZ, _
appid)
lRet = RegSetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"kinpass", _
REG_SZ, _
aes128encode(regpass))
'フォームを閉じる
Unload UserForm1
End Sub
'UserFormがロードされた時に発動
Private Sub UserForm_Initialize()
'レジストリ項目をボックスにロードする
On Error Resume Next
'パスワード入力欄を*に変換する
TextBox6.PasswordChar = "*"
TextBox6.TextAlign = fmTextAlignLeft
'レジストリからID等を読み取る
Dim subdomain As String
Dim appid As String
Dim userid As String
Dim regpass As String
Dim redirect As String
subdomain = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"subdomain", _
REG_SZ, _
0)
appid = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"appid", _
REG_SZ, _
0)
userid = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"userid", _
REG_SZ, _
0)
redirect = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"redirect", _
REG_SZ, _
0)
Me.TextBox3.Value = subdomain
Me.TextBox4.Value = redirect
Me.TextBox5.Value = userid
Me.TextBox7.Value = appid
'レジストリのパスワードを復号化して取り出す
regpass = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"kinpass", _
REG_SZ, _
0)
Me.TextBox6.Value = aes128decode(regpass)
End Sub
図：UserFormにはこのように増設しました
シート側の列の設定
一括取得等の為にシートを用意します。シート名はkintoneとし、kintone側のテーブルと同じような列構成で作っておきます。データの一括取得や、処理フラグなどを格納するようにkintone側で作成しておく必要がありますので、テーブル設計はしっかりおこないましょう。
図：テーブル設計はアプリ作成の肝です
図：シート側も同じ設計にしておく
承認用のフォームを用意する
UserForm2として承認用のフォームを新規に用意します。摘要欄だけはプロパティとして
- EnterkeyBeheiviorをTrueにする（Enterキーで改行になります）
- MultilineをTrueにする（複数行かけるようになる）
- ScrollBarsは「2 - fmScrollBarsVertical」とする（縦だけスクロールバー表示）
として設定しています。他はテキストボックスを用意して、初期化時に選択したレコードデータを格納します。また、承認・却下用のボタンを用意し、それぞれに処理を記述する必要があります。
図：承認用のダイアログがこれで用意できました。
新規追加用フォーム
UserForm3として新規追加用のフォームを用意します。使用用途欄のプロパティは
- EnterkeyBeheiviorをTrueにする（Enterキーで改行になります）
- MultilineをTrueにする（複数行かけるようになる）
- ScrollBarsは「2 - fmScrollBarsVertical」とする（縦だけスクロールバー表示）
として設定。他にも細かくデザイン上の設定変更や、数値の欄は右揃えにする等のプロパティ変更をしています。
また今回は、通常VBAのUserForm上では使えないカレンダーコントロールについて、こちらのクラスを利用する事でOS標準で入ってるCommon Controlの1つである「DTPicker」をVBA上から利用する事ができました。詳しくはクラス公開ページを良く読んでから装備してみてください。Visual Basic 6.0 runtimeの別途インストールは不要です（Windows10の場合）
図：データ追加用のダイアログはちょっとだけ豪華
ソースコード
データの一括取得
もっともよく利用する項目がデータの一括取得。ただし、データには既に処理が完了済みのものもあり、これらのデータまで毎回取得するのは合理的ではなく、またコードも複雑怪奇になります。また、kintoneは現在一括取得では最大500レコードぽっちしか取得できない制限があるため（2020年7月には10000件まで増やすようですが・・・・）、例えば、500件以上の未処理データがある場合には、数回に分けて取得するといった事が必要になります。
今回は以下の事を考慮して設計します。
- レコード番号を元に、既に取得済みデータについては取得対象とはしない
- 承認が未処理のレコードについては取得対象としない
小規模な組織であればこれだけで速度面や制限面もクリアしつつ十分な運用が出来るはずです。kintoneでは「指定したフィールドが空のものを抽出」がAPIでやる方法が無いので、空ではなく、未処理状態のものと定義づけて処理をすると良いです。それが出来ない場合、空で抽出するのではなく一度取得後空かどうか判定して、Excelに貼り付ける事になります。よって、未処理状態は初期値「未処理」が入るようにフィールドに設定しておきましょう。
'APIアクセス用エンドポイントURL
Private Const kingetdata As String = "https://ここにドメイン名.cybozu.com/k/v1/records.json?"
'kintoneの未処理データを一括で取得する
Public Function kintoneGetdata()
'変数を宣言
Dim appid As String
Dim query As String
Dim totalCount As Integer
Dim access_token As String
Dim actflg As Boolean
Dim ret As Boolean
Dim temptoken As String
Dim result As Variant
'問い合わせ
result = MsgBox("kintoneから最新のデータを受信しますか？？", vbYesNo + vbDefaultButton2 + vbExclamation)
If result = vbYes Then
'インポート処理を続行する
Else
'メッセージを表示
MsgBox "処理をキャンセルしました。"
'終了処理
Exit Function
End If
'APP IDを取得する
appid = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"appid", _
REG_SZ, _
0)
'アクセストークンの期限切れチェック
actflg = checkExpireToken()
If actflg = False Then
'新しくトークンを取得し直す
ret = getNewToken()
'トークンが取得し直せたか判定
If ret = False Then
MsgBox "Access Tokenの再取得に失敗しました。再度認証し直してください。"
Exit Function
End If
End If
'アクセストークンを取り出す
temptoken = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"access_token", _
REG_SZ, _
0)
access_token = aes128decode(temptoken)
'シートの取得済みの最大レコード番号を取得する
Dim recnum As Long
With Application.WorksheetFunction
recnum = .Max(ThisWorkbook.Worksheets("kintone").Range("A:A"))
End With
'抽出クエリを組み立てる(500レコード、recnum以降のレコードを指定）
query = "品目名 in (""封筒ラベル"") and 承認 = ""未処理"" and レコード番号 > " & recnum & " order by レコード番号 asc limit 500"
'抽出クエリをURLエンコードする
query = WorksheetFunction.EncodeURL(query)
'リクエストURLを組み立てる
Dim requrl As String
requrl = kingetdata & "app=" & appid & "&totalCount=true&query=" & query
'kintoneへデータをリクエスト
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", requrl, False
.setProxy 2, proxyuri 'プロキシサーバのURLとポート番号
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Authorization", "Bearer " & access_token
.send
'ステータスを取得
Dim status As String
status = .status
'ステータスに従って処理を分岐
Select Case .status
Case 200
'JSON取得用
Dim doc, jsn
Dim tempjson, temprec, tempval
'HTMLDocumentを取得
Set doc = CreateObject("HtmlFile")
'scriptタグを追加
doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
'JSONデータを取得する
Json = .responseText
'パース関数でJSONオブジェクトを取得
Set jsn = doc.JsonParse(Json)
'レコード数を取得する
totalCount = jsn.totalCount
'jsn.recordが空の場合データなしとみなす
If jsn.records = "" Then
MsgBox "現在最新のレコードを取り込み済みです"
Exit Function
End If
'ワークシートの列データを取得する
Dim colArray
Dim colcnt
Dim colname As String
colArray = ThisWorkbook.Worksheets("kintone").Range("A1:O1")
'列データのカラム件数を取得する
colcnt = UBound(colArray, 2)
'件数が1件以上ある場合
If totalCount >= 1 Then
'書き込み用配列を定義する
'totalCountの値がレコード件数、14が列数
Dim dataArray() As Variant
Dim testday As Variant
Dim testvalue As Variant
ReDim dataArray(totalCount, colcnt)
For i = 0 To totalCount - 1
'配列データを取得する
Set tempjson = CallByName(jsn.records, i, VbGet)
'配列にデータを流し込む
For j = 1 To colcnt
'要素名を取得する
colname = colArray(1, j)
'配列にデータを流し込む
Set temprec = CallByName(tempjson, colname, VbGet)
testvalue = CallByName(temprec, "value", VbGet)
'特定の日付列の場合には加工する
If colname = "更新日時" Or colname = "依頼日" Then
'日付の部分だけを取り出す
testday = Left(testvalue, 10)
'ハイフンをスラッシュに変換
testday = Replace(testday, "-", "/")
'配列にぶっこむ
dataArray(i, j - 1) = testday
Else
'配列にぶっこむ
dataArray(i, j - 1) = testvalue
End If
Next j
Next i
'シートの最終列および最終行を取得する
Dim lastrow As Long
Dim startrow As Long
Dim endrow As Long
lastrow = ThisWorkbook.Worksheets("kintone").UsedRange.Rows.Count
startrow = lastrow + 1
endrow = startrow + totalCount
'シートに書き出す
ThisWorkbook.Worksheets("kintone").Range("A" & startrow & ":O" & endrow) = dataArray
Else
'取り込むデータがなかった場合
MsgBox "取り込めるデータはありませんでした。"
Exit Function
End If
Case Else
'データ取得失敗
MsgBox "データの取得に失敗しました"
Exit Function
End Select
End With
'終了処理
MsgBox "取込が完了しました。"
End Function
- データ取得用のエンドポイントURLは、kingetdataに記してある通りのものになります。cursorと呼ばれるAPIもあります。
- Access Tokenの期限切れチェック＆再取得ルーチンをまず走らせます。
- 今回より新たに追加したAPP IDをレジストリから取得します。
- offsetは指定した分のレコード数だけ飛ばして表示するので、クエリの結果5件返ってきた場合、offsetが2の場合、3件目～のデータを受信する。レコード番号とは関係ないので注意。
- query文字列が嵌るポイントです。ドロップダウン項目は項目名 in (""項目の値"")としてクエリを作る必要があります。複数つなげる場合にはand演算子でつないで条件指定をします。
- 空文字での検索はできないので、どこか判定になる列で今回は未処理だったらという条件で取得します。
- レコード番号順でorder byを指定し、レコード番号最大値以上、取得件数は最大値の500をlimitとして指定しています。
- query文字列は必ず「URLエンコード」してから渡す必要があります。
- アクセスするURLにAPP IDとtotalCount=trueのオプション、query文字列をつなげて、GETで通信します。
- VBA-JSONは正直扱いが面倒（特にJSONオブジェクトのキー名に変数が素直に使えない）ので、いつものParseをしています。
- jsn.recordsが空の場合、取得できるデータがないのでそこで終了です。
- kintoneシートのカラム列名でCallByName関数にてkeyの指定として利用しています。
- 配列を用意し、同じレコード数・カラム数で拡張、データをCallByName関数でvalueを取得し流し込んであげます。
- 最後にシートの最終行以下に新しく取得した配列データを書き込みしています。
- totalCountですが、これはqueryでフィルタされたあとの件数ではなくフィルタされる前の件数なので注意。これが500を超えている場合にはtotalCount/500の回数だけGETで叩けば全てのデータを取得可能です。
全データを取得する
レコード取得のAPIについては、cursorを使った手法では10,000件まで取得可能ですが、通常のAPIでは500件がMAXです。そのため、kintoneのテーブルに500件以上ある場合、何度か回さないと取得ができません。それほど多く利用するシーンは無いと思いますが、無いと困るので、作りました。
以下のコードはExcelではなくAccess用に作っていますが、適当に関数などを書き直せば動くと思います。必要な部分だけを掲載しています。
'データ取得用変数
Dim lastset As Boolean
Dim loopcnt As Variant
'取得件数リミット（最大値は500）
Dim reclimit As Integer
reclimit = 500
'lastsetがfalseの間はループを回す
Do Until lastset = True
'テーブルの取得済みの最大レコード番号を取得する
recnum = DMax("レコード番号", "終了済み一覧")
'recnumがnullの場合は0として設定
If IsNull(recnum) Then
recnum = 0
End If
'抽出クエリを組み立てる(500レコード、終了済みが-1のものだけ）
'終了済み案件データを取得して更新クエリで反映
query = "endflg = -1 order by レコード番号 asc limit " & reclimit
query = encodeurl(query)
requrl = kingetdata & "app=" & appid & "&totalCount=true&query=" & query
'kintoneへデータをリクエスト
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", requrl, False
.setProxy 2, proxyuri 'プロキシサーバのURLとポート番号
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Authorization", "Bearer " & access_token
.send
'ステータスを取得
status = .status
'ステータスに従って処理を分岐
Select Case .status
Case 200
'HTMLDocumentを取得
Set doc = CreateObject("HtmlFile")
'scriptタグを追加
doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
'JSONデータを取得する
Json = .responseText
'パース関数でJSONオブジェクトを取得
Set jsn = doc.JsonParse(Json)
'レコード数を取得する
totalCount = jsn.totalCount
'リミットから回すべき回数を算出する
If totalCount <= reclimit Then
'はじめからreclimit以下の件数ならばoffsetは1で終了
loopcnt = totalCount
lastset = True
Else
'reclimitがそのままloopcntとなる
loopcnt = reclimit
End If
'jsn.recordが空の場合データなしとみなす
If jsn.records = "" Then
totalCount = 0
Exit Do
Else
'件数が1件以上ある場合
If totalCount >= 1 Then
'DB接続用変数
Set rs = db.OpenRecordset("終了済み一覧", dbOpenDynaset)
For i = 0 To loopcnt - 1
'配列データを取得する
Set tempjson = CallByName(jsn.records, i, VbGet)
'レコードを追加する
With rs
.AddNew
'レコード番号を取得する
Set temprec = CallByName(tempjson, "レコード番号", VbGet)
!レコード番号 = CallByName(temprec, "value", VbGet)
'終了フラグ
Set temprec = CallByName(tempjson, "endflg", VbGet)
!終了済み = CallByName(temprec, "value", VbGet)
.Update
End With
Next i
End If
End If
Case Else
'データ取得失敗
MsgBox "終了済みデータの取得に失敗しました"
Exit Function
End Select
End With
Loop
- lastsetがtrueの場合ループから脱出するようにしています。
- reclimitは取得できる最大値を指定しています（今回は500）
- テーブルより取得済みレコード番号の最大値を取得しておきます。クエリではこれよりも上のレコード番号を取得させます。
- POST送信で送り、totalCountが返ってきます。この値は最大値以上の条件での返り値なのでループ毎に減っていきます。
- totalCountがreclimit以下かどうかで判定させて、lastsetのフラグをtrueにします。
- また、reclimit以下の場合には残りの件数をloopcntに入れ、そうでない場合はreclimitをloopcntに入れます。
- loopcntを元にループを回し取得したデータをテーブルに流し込んでいきます。
１ループ毎にレコード番号最大値を取得してクエリを流して、totalCountがreclimit以下になるまで回し続ける事でオフセットなどの計算をせずに全部のレコードを取得可能です。
データの更新
承認フォーム側コード
UserForm2として承認用のフォーム側には、initializeと承認・却下のボタンを用意しています。
'承認ボタンの処理
Private Sub CommandButton1_Click()
'摘要欄のvalidation
If Me.TextBox7.Value = "" Then
MsgBox "摘要欄が空ですよ。"
Exit Sub
Else
tekiyou = Me.TextBox7.Value
End If
'承認フラグを立てる
appflg = "承認"
'ダイアログを非表示にする
Me.Hide
End Sub
'却下ボタンの処理
Private Sub CommandButton2_Click()
'摘要欄のvalidation
If Me.TextBox7.Value = "" Then
MsgBox "摘要欄が空ですよ。"
Exit Sub
Else
tekiyou = Me.TextBox7.Value
End If
'承認フラグを立てる
appflg = "却下"
'ダイアログを非表示にする
Me.Hide
End Sub
'UserForm2を初期化
Private Sub UserForm_Initialize()
'選択レコードの値を各テキストボックスに展開
Me.TextBox1.Value = retArray(1, 1)
Me.TextBox5.Value = retArray(1, 10)
Me.TextBox2.Value = retArray(1, 4)
Me.TextBox3.Value = retArray(1, 5)
Me.TextBox4.Value = retArray(1, 6)
Me.TextBox6.Value = retArray(1, 13)
'摘要欄にフォーカス
Me.TextBox7.SetFocus
End Sub
- 初期化では選択してる行のデータを各テキストボックスに反映しています。
- 承認及び却下のボタンでは、グローバル変数であるappflgに対してそれぞれの値を格納し、グローバル変数であるtekiyouに摘要欄の値を格納しています。
- この時、摘要欄は「Multilineはtrue」となっていて、「EnterkeyBehaviorはTrue」でEnterで改行されます。改行コードとなっているのでメールで送る場合は注意が必要です。
- 摘要欄が長くなった時の為に、Scrollbarsは「2 - fmScrollBarsVertical」として縦だけ表示するようにしています。
メインの更新用コード
承認および却下をした場合には、kintone側の対象の列の値を変更するだけでなく、入力値を持ってしてExcelの行の値も変更、その後Outlookにてメールを送る処理を作ります。
'APIアクセス用エンドポイントURL
Private Const kingetdata As String = "https://ドメイン名.cybozu.com/k/v1/records.json" '一括取得用
Private Const kinputdata As String = "https://ドメイン名.cybozu.com/k/v1/record.json" '単一レコード用
'ユーザフォーム用のグローバル配列
Public retArray As Variant
'摘要欄のワード
Public tekiyou As Variant
'選択レコードのIDを格納する
Public selerec As Variant
Public tarrec As Variant
'承認フラグ
Public appflg As String
'選択レコードの承認作業
Public Function kintoneApprove()
'変数初期化
appflg = ""
'現在アクティブになってるシート名を取得する
Dim activesheetman As String
activesheetman = ActiveSheet.Name
'// シートの入力範囲の全セルを取得
Dim rUsed As Range
Set rUsed = ActiveSheet.UsedRange
'行選択されているかどうかチェック
Dim lineman As Boolean
lineman = line_check()
If lineman = False Then
'行選択されていないので終了
MsgBox "行選択されていませんよ"
Exit Function
End If
'選択されている行数が2以上の場合終了
If Selection.Rows.Count >= 2 Then
MsgBox "一度に選択できる行数は1行だけです。"
Exit Function
End If
'選択されている行番号を取得する
Dim rng As Range
For Each rng In Selection.Rows
selerec = rng.Row
Next rng
'レコードデータIDを取得する
tarrec = rUsed(selerec, 1)
'承認列が未処理ではない場合終了
Dim approve As String
approve = rUsed(selerec, 15)
'承認済みの場合の処理
Select Case approve
'承認の場合
Case "承認":
MsgBox "既にこのレコードは承認済みです"
Exit Function
Case "却下":
MsgBox "既にこのレコードは却下となっています。"
Exit Function
End Select
'UserForm2側に送るデータを生成
retArray = ThisWorkbook.Worksheets("kintone").Range("A" & selerec & ":O" & selerec)
'UserForm2を開く
Load UserForm2
UserForm2.Show vbModal
Unload UserForm2
'appflgが空の場合、何もしないで終了（何もしないで閉じた場合の対処）
If appflg = "" Then
Exit Function
End If
'完了日を作成
Dim endday As String
endday = Format(Date, "yyyy-mm-dd")
'承認作業を実行
Dim ret As Boolean
ret = kintonePutData(appflg, endday)
'retの値によって、処理を分岐
If ret = True Then
'承認完了なのでスプレッドシート側も値を書き換える
With ThisWorkbook.Worksheets("kintone")
.Range("H" & selerec) = endday
.Range("N" & selerec) = tekiyou
.Range("O" & selerec) = appflg
End With
'Outlookで本人にメール通知
'Outlookオブジェクトの生成
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
'MailItemオブジェクトを生成
Set objOutlook = New Outlook.Application
'メール作成インスタンスの作成
Set objMail = objOutlook.CreateItem(olMailItem)
'メール本文等の設定
Dim Subject As String
Dim mailhead As String
Dim mailmsg As String
'メールサブジェクトを取得
Subject = rUsed(selerec, 4) & rUsed(selerec, 5) & "のオーダーについて"
'メールヘッダを作成する
mailhead = rUsed(selerec, 10) & "様<br><br><br>"
'メール・メッセージを組み立て
mailmsg = "<p>頂きました『" & rUsed(selerec, 4) & rUsed(selerec, 5) & "』のオーダーについて" & _
"<font color='red'><b>" & appflg & "</b></font>となりました。詳細については以下の通りです。</p>" & _
"<hr><b>承認者からのコメント：</b><br>" & tekiyou & "<br>"
mailmsg = mailmsg & "<p>承認された場合は、後ほどお届けします。却下された場合は、承認者のコメントを参考に修正し、再オーダーをお願い致します。</p><br><br>"
'改行コードを<br>に置き換え
mailmsg = Replace(mailmsg, vbLf, "<br>")
'メールを組み立てる（HTMLメール形式）
With objMail
.To = rUsed(selerec, 11)
.Subject = Subject
.BodyFormat = olFormatHTML 'メールの形式
.HTMLBody = mailhead & mailmsg 'メール本文
'メールを送信する
.Send
End With
'終了処理
Set objOutlook = Nothing
Set objMail = Nothing
MsgBox "更新が完了しました。"
Else
'承認失敗してるので何もしない
End If
End Function
'行選択されているかどうかチェック
Public Function line_check() As Boolean
'変数の宣言
Dim lineadd As String
lineadd = Selection.Address(False, False)
lineadd = Replace(lineadd, ":", "")
'選択行かどうかを確認
If IsNumeric(lineadd) Then
line_check = True
Else
line_check = False
End If
End Function
'kintone側のレコードを更新するルーティン（単一レコード）
Public Function kintonePutData(approveman As String, approveday As String) As Boolean
'変数の宣言
Dim appid As String
Dim access_token As String
Dim temptoken As String
Dim ret As Variant
'APP IDを取得する
appid = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"appid", _
REG_SZ, _
0)
'アクセストークンの期限切れチェック
actflg = checkExpireToken()
If actflg = False Then
'新しくトークンを取得し直す
ret = getNewToken()
'トークンが取得し直せたか判定
If ret = False Then
MsgBox "Access Tokenの再取得に失敗しました。再度認証し直してください。"
Exit Function
End If
End If
'アクセストークンを取り出す
temptoken = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"access_token", _
REG_SZ, _
0)
access_token = aes128decode(temptoken)
'リクエストデータを組み立て
'http://kimama-vba.com/2019/12/28/kintone-excel-put/
Dim Json_St As String
Dim Json As New Scripting.Dictionary '外側のJSON用
Dim Rec_Json As New Scripting.Dictionary 'record用
'個別フィールド用
Dim json_approve As New Scripting.Dictionary '承認列
Dim json_tekiyou As New Scripting.Dictionary '摘要列
Dim json_endday As New Scripting.Dictionary '完了日列
'共通値を追加
Json.Add "app", CInt(appid) 'appIDを指定
Json.Add "id", tarrec '更新対象のレコードID
'各列のデータを生成して1レコード作る
json_approve.Add "value", approveman
json_tekiyou.Add "value", tekiyou
json_endday.Add "value", approveday
With Rec_Json
.Add "承認", json_approve
.Add "摘要", json_tekiyou
.Add "完了日", json_endday
End With
'recordに塊を追加する
Json.Add "record", Rec_Json
'JSONに変換
Json_St = JsonConverter.ConvertToJson(Json)
'HTTPリクエスト
Dim http As New WinHttpRequest
Dim flagman As Boolean
With http
.Open "PUT", kinputdata, False
.setProxy 2, proxyuri 'プロキシサーバのURLとポート番号
.setRequestHeader "Content-Type", "application/json"
.setRequestHeader "Authorization", "Bearer " & access_token
.Send Json_St
'ステータスを取得
Dim status As String
status = .status
Select Case .status
Case 200, 201
flagman = True
Case Else
MsgBox .status & "エラー。承認は失敗しました。"
flagman = False
End Select
End With
'値を返す
kintonePutData = flagman
End Function
- グローバル変数kinputdataが1行レコードを更新する為のエンドポイントURLになります。recordであってrecordsじゃない点に注意。
- UserForm2側の摘要欄(tekiyou)や承認フラグ(appflg）、レコードデータのID(tarrec)、現在選択されている行の番号(selerec)などをグローバル変数で格納します。
- line_check関数で行が選択されているかどうかを判定します。
- 今回は複数行まとめてではなく、1行単位で承認をする仕組みなので、1行以上選択して承認は出来ません。
- 完了日の日付はyyyy-mm-dd形式でなければなりません。
- 承認後は承認内容である承認列、完了日、摘要の内容をシートの該当の行に反映します。
- また、承認後その内容を元に、Outlookにてメールを送るコードが入っています。その際に摘要欄は改行コードを<br>に変更しています（HTMLメールで送っているため）
- kintonePutData関数が、kintone側のレコードを更新する関数になります。
- 更新するデータはJSONで組み立てて、JsonConverter.ConvertToJsonにてJSON化したものをPUTメソッドにて送信します。
- JSONはrecordキーだけが複数のkeyの値を持っている状態にする必要があります。
- 承認でステータスが200が返ってくれば、trueとして、そうでなければfalseとしてflagmanで返す。この返り値を元にメインルーチンでシート書き込みやメール送信を行います。
- シートでは承認された場合は灰色、却下された場合は赤色でレコードが色分けされるように、条件付き書式設定を行っています。
{
"app":418,
"id":6,
"record":{
"承認":{
"value":"承認フラグがここに入る"
},
"摘要":{
"value":"摘要欄の文字列がここに入る"
},
"完了日":{
"value":"2020-03-16"
}
}
}
図：承認用のJSONは上記のようなスタイルで構築する
図：承認されると灰色にレコードが変色する
データの新規追加
本来今回のケースの場合、kintone側へデータをExcel側から入れる予定はなかったのですが、これだけやらないというのも気持ち悪いのと、他で流用できるので、ついでに装備することにしました。新規入力用フォームを用意し、尚且新規追加用のコードを用意する必要があります。追加用コードは、更新用コードと殆ど同じ形式なので
新規追加フォーム側コード
フォーム側では主にプルダウンメニューの動的生成およびDTPickerを呼び出すクラスの初期化などを行っています。また、新規追加ボタンのアクションにつても記述しております。
Option Explicit Private DTPCBox2 As clsDTPickerOnCombo3 '新規追加ボタンクリック時 Private Sub CommandButton1_Click() '入力値のvalidationを行う Dim validata As Variant Dim ret As Variant '依頼日を生成する Dim iraibi As String iraibi = Format(Date, "yyyy-mm-dd") dataArray(0) = iraibi '品目名について validata = hinmoku.Value If validata = "" Or validata = "品目名を選択してください" Then MsgBox "品目名が選択されていませんよ" hinmoku.SetFocus Exit Sub Else dataArray(1) = validata End If '品名について validata = hinmei.Value If validata = "" Or validata = "品名を選択してください" Then MsgBox "品名が選択されていませんよ" hinmei.SetFocus Exit Sub Else dataArray(2) = validata End If '数量について validata = StrConv(suryou.Value, vbNarrow) If validata = "" Or validata = 0 Then MsgBox "数量が入っていません" suryou.SetFocus Exit Sub Else '入力値が数値かどうか判定 If IsNumeric(validata) Then dataArray(3) = validata Else MsgBox "数値じゃない値が入っていますよ" suryou.SetFocus Exit Sub End If End If '希望日について validata = DTPCBox2.Value dataArray(4) = Replace(validata, "/", "-") 'コードについて validata = StrConv(pjcode.Value, vbNarrow) If validata = "" Then MsgBox "コードが入っていませんよ" pjcode.SetFocus Exit Sub Else dataArray(5) = validata End If '担当者について validata = tantou.Value If validata = "" Then MsgBox "担当者名が入っていませんよ" tantou.SetFocus Exit Sub Else dataArray(6) = validata End If 'メールアドレスについて validata = StrConv(mail.Value, vbNarrow) If validata = "" Then MsgBox "メールアドレスが入っていませんよ" mail.SetFocus Exit Sub Else '有効なメールアドレス形式のチェック If chkMailAddress(validata) Then dataArray(7) = validata Else MsgBox "有効なメールアドレスの形式ではありません" mail.SetFocus Exit Sub End If End If '毎月の場合について validata = monthman.Value dataArray(8) = validata '使用用途について validata = youto.Value If validata = "" Then MsgBox "使用用途が入っていませんよ" youto.SetFocus Exit Sub Else dataArray(9) = validata End If 'kintone側へデータをインサート ret = kintoneInsert() 'retの値によって、処理を分岐 If ret = True Then 'データを再取得する Call kintoneGetdata 'UserForm3をアンロード Unload UserForm3 Else '追加失敗してるので何もしない End If End Sub '品目名プルダウン選択時 Private Sub hinmoku_Change() 'ListIndexの値に応じて変更 Dim listnum As Integer listnum = hinmoku.ListIndex '品名プルダウンをクリアする hinmei.Clear '選択項目に応じて品名プルダウンを変更 Select Case listnum Case 0 '何もしない Case 1 'レターパックの品目にチェンジ With hinmei .AddItem "品名を選択してください" .AddItem "レターパックプラス" .AddItem "レターパックライト" End With '品名プルダウンの初期値 hinmei.ListIndex = 0 Case 2 '封筒の品目にチェンジ With hinmei .AddItem "品名を選択してください" .AddItem "角2" .AddItem "角2(のりつき)" .AddItem "角2(のりつき)" .AddItem "コピー用紙" .AddItem "コピー用紙(1箱)" .AddItem "長3(のりつき)" End With '品名プルダウンの初期値 hinmei.ListIndex = 0 Case 3 'レターパックの品目にチェンジ With hinmei .AddItem "品名を選択してください" .AddItem "ラベル" End With '品名プルダウンの初期値 hinmei.ListIndex = 0 End Select End Sub 'userformの初期化 Private Sub UserForm_Initialize() 'UserForm3にカレンダーをオーバーラップさせる Me.Top = UserForm3.Top + 50 Me.Left = UserForm3.Left + 50 '希望日のプルダウンにカレンダーを被せる Set DTPCBox2 = New clsDTPickerOnCombo3 With DTPCBox2 .Add kibou .Create Me, "yyyy/MM/dd(dddd)", DefaultFONT:=False '2:ComboBox部のみフォント変更 .CalendarBackColor(0) = &H99FFFF '(1)(2)一緒に設定 .CalendarTitleBackColor(0) = &H808000 ' 〃 .CalendarTrailingForeColor(0) = &H99FFFF ' 〃 '.Value(2) = DateValue(Date) End With '品目名プルダウンを初期化 With hinmoku If .Text = "" Then .AddItem "品目名を選択してください" .AddItem "レターパック" .AddItem "封筒" .AddItem "ラベル印刷" End If End With hinmoku.ListIndex = 0 End Sub Private Sub UserForm_Terminate() DTPCBox2.Destroy Set DTPCBox2 = Nothing End Sub 'メールアドレスの形式チェック Function chkMailAddress(mailaddress As Variant) As Boolean Dim ret As Boolean '// 関数戻り値 Dim reg As New RegExp '// 正規表現クラスオブジェクト '// 検索条件＝メールアドレス形式を抽出 reg.Pattern = "^.+@.+\..+$" '// 文字列の最後まで検索する reg.Global = True If reg.Test(mailaddress) = False Then chkMailAddress = False Exit Function End If chkMailAddress = True End Function
- initializeではkibouという名前の希望日プルダウン上にDTPickerを呼び出して被せています（kibouのプルダウンはダミーなので、値を取る時には、DTPCBox2.valueとしてこの場合取得します。
- 同じく、品目名のプルダウンの初期化を行い、初期値はListIndex = 0のものを指定しています。
- 品目名プルダウンを選択した時のchangeイベントにて品名プルダウンを生成し、初期値はListIndex = 0のものを指定しています。
- 新規追加ボタンでは各コントロールの値を取得・Validationを行い、グローバル配列であるdataArray()に追加しています。
- kintoneInsertを呼び出し、無事に追加が出来た場合には、kintoneGetdataを呼び出して最新のデータを取得させています。
- メールアドレスの形式チェックではこちらのサイトの関数を利用しています。
メインの追加用コード
データの新規追加は更新のコードと殆ど同じです。ただ、レコード番号の指定が無いだけですね。
'kintoneへレコードを追加する（単一レコード）
Public Function kintoneInsert() As Boolean
'変数の宣言
Dim appid As String
Dim access_token As String
Dim temptoken As String
Dim ret As Variant
'APP IDを取得する
appid = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"appid", _
REG_SZ, _
0)
'アクセストークンの期限切れチェック
actflg = checkExpireToken()
If actflg = False Then
'新しくトークンを取得し直す
ret = getNewToken()
'トークンが取得し直せたか判定
If ret = False Then
MsgBox "Access Tokenの再取得に失敗しました。再度認証し直してください。"
Exit Function
End If
End If
'アクセストークンを取り出す
temptoken = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"access_token", _
REG_SZ, _
0)
access_token = aes128decode(temptoken)
'リクエストデータを組み立て
Dim Json_St As String
Dim Json As New Scripting.Dictionary '外側のJSON用
Dim Rec_Json As New Scripting.Dictionary 'record用
'共通値を追加
Json.Add "app", CInt(appid) 'appIDを指定
'個別フィールド用
Dim json_iraibi As New Scripting.Dictionary '依頼日用
Dim json_hinmoku As New Scripting.Dictionary '品目名用
Dim json_hinmei As New Scripting.Dictionary '品名用
Dim json_suryou As New Scripting.Dictionary '数量用
Dim json_kibou As New Scripting.Dictionary '希望日用
Dim json_pjcode As New Scripting.Dictionary 'コード用
Dim json_tantou As New Scripting.Dictionary '担当者名用
Dim json_mail As New Scripting.Dictionary 'メアド用
Dim json_monthman As New Scripting.Dictionary '毎月の場合用
Dim json_youto As New Scripting.Dictionary '使用用途用
'各列のデータを生成して1レコード作る
json_iraibi.Add "value", dataArray(0)
json_hinmoku.Add "value", dataArray(1)
json_hinmei.Add "value", dataArray(2)
json_suryou.Add "value", dataArray(3)
json_kibou.Add "value", dataArray(4)
json_pjcode.Add "value", dataArray(5)
json_tantou.Add "value", dataArray(6)
json_mail.Add "value", dataArray(7)
json_monthman.Add "value", dataArray(8)
json_youto.Add "value", dataArray(9)
With Rec_Json
.Add "依頼日", json_iraibi
.Add "品目名", json_hinmoku
.Add "品名", json_hinmei
.Add "数量", json_suryou
.Add "希望日", json_kibou
.Add "コード", json_pjcode
.Add "担当者", json_tantou
.Add "メールアドレス", json_mail
.Add "毎月の場合", json_monthman
.Add "使用用途", json_youto
End With
'recordに塊を追加する
Json.Add "record", Rec_Json
'JSONに変換
Json_St = JsonConverter.ConvertToJson(Json)
'HTTPリクエスト
Dim http As New WinHttpRequest
Dim flagman As Boolean
With http
.Open "POST", kinputdata, False
.setProxy 2, proxyuri 'プロキシサーバのURLとポート番号
.setRequestHeader "Content-Type", "application/json"
.setRequestHeader "Authorization", "Bearer " & access_token
.Send Json_St
'ステータスを取得
Dim status As String
status = .status
Select Case .status
Case 200, 201
'JSON取得用
Dim doc, jsn, Jsonman
Dim tempjson, temprec, tempval
'HTMLDocumentを取得
Set doc = CreateObject("HtmlFile")
'scriptタグを追加
doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
'JSONデータを取得する
Jsonman = .responseText
'パース関数でJSONオブジェクトを取得
Set jsn = doc.JsonParse(Jsonman)
'レコード番号を取得する
recid = CallByName(jsn, "id", VbGet)
flagman = True
Case Else
MsgBox .status & "エラー。データの追加は失敗しました。"
flagman = False
End Select
End With
'値を返す
kintoneInsert = flagman
End Function
- レコードの塊はそれぞれの列用にDictionaryを用意し、valueをセット、Rec_Jsonに追加する形でJsonConverter.ConvertToJsonを行ってから、JSON形式に仕立てています。
- JSON化したデータを元に、WinHttpにてPOSTで通信をしています。
- 無事にデータが追加できたら、200が返ってくるので、flagmanにフラグを格納して返します。
- 今回はシンプルなフォームなのでこんなもんですが、checkboxなどの場合や、複数のレコードをまとめてバルクインサートなどはまたやり方が異なるので、難易度が上です。
- 組み立てたJSONは以下のような感じになります。
- Kintone側からの返り値をCallbyNameで取得すると、新規追加時に割り当てられたレコード番号を取得することが可能です。今回はこの値をrecidに格納しています。
{
"app":999,
"record":{
"依頼日":{
"value":"2020-03-18"
},
"品目名":{
"value":"ここに品目プルダウンの値"
},
"品名":{
"value":"ここに品名プルダウンの値"
},
：：：中略：：：
"毎月の場合":{
"value":"毎月使いたい場合のコメント"
},
"使用用途":{
"value":"使用用途について"
}
}
}
データの削除
Excel上でレコードの削除をしても、kintone上で削除されるわけじゃありません。ですので、レコード削除用のコマンドを用意し、それを持って削除をするようにしましょう。未処理のままの行をただExcel上で削除しても次回データ取得時に当然ですが復活してしまいますので、データの削除は必須です。kintoneの仕様上1度に削除できる件数は最大100件までです。
'kintoneからデータを削除するコマンド
Public Function kintoneDelete()
'現在アクティブになってるシート名を取得する
Dim activesheetman As String
activesheetman = ActiveSheet.Name
'// シートの入力範囲の全セルを取得
Dim rUsed As Range
Set rUsed = ActiveSheet.UsedRange
'行選択されているかどうかチェック
Dim lineman As Boolean
lineman = line_check()
If lineman = False Then
'行選択されていないので終了
MsgBox "行選択されていませんよ"
Exit Function
End If
'選択されている行数が2以上の場合終了
If Selection.Rows.Count >= 2 Then
MsgBox "一度に選択できる行数は1行だけです。"
Exit Function
End If
'選択されている行番号を取得する
Dim rng As Range
For Each rng In Selection.Rows
selerec = rng.Row
Next rng
'レコードデータIDを取得する
tarrec = rUsed(selerec, 1)
'レコードIDが空の場合終了
If tarrec = "" Then
MsgBox "有効な行が選択されていません。"
Exit Function
End If
'問い合わせを出す
Dim result As Variant
result = MsgBox("kintoneから『ID=" & tarrec & "』のデータを削除しますか？？", vbYesNo + vbDefaultButton2 + vbExclamation)
If result = vbYes Then
'インポート処理を続行する
Else
'メッセージを表示
MsgBox "処理をキャンセルしました。"
'終了処理
Exit Function
End If
'承認作業を実行
Dim ret As Boolean
ret = kintoneDelData()
'retの値によって、処理を分岐
If ret = True Then
'行を削除する
ThisWorkbook.Worksheets("kintone").Rows(selerec).Delete
'削除完了
MsgBox "データは削除されました。"
Else
'削除失敗してるので何もしない
End If
End Function
'レコード削除を担当する関数
Public Function kintoneDelData() As Boolean
'変数の宣言
Dim appid As String
Dim access_token As String
Dim temptoken As String
Dim ret As Variant
'APP IDを取得する
appid = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"appid", _
REG_SZ, _
0)
'アクセストークンの期限切れチェック
actflg = checkExpireToken()
If actflg = False Then
'新しくトークンを取得し直す
ret = getNewToken()
'トークンが取得し直せたか判定
If ret = False Then
MsgBox "Access Tokenの再取得に失敗しました。再度認証し直してください。"
Exit Function
End If
End If
'アクセストークンを取り出す
temptoken = RegGetValue(HKEY_CURRENT_USER, _
"Software\kintoneman" & _
"\Settings", _
"access_token", _
REG_SZ, _
0)
access_token = aes128decode(temptoken)
'リクエストURLを構築する
Dim requrl As String
requrl = kingetdata & "?app=" & appid & "&ids[0]=" & tarrec
'HTTPリクエスト
Dim http As New WinHttpRequest
Dim flagman As Boolean
'kintoneへデータをリクエスト
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "DELETE", requrl, False
.setProxy 2, proxyuri 'プロキシサーバのURLとポート番号
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Authorization", "Bearer " & access_token
.Send
'ステータスを取得
Dim status As String
status = .status
Select Case .status
Case 200, 201
flagman = True
Case Else
MsgBox .status & "エラー。削除は失敗しました。"
flagman = False
End Select
End With
'値を返す
kintoneDelData = flagman
End Function
- kingetdataのエンドポイントURLを使用します。
- 一括削除が出来ますが今回は1レコード削除にしてあります。複数行削除したい場合にはids配列を複数つなげればOKです（ids[0]=1&ids[1]=3といった具合に）
- idsに代入する値はレコードIDです。
- WinHttpで通信するときのメソッドは「DELETE」になります。
- 削除が成功すると200のステータスが返ってくるので、これを受信したら、Excelシート側の行をRows(レコード番号).Deleteで削除します。レコードのIDではなくレコード番号な点に注意。
- 次項にあるように、右クリックメニューから削除できるようにコマンドを追加しておくと非常に便利です
右クリックメニューにも承認ボタンを付ける
リボンにすでに承認用ボタンを付けているので、不要といえば不要なのですが、マウス操作では行選択=>即承認作業という流れでは、リボンまでの移動やボタンを選ぶ作業は地味にタイムロスやストレスになります。そこで、右クリックメニューにも承認用ボタンをつけてみます。起動時に自動的にメニューへ動的に追加します。
'リボン起動時に初期化するコード
Public Sub OnLoad(ribbon As IRibbonUI)
'リボンのインスタンスを取得
Set m_ribbon = ribbon
'自作のリボンをアクティブにする
m_ribbon.ActivateTab ("macroman")
'右クリックメニューを一時的に追加する
Dim approve
Set approve = Application.CommandBars("row").Controls.Add(Temporary:=True)
With approve
.Caption = "承認作業"
.OnAction = "kintoneApprove"
.BeginGroup = "False"
.FaceId = 2
End With
End Sub
- リボンのOnLoadイベントを今回は利用しています。Auto_OpenのサブプロシージャでもOK
- 今回は単一のボタン追加ですが、ネストするサブメニュー追加も可能です。また、ボタンの位置なども変更可能
- Temporary:=Trueは付けておいたほうが良いです。ブック終了時にメニューが消えます。でないと、次回起動時にもう一個メニューが追加されてしまうため
- Application.CommandBars("cell")でセルの右クリックメニューになります。今回は行選択なのでrowを指定しています。
- Application.CommandBars("row").Control("コマンド名").Deleteでメニューを削除可能。コマンド名はCaptionで指定した文字列です。
- faceidはアイコンです。番号で指定をします。こちらのサイトに対応表があるので、好きなアイコンを指定しましょう。
図：承認作業メニューが追加されました
関連リンク
- OAuth 2.0を使ってcybozu.comのREST APIをPostmanで叩く方法
- OAuthクライアントの使用
- Kintone Excel 連携 キントーン レコードの更新！ VBA マクロ
- Kintone Excel 連携 キントーン レコードの登録！ VBA マクロ
- kintone API レコード一括取得APIのoffsetの上限値制限について（2019/10/30更新）
- レコードの取得（GET）
- レコードの登録（POST）
- レコード削除（DELETE）
- レコードの登録（POST）
- offset の制限値を考慮したレコード一括取得について
- VBAからBox APIを叩いてみる – 実践編
- 右クリックメニューの変更（CommandBars）
- Excel VBAで指定した範囲の最大値・最小値を取得する：Max, Min
- REST APIのGET/recordsにおけるクエリの書き方のコツ【一覧の絞り込み条件を再利用する方法】
- ダブルコーテーションの表示
- クエリでユーザー選択フィールドが未入力のレコードを抽出する方法
- VBA 二次元配列
- 右クリックメニューに独自のコマンドを追加する
- 【エクセル時短】セルじゃなくて「行全体」の色を変えたい！ 条件付き書式を工夫して見やすくするワザ
- VBA 行を削除する
