2019年3月12日 / 最終更新日時 : 2021年12月30日 officeの杜 msoffice

VBAからBoard APIを使ってデータの入出力してみた

様々なクラウドシステムがあり、今登場しているこれらウェブサービスの殆どは、既存の業務アプリケーションと連携する為のREST APIを備えています。しかし、通常はこのAPIはサーバサイドからの連携を想定していて、ローカルアプリケーションからの連携を想定していません。例えば、PHPやNode.js、Javaなどを用いています。Google Apps Scriptもサーバサイドですね。

しかし、現実の企業では必ずしも連携元のアプリケーションがウェブアプリケーションとは限りません。むしろ活用する場合には、Excelから使うのがほとんどだと思われます。

今回、Boardと呼ばれるクラウドの案件・顧客管理のシステムを利用する機会があったので、Excelからデータの入出力を実装してみました。ExcelではJSONの扱いは苦手なのですが、今回はいつものようなJSON Parseするやり方ではなく、Callbyname関数を利用した取得法を使っています。

1 今回利用するファイル等
2 事前準備
- 2.1 APIトークンとAPIキーの取得
- 2.2 リクエスト制限
3 ソースコード
4 関連リンク

今回利用するファイル等

事前準備

APIトークンとAPIキーの取得

Board APIはよく見かけるOAuth2.0認証を利用した方法ではなく、あらかじめ用意しておいたAPIトークンとAPIキーの２つを送り付けることでAPIの操作を行う事が出来ます。以下にその取得手順を示します。

Boardにログインする
右上の歯車アイコンをクリックして「API設定」を開く
APIキーが表示されているので控えておく
新規トークン生成をクリックして、新しいAPIトークンを作成します。
用途説明を入力、このトークンへ与える権限をチェックして、登録ボタンを押します。権限は必要最低限にて。自分の場合、「顧客リストの取得」「案件の更新」「案件のリストの取得」の３つとしてます。
APIトークンは設定時の1度しか表示されませんので注意が必要です。この２つを控えておきます。VBA中で使用します。

図：Board API Token取得

リクエスト制限

API自体追加料金なしで利用は可能ですが、連続リクエストには制限があります。この制限を理解せずにコードを組んでしまうと、場合によっては制限を超えた分について処理されずにエラーとなってしまいます。上手に制限を回避するようにコードを書く必要があります。主な注意すべきリクエスト制限は以下の通りです。

１日3000リクエストまで。なるべく一発で処理できるようにAPIの利用回数には気を付ける必要があります。
3リクエスト/秒まで。但し、100リクエストまでは制限なく呼び出し可能。ただし、この100は全部で100であり、１回あたりではありません。よって、頻繁に3リクエスト/秒を超えるリクエストを投げてしまうと、この100を消費してしまいます。なるべく、１リクエストは3秒の間隔を守りましょう。
上記の100リクエストは一定期間利用されないと100まで補充される仕組みです。
リクエスト基準の1日は、UTC基準でありJSTでないので注意。
制限をオーバーすると、秒間リクエストを超えると429 - Too Many Requestsが返ってきます。１日の制限リクエストを超えるとLimit Exceededが返ってきます。エラー処理も実装しておくと良いでしょう。
データの取得などで、１回のリクエストで取得できる件数は最大100件まで。それを超えた場合、ページネーションされ、ページ指定を繰り返してデータを取得する必要があります。なるべく取得する範囲を絞ってリクエストを投げましょう。

ソースコード

データの取得

今回は、Boardの案件リストを取得してみます。但し、指定された日付以降のデータに限り取得するようにします。それでも結構な数になるのでページネーションされる可能性があるため、リクエスト制限回避の為に、1リクエスト毎に3秒間のsleepを入れています。

'BoardのベースURI
Const baseuri As String = "https://api.the-board.jp/v1/projects?"
Public Const patchurl As String = "https://api.the-board.jp/v1/projects/"

'プロキシURL
Const proxyuri As String = "ここにプロキシーのアドレスを入れる"

'sleep用
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)

'HTTP通信でBoard APIを使って、BoardDataを取得するコード
Public Function getWebStatus()
    '変数を宣言
    Dim Json As String
    Dim ret As String
    Dim url As String
    Dim tempArray As Variant
    Dim status As String
    Dim xmlHttp  As Object
    Dim JsonObject As Object, item As Object
    Dim strRes As Variant
    Dim cnt As Integer
    Dim dlength As Long
    Dim secflg As Boolean '部門名フラグ
    
    '日付処理用変数
    Dim nowdate As Date
    Dim yeardate As Integer
    Dim monthdate As Integer
    Dim daydate As Integer
    Dim seikyudate
    Dim setdate As String
    Dim startdate As Date
    
    '変数を初期化
    cnt = 1
    
    'JSONをパースする用の変数
    Dim doc
    
    '変数を宣言する
    Dim rc As Integer
    
    '実行前問い合わせをする
    rc = MsgBox("Boardからデータ取得開始日以降のデータを取得しますか？", vbYesNo + vbQuestion, "確認")
    If rc = vbYes Then
        'ここでは何もしない
    Else
        'プログラムの実行をキャンセルする
        MsgBox "実行はキャンセルされました。"
        Exit Function
    End If
    
    'dataシートの最終行を取得する
    'シートの最終列および最終行を取得する
    Dim lastrow As Long
    With ThisWorkbook.Worksheets("data").UsedRange
        lastrow = 2
    End With
    
    'シートをクリアする
    Dim kinfinal As Variant
    kinfinal = Worksheets("data").UsedRange.Rows.Count
    
    If kinfinal = 1 Then
        'タイトル行だけなので何もしない
    Else
        '2行目移行を削除する
        Worksheets("data").Range("A2:R" & kinfinal).Clear
    End If
    
    
    'URLを組み立てる
    startdate = ThisWorkbook.Worksheets("setting").Range("B2").Value
    nowdate = CDate(Format(startdate, "yyyy/mm/dd"))
    yeardate = Year(nowdate)
    monthdate = Month(nowdate)
    daydate = Day(nowdate)
    setdate = yeardate & "-" & monthdate & "-" & daydate
    
    '日付形式：2018-5-25
    Dim gtec As String
    gtec = "response_group=large&per_page=80&created_at_gteq="
    url = baseuri & gtec & setdate & "%2000:00:00"
    
    'JSON受信用
    'HTMLDocumentを取得
    Set doc = CreateObject("HtmlFile")
    'scriptタグを追加
    doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
    
    'Httpオブジェクトを設定
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    Dim totalcount As Variant
    
    'APIキーとTokenを取得
    Dim apikey As String
    Dim apitoken As String
    
    apikey = RegGetValue(HKEY_CURRENT_USER, _
            "Software\bd" & _
            "\Settings", _
            "key", _
            REG_SZ, _
            0)
            
    apitoken = RegGetValue(HKEY_CURRENT_USER, _
            "Software\bd" & _
            "\Settings", _
            "token", _
            REG_SZ, _
            0)
    
    'Headリクエストを発行する（件数を取得する）
    With xmlHttp
        .Open "HEAD", url, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Content-Type", "application/json"
        .setRequestHeader "Authorization", "Bearer " & apitoken
        .setRequestHeader "x-api-key", apikey
        .send
        
        totalcount = .GetResponseHeader("X-Total-Count")
    
    End With
    
    '回すべき最大ページ数を算出する
    Dim totalpage As Integer
    Dim pagecnt As Integer
    pagecnt = 1
    totalpage = Application.RoundUp(totalcount / 80, 0)

    'lookup用データの取得
    Dim MyArray, FlagArray
    Dim groupname As Variant
    Dim flagname As String
    Dim m_date As Date
    Dim fydate As Date
    Dim tempseikyu As Variant
    Dim gcode As Variant
    Dim knum As Variant  '管理番号

    'GETリクエストで実データを取得する（ページ数分）
    For j = 1 To totalpage
        'urlを書き換える
        Dim pageman As String
        pageman = "page=" & pagecnt & "&"
        url = baseuri & pageman & gtec & setdate & "%2000:00:00"
        Debug.Print url
        Dim FileName As String 'ファイル
        
        'リクエスト実行
        With xmlHttp
            .Open "GET", url, False
            .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .setRequestHeader "Content-Type", "application/json"
            .setRequestHeader "Authorization", "Bearer " & apitoken
            .setRequestHeader "x-api-key", apikey
            .send
            strRes = .responseText
            
            'JSONデータをファイルに出力
            FileName = ActiveWorkbook.Path & "\test" & pagecnt & ".txt"
            Open FileName For Output As #1
            Print #1, strRes
            Close #1

            'ステータス処理
            Select Case .status
                Case 200:
                    '通信成功してるのでオッケー
                    
                Case Else:
                    MsgBox "なんかエラーだって！！"
                    Exit Function
            End Select
            
        End With
    
        'JSONの中身を取り出す
        'パース関数でJSONオブジェクトを取得
        Set JsonObject = doc.JsonParse(strRes)
        
        '配列の件数を取得する
        dlength = CallByName(JsonObject, "length", VbGet)

        For i = 0 To dlength - 1
            '部門フラグ初期化
            secflg = True
            
            '個別データをまずは取り出す
            Set o = CallByName(JsonObject, i, VbGet)
            Set o2 = CallByName(o, "client", VbGet)
            
            '見積もり日を取得する(estimate_date)
            m_date = CDate(CallByName(o, "estimate_date", VbGet))
            
            '請求日付を取得する（ちょっと特殊な処理が必要）
            If Len(CallByName(o, "invoice_dates", VbGet)) = 10 Then
                '請求日付を格納する
                seikyudate = CDate(CallByName(o, "invoice_dates", VbGet))
            Else
                '請求日付が複数入ってるので1個目を取得する
                tempseikyu = Split(CStr(CallByName(o, "invoice_dates", VbGet)), ",")
                
                '1個目を取得して変換する
                seikyudate = CDate(tempseikyu(1))
            
            End If
            
            '会計期間開始日付
            fydate = CDate(Worksheets("setting").Range("B2").Value)
            
            '部門判定（特定グループのみをフィルタする）
            '人開は486702と486343を使用
            Dim filtergrp As Long
            filtergrp = 1111  'フィルタするグループIDを入れる
            
            gcode = CallByName(o, "group_id", VbGet)
            If gcode = filtergrp Then
                'trueなので取り込む
                secflg = True
            Else
                'falseなので取り込まない
                secflg = False
            End If
            
            '管理番号を成型する
            If IsNull(CallByName(o, "management_no", VbGet)) Then
                knum = "null"
            Else
                knum = Replace(CallByName(o, "management_no", VbGet), "-", "")
            End If

            
            '部門フラグがtrueの時だけ処理
            If secflg = True Then
                'オッケーなデータ
                '詳細データを取り出して書き込み
                Worksheets("data").Cells(lastrow, 1).Value = CallByName(o, "project_no", VbGet)
                Worksheets("data").Cells(lastrow, 2).Value = CallByName(o, "id", VbGet)
                Worksheets("data").Cells(lastrow, 3).Value = knum
                Worksheets("data").Cells(lastrow, 4).Value = CallByName(o, "name", VbGet)
                Worksheets("data").Cells(lastrow, 5).Value = CallByName(o2, "name", VbGet)
                Worksheets("data").Cells(lastrow, 6).Value = CallByName(o, "invoice_total", VbGet)
                Worksheets("data").Cells(lastrow, 7).Value = CLng(CallByName(o, "invoice_total", VbGet)) + CLng(CallByName(o, "invoice_tax", VbGet))
                Worksheets("data").Cells(lastrow, 8).Value = CallByName(o, "invoice_total", VbGet) - CallByName(o, "cost_total", VbGet)
                Worksheets("data").Cells(lastrow, 9).Value = CallByName(o, "estimate_date", VbGet)
                Worksheets("data").Cells(lastrow, 10).Value = CallByName(o, "delivery_date", VbGet)
                groupname = CallByName(o, "group_name", VbGet)
                Worksheets("data").Cells(lastrow, 11).Value = groupname
                Worksheets("data").Cells(lastrow, 12).Value = CallByName(o, "created_at", VbGet)
                Worksheets("data").Cells(lastrow, 13).Value = CallByName(o, "updated_at", VbGet)
                flagname = CallByName(o, "order_status_name", VbGet)
                Worksheets("data").Cells(lastrow, 15).Value = CallByName(o, "order_status_name", VbGet)
                Worksheets("data").Cells(lastrow, 17).Value = seikyudate
                Worksheets("data").Cells(lastrow, 18).Value = CallByName(o, "in_house_memo", VbGet)
                Worksheets("data").Cells(lastrow, 19).Value = CallByName(o, "group_id", VbGet)

                'lastrow値を更新する
                lastrow = lastrow + 1
            
            End If

        Next i
        
        'ページカウントをまわす
        pagecnt = pagecnt + 1
        
        '3秒間スリープさせる
        Sleep 3000
        
    Next j
    
    '終了メッセージ
    MsgBox setdate & "以降作成された" & totalcount & "件のデータを取得しました。"
    
    '終了処理
    Set JsonObject = Nothing
    Set xmlHttp = Nothing
    Set doc = Nothing
    
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

'BoardのベースURI

Const baseuri As String = "https://api.the-board.jp/v1/projects?"

Public Const patchurl As String = "https://api.the-board.jp/v1/projects/"

'プロキシURL

Const proxyuri As String = "ここにプロキシーのアドレスを入れる"

'sleep用

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)

'HTTP通信でBoard APIを使って、BoardDataを取得するコード

Public Function getWebStatus()

'変数を宣言

Dim Json As String

Dim ret As String

Dim url As String

Dim tempArray As Variant

Dim status As String

Dim xmlHttp As Object

Dim JsonObject As Object, item As Object

Dim strRes As Variant

Dim cnt As Integer

Dim dlength As Long

Dim secflg As Boolean '部門名フラグ

'日付処理用変数

Dim nowdate As Date

Dim yeardate As Integer

Dim monthdate As Integer

Dim daydate As Integer

Dim seikyudate

Dim setdate As String

Dim startdate As Date

'変数を初期化

cnt = 1

'JSONをパースする用の変数

Dim doc

'変数を宣言する

Dim rc As Integer

'実行前問い合わせをする

rc = MsgBox("Boardからデータ取得開始日以降のデータを取得しますか？", vbYesNo + vbQuestion, "確認")

If rc = vbYes Then

'ここでは何もしない

Else

'プログラムの実行をキャンセルする

MsgBox "実行はキャンセルされました。"

Exit Function

End If

'dataシートの最終行を取得する

'シートの最終列および最終行を取得する

Dim lastrow As Long

With ThisWorkbook.Worksheets("data").UsedRange

lastrow = 2

End With

'シートをクリアする

Dim kinfinal As Variant

kinfinal = Worksheets("data").UsedRange.Rows.Count

If kinfinal = 1 Then

'タイトル行だけなので何もしない

Else

'2行目移行を削除する

Worksheets("data").Range("A2:R" & kinfinal).Clear

End If

'URLを組み立てる

startdate = ThisWorkbook.Worksheets("setting").Range("B2").Value

nowdate = CDate(Format(startdate, "yyyy/mm/dd"))

yeardate = Year(nowdate)

monthdate = Month(nowdate)

daydate = Day(nowdate)

setdate = yeardate & "-" & monthdate & "-" & daydate

'日付形式：2018-5-25

Dim gtec As String

gtec = "response_group=large&per_page=80&created_at_gteq="

url = baseuri & gtec & setdate & "%2000:00:00"

'JSON受信用

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"

'Httpオブジェクトを設定

Set xmlHttp = CreateObject("MSXML2.XMLHTTP")

Dim totalcount As Variant

'APIキーとTokenを取得

Dim apikey As String

Dim apitoken As String

apikey = RegGetValue(HKEY_CURRENT_USER, _

"Software\bd" & _

"\Settings", _

"key", _

REG_SZ, _

apitoken = RegGetValue(HKEY_CURRENT_USER, _

"Software\bd" & _

"\Settings", _

"token", _

REG_SZ, _

'Headリクエストを発行する（件数を取得する）

With xmlHttp

.Open "HEAD", url, False

.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

.setRequestHeader "Content-Type", "application/json"

.setRequestHeader "Authorization", "Bearer " & apitoken

.setRequestHeader "x-api-key", apikey

.send

totalcount = .GetResponseHeader("X-Total-Count")

End With

'回すべき最大ページ数を算出する

Dim totalpage As Integer

Dim pagecnt As Integer

pagecnt = 1

totalpage = Application.RoundUp(totalcount / 80, 0)

'lookup用データの取得

Dim MyArray, FlagArray

Dim groupname As Variant

Dim flagname As String

Dim m_date As Date

Dim fydate As Date

Dim tempseikyu As Variant

Dim gcode As Variant

Dim knum As Variant '管理番号

'GETリクエストで実データを取得する（ページ数分）

For j = 1 To totalpage

'urlを書き換える

Dim pageman As String

pageman = "page=" & pagecnt & "&"

url = baseuri & pageman & gtec & setdate & "%2000:00:00"

Debug.Print url

Dim FileName As String 'ファイル

'リクエスト実行

With xmlHttp

.Open "GET", url, False

.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

.setRequestHeader "Content-Type", "application/json"

.setRequestHeader "Authorization", "Bearer " & apitoken

.setRequestHeader "x-api-key", apikey

.send

strRes = .responseText

'JSONデータをファイルに出力

FileName = ActiveWorkbook.Path & "\test" & pagecnt & ".txt"

Open FileName For Output As #1

Print #1, strRes

Close #1

'ステータス処理

Select Case .status

Case 200:

'通信成功してるのでオッケー

Case Else:

MsgBox "なんかエラーだって！！"

Exit Function

End Select

End With

'JSONの中身を取り出す

'パース関数でJSONオブジェクトを取得

Set JsonObject = doc.JsonParse(strRes)

'配列の件数を取得する

dlength = CallByName(JsonObject, "length", VbGet)

For i = 0 To dlength - 1

'部門フラグ初期化

secflg = True

'個別データをまずは取り出す

Set o = CallByName(JsonObject, i, VbGet)

Set o2 = CallByName(o, "client", VbGet)

'見積もり日を取得する(estimate_date)

m_date = CDate(CallByName(o, "estimate_date", VbGet))

'請求日付を取得する（ちょっと特殊な処理が必要）

If Len(CallByName(o, "invoice_dates", VbGet)) = 10 Then

'請求日付を格納する

seikyudate = CDate(CallByName(o, "invoice_dates", VbGet))

Else

'請求日付が複数入ってるので1個目を取得する

tempseikyu = Split(CStr(CallByName(o, "invoice_dates", VbGet)), ",")

'1個目を取得して変換する

seikyudate = CDate(tempseikyu(1))

End If

'会計期間開始日付

fydate = CDate(Worksheets("setting").Range("B2").Value)

'部門判定（特定グループのみをフィルタする）

'人開は486702と486343を使用

Dim filtergrp As Long

filtergrp = 1111 'フィルタするグループIDを入れる

gcode = CallByName(o, "group_id", VbGet)

If gcode = filtergrp Then

'trueなので取り込む

secflg = True

Else

'falseなので取り込まない

secflg = False

End If

'管理番号を成型する

If IsNull(CallByName(o, "management_no", VbGet)) Then

knum = "null"

Else

knum = Replace(CallByName(o, "management_no", VbGet), "-", "")

End If

'部門フラグがtrueの時だけ処理

If secflg = True Then

'オッケーなデータ

'詳細データを取り出して書き込み

Worksheets("data").Cells(lastrow, 1).Value = CallByName(o, "project_no", VbGet)

Worksheets("data").Cells(lastrow, 2).Value = CallByName(o, "id", VbGet)

Worksheets("data").Cells(lastrow, 3).Value = knum

Worksheets("data").Cells(lastrow, 4).Value = CallByName(o, "name", VbGet)

Worksheets("data").Cells(lastrow, 5).Value = CallByName(o2, "name", VbGet)

Worksheets("data").Cells(lastrow, 6).Value = CallByName(o, "invoice_total", VbGet)

Worksheets("data").Cells(lastrow, 7).Value = CLng(CallByName(o, "invoice_total", VbGet)) + CLng(CallByName(o, "invoice_tax", VbGet))

Worksheets("data").Cells(lastrow, 8).Value = CallByName(o, "invoice_total", VbGet) - CallByName(o, "cost_total", VbGet)

Worksheets("data").Cells(lastrow, 9).Value = CallByName(o, "estimate_date", VbGet)

Worksheets("data").Cells(lastrow, 10).Value = CallByName(o, "delivery_date", VbGet)

groupname = CallByName(o, "group_name", VbGet)

Worksheets("data").Cells(lastrow, 11).Value = groupname

Worksheets("data").Cells(lastrow, 12).Value = CallByName(o, "created_at", VbGet)

Worksheets("data").Cells(lastrow, 13).Value = CallByName(o, "updated_at", VbGet)

flagname = CallByName(o, "order_status_name", VbGet)

Worksheets("data").Cells(lastrow, 15).Value = CallByName(o, "order_status_name", VbGet)

Worksheets("data").Cells(lastrow, 17).Value = seikyudate

Worksheets("data").Cells(lastrow, 18).Value = CallByName(o, "in_house_memo", VbGet)

Worksheets("data").Cells(lastrow, 19).Value = CallByName(o, "group_id", VbGet)

'lastrow値を更新する

lastrow = lastrow + 1

End If

Next i

'ページカウントをまわす

pagecnt = pagecnt + 1

'3秒間スリープさせる

Sleep 3000

Next j

'終了メッセージ

MsgBox setdate & "以降作成された" & totalcount & "件のデータを取得しました。"

'終了処理

Set JsonObject = Nothing

Set xmlHttp = Nothing

Set doc = Nothing

End Function

会社での利用を想定しているので、WinHttpでリクエストを投げる時用にプロキシーのURL設定を加えています。ただし、取得側はそれが不要なxmlhttpで通信させています。データの更新側はWinhttpで記述しています。
APIキーやAPIトークンはレジストリに登録し呼び出す形にしている為、ワークブック内には記述しません。
dataシートは洗い替えで取得するので既存データは一旦全クリアされます。
いきなりデータを取得するのではなく、HEADリクエストでX-Total-Countの値を取得させています。
per_pageを80にしているので、変更したい場合には最大100まで指定できます。
取得したデータは一旦JSONを記述したtxtファイルとして書き出すようにしています。
JSONの最初のパースはVBA-JSONを利用しない方法をつかってパース取得しています。
個別のセクションは各々で、CallByName関数で値を取得する方法を利用しています。VBAで使うならこの方法がもっともベターかも。
途中部門判定をしていますが、この時CallByNameで指定してるgroup_idは表向き知る手段がありません。次項の注意点を参考に書き込み対象にしたいgroup_idを追記しましょう。
リクエスト制限対応の為、1ページ実行するごとに3秒間sleepを入れています。
ページカウント文だけリクエストを発行して完了です。

group_idの確認について

いわゆる部門毎に区分けした時に着けられるコードなのですが、Board上ではそれを確認する場所がありません。ゆえにそのままでは、全データ取得後全データがExcelに書き込まれてしまいます。特定部門だけに絞りたい場合、具合がよくありません。

このgroup_idですが、一旦この制限部分を取っ払って全データを取得します。すると、対象部門のgroup_idが何なのか？知ることが可能です。再び、制限を加えてこのコードで比較してフィルターすると良いでしょう。

CallByName関数について

通常、JavaScriptではJSON文字列を解析して値を取得する場合、hogehoge.data[1].personといったような形で取得ができます。しかし、VBAでも基本はこれでも取得できなくもないのですが、時として文字列がVBAの予約語とぶつかって勝手に大文字になったり（idなどは代表的）、データの取得上具合がよくありません。

そこで使う特殊な関数がCallByName関数。ただ使い方に癖があるので、JavaScriptのようにスムーズにはいきません。深い階層にあるデータは何度もCallByName関数を使って掘っていく必要があります。使う手順は以下のような感じ。

[
	{
		"id": 1,
		"project_no": 1001,
		"management_no": "123456",
		"name": "サンプル案件",
		"client": {
			"id": 1,
			"name": "サンプル株式会社",
			"name_disp": "サンプル"
		}
	},
	{
		"id": 2,
		"project_no": 1002,
		"management_no": "78910",
		"name": "とまと大好き",
		"client": {
			"id": 1,
			"name": "まるたねしゅびょう",
			"name_disp": "甘っこ"
		}
	}
]

[

{

"id": 1,

"project_no": 1001,

"management_no": "123456",

"name": "サンプル案件",

"client": {

"id": 1,

"name": "サンプル株式会社",

"name_disp": "サンプル"

}

{

"id": 2,

"project_no": 1002,

"management_no": "78910",

"name": "とまと大好き",

"client": {

"id": 1,

"name": "まるたねしゅびょう",

"name_disp": "甘っこ"

}

]

[]内に複数のレコードがJSON形式(jsonobjectという名前でパース済み)で含まれているのでまずはこのデータをobject型変数にCallByNameでセットする
その場合のコードは、Set o = CallByName(jsonobject, i, VbGet)となる。iは１個目,2個目などを指定する
このままでは、n個目の塊が取れただけなので、この塊の中からproject_noを取得してみる。String型変数に格納してみる。
その場合のコードは strpjnum = CallByName(o, "project_no", VbGet)となる。
さらに深い階層であるclient内の値を取得したい場合は、さらにCallByNameで処理してから同様に値を取り出すことになる。

JavaScriptのようにチェーンで取得できないのは不便ですが、この手法があるからこそVBAでJSONを取り扱えます。もちろん、VBA-JSONを使ったほうがより楽に処理はできます。

データの更新

取得したデータには、その案件を特定できるIDが含まれています。このIDを利用して逆に、Board側にデータを追記してみたいと思います。今回は、Board側案件データの社内メモ欄（in_house_memo）にねじ込みたいと思います。

'プロジェクト案件毎の集計値をBoard側へPushする
Public Function setWebStatus()
    '変数を宣言
    Dim Json As String
    Dim ret As String
    Dim url As String
    Dim tempArray As Variant
    Dim status As String
    Dim xmlHttp  As Object
    Dim JsonObject As Object, item As Object
    Dim strRes As Variant
    Dim cnt As Integer
    Dim dlength As Long
    Dim secflg As Boolean '部門名フラグ
    
    '日付処理用変数
    Dim nowdate As Date
    Dim yeardate As Integer
    Dim monthdate As Integer
    Dim daydate As Integer
    Dim seikyudate
    Dim setdate As String
    Dim startdate As Date
    
    '変数を初期化
    cnt = 1
    
    '変数を宣言する
    Dim rc As Integer
    
    '実行前問い合わせをする
    rc = MsgBox("PJ集計値をもって、Board側へデータを併合しますか？", vbYesNo + vbQuestion, "確認")
    If rc = vbYes Then
        'ここでは何もしない
    Else
        'プログラムの実行をキャンセルする
        MsgBox "実行はキャンセルされました。"
        Exit Function
    End If
    
    'PJ集計値シートのデータ量を調べる
    Dim kinfinal As Variant
    Dim MyArray
    kinfinal = Worksheets("PJ集計").UsedRange.Rows.Count
    
    If kinfinal = 1 Then
        'タイトル行だけなので何もしない
        MsgBox "送るべき集計値がありません"
        Exit Function
    Else
        'データを取得する
        MyArray = Worksheets("PJ集計").Range("A2:B" & kinfinal)
    End If
    
    'Httpオブジェクトを設定
    Dim tempmemo As String
    Dim pushman As String
    tempmemo = ""

    'APIキーとTokenを取得
    Dim apikey As String
    Dim apitoken As String
    
    apikey = RegGetValue(HKEY_CURRENT_USER, _
            "Software\bd" & _
            "\Settings", _
            "key", _
            REG_SZ, _
            0)
            
    apitoken = RegGetValue(HKEY_CURRENT_USER, _
            "Software\bd" & _
            "\Settings", _
            "token", _
            REG_SZ, _
            0)
    
    
    'ループで回してPATCHでBoardに送り付ける
    For cnt = 1 To kinfinal - 1
        'メモデータを初期化
        tempmemo = ""
        pushman = ""
        
        '押し込むメモデータを生成
        tempmemo = "コスト：" & MyArray(cnt, 2)
        
        '送り込むURLを組み立て(案件ナンバーじゃなくIDで)
        pushman = patchurl & MyArray(cnt, 3)

        'リクエストパラメータ作成
        Set JsonObject = New Dictionary
        JsonObject.Add "in_house_memo", tempmemo
        
        'PATCHリクエスト
        With CreateObject("WinHttp.WinHttpRequest.5.1")
            .Open "PATCH", pushman, False
            .setProxy 2, proxyuri
            .setRequestHeader "Content-Type", "application/json"
            .setRequestHeader "Authorization", "Bearer " & apitoken
            .setRequestHeader "x-api-key", apikey
            .send JsonConverter.ConvertToJson(JsonObject)
    
            '返ってきた値をもとにデータを処理
            Select Case .status
                Case 200, 201
                    'レスポンスヘッダを取得
                    Debug.Print .GetAllResponseHeaders()
                    
                    '投稿結果
                    strResult = .responseText
                    
                    Debug.Print strResult
    
                Case Else
                    MsgBox .status & "エラーです。"
                    Exit Function
            End Select
        End With
        
        '3秒間スリープさせる
        Sleep 3000
    
    Next cnt
    
    '終了メッセージ
    MsgBox "Boardへデータをマージしました。再度Boardデータを取り込んでみてください。"
    
    '終了処理
    Set JsonObject = Nothing
    Set xmlHttp = Nothing
    Set doc = Nothing
    
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

'プロジェクト案件毎の集計値をBoard側へPushする

Public Function setWebStatus()

'変数を宣言

Dim Json As String

Dim ret As String

Dim url As String

Dim tempArray As Variant

Dim status As String

Dim xmlHttp As Object

Dim JsonObject As Object, item As Object

Dim strRes As Variant

Dim cnt As Integer

Dim dlength As Long

Dim secflg As Boolean '部門名フラグ

'日付処理用変数

Dim nowdate As Date

Dim yeardate As Integer

Dim monthdate As Integer

Dim daydate As Integer

Dim seikyudate

Dim setdate As String

Dim startdate As Date

'変数を初期化

cnt = 1

'変数を宣言する

Dim rc As Integer

'実行前問い合わせをする

rc = MsgBox("PJ集計値をもって、Board側へデータを併合しますか？", vbYesNo + vbQuestion, "確認")

If rc = vbYes Then

'ここでは何もしない

Else

'プログラムの実行をキャンセルする

MsgBox "実行はキャンセルされました。"

Exit Function

End If

'PJ集計値シートのデータ量を調べる

Dim kinfinal As Variant

Dim MyArray

kinfinal = Worksheets("PJ集計").UsedRange.Rows.Count

If kinfinal = 1 Then

'タイトル行だけなので何もしない

MsgBox "送るべき集計値がありません"

Exit Function

Else

'データを取得する

MyArray = Worksheets("PJ集計").Range("A2:B" & kinfinal)

End If

'Httpオブジェクトを設定

Dim tempmemo As String

Dim pushman As String

tempmemo = ""

'APIキーとTokenを取得

Dim apikey As String

Dim apitoken As String

apikey = RegGetValue(HKEY_CURRENT_USER, _

"Software\bd" & _

"\Settings", _

"key", _

REG_SZ, _

apitoken = RegGetValue(HKEY_CURRENT_USER, _

"Software\bd" & _

"\Settings", _

"token", _

REG_SZ, _

'ループで回してPATCHでBoardに送り付ける

For cnt = 1 To kinfinal - 1

'メモデータを初期化

tempmemo = ""

pushman = ""

'押し込むメモデータを生成

tempmemo = "コスト：" & MyArray(cnt, 2)

'送り込むURLを組み立て(案件ナンバーじゃなくIDで)

pushman = patchurl & MyArray(cnt, 3)

'リクエストパラメータ作成

Set JsonObject = New Dictionary

JsonObject.Add "in_house_memo", tempmemo

'PATCHリクエスト

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "PATCH", pushman, False

.setProxy 2, proxyuri

.setRequestHeader "Content-Type", "application/json"

.setRequestHeader "Authorization", "Bearer " & apitoken

.setRequestHeader "x-api-key", apikey

.send JsonConverter.ConvertToJson(JsonObject)

'返ってきた値をもとにデータを処理

Select Case .status

Case 200, 201

'レスポンスヘッダを取得

Debug.Print .GetAllResponseHeaders()

'投稿結果

strResult = .responseText

Debug.Print strResult

Case Else

MsgBox .status & "エラーです。"

Exit Function

End Select

End With

'3秒間スリープさせる

Sleep 3000

Next cnt

'終了メッセージ

MsgBox "Boardへデータをマージしました。再度Boardデータを取り込んでみてください。"

'終了処理

Set JsonObject = Nothing

Set xmlHttp = Nothing

Set doc = Nothing

End Function

PJ集計シートに案件No.、ねじ込む値、IDの３つを追記しておきます。IDを基準にデータを特定し送り込みます。
リクエストはまとめて送れないので、レコード単位で送ることになります。3リクエスト/秒の制限に掛からないようにsleepを加えています。
リクエスト用のURLにIDを追記してリクエストを行います。
リクエストメソッドはPATCHで行います。
送るデータはJSON形式にして送りつける必要がありますので、今回は素直にVBA-JSONを利用しています。その為、参照設定に「Microsoft Scripting Runtime」を追加しておく必要があります（Dictionaryで利用する為）。
Dictionaryで連想配列を作ってデータを構築後、ConvertToJsonにてJSONへ変換し、リクエスト送信します。
無事送信できれば、ステータスとして200が返ってくるので、これで完了です。実際にBoard上で該当の案件の社内メモを確認してみましょう。

APIキーとAPIトークン

前項のコード内にて、APIキーとAPIトークンを利用していますが、今回これらはコード内に記述していません。やはり、これらのキーを含めたままですと、セキュリティ的にはよろしくない（ファイルが流出時にトークンを悪用されてしまう）。そこで、これらの値はレジストリ内に格納し、登録したPCで呼び出して使う形にしたほうが、ナンボもマシです。

そこで今回のファイルにはUserFormを追加し、別途このフォーム上から登録してもらうようにコードを組んでいます。呼び出し側は直接レジストリから読みだします。以下にUserFormの送信コマンドのコードを記述します。

Private Sub CommandButton1_Click()
    '入力内容を取得する
    Dim apikey As String
    Dim apitoken As String
    Dim lRet As Variant
    
    apikey = Me.TextBox1.Value
    apitoken = Me.TextBox2.Value
    
    '入力内容でもってレジストリにデータを登録
    lRet = RegSetValue(HKEY_CURRENT_USER, _
           "Software\bd" & _
           "\Settings", _
           "key", _
           REG_SZ, _
           apikey)

    lRet = RegSetValue(HKEY_CURRENT_USER, _
           "Software\bd" & _
           "\Settings", _
           "token", _
           REG_SZ, _
           apitoken)
    
    'フォームを閉じる
    DoCmd.Close acForm, Me.Name
    
End Sub

Private Sub CommandButton1_Click()

'入力内容を取得する

Dim apikey As String

Dim apitoken As String

Dim lRet As Variant

apikey = Me.TextBox1.Value

apitoken = Me.TextBox2.Value

'入力内容でもってレジストリにデータを登録

lRet = RegSetValue(HKEY_CURRENT_USER, _

"Software\bd" & _

"\Settings", _

"key", _

REG_SZ, _

apikey)

lRet = RegSetValue(HKEY_CURRENT_USER, _

"Software\bd" & _

"\Settings", _

"token", _

REG_SZ, _

apitoken)

'フォームを閉じる

DoCmd.Close acForm, Me.Name

End Sub

非常に単純なコードで、別途導入済みのレジストリ読み書きのモジュールを使って、レジストリ内に値を格納しています。但し、パスワード入力欄は＊印で表示されるよう加工していないので、実用時にはここをどうにかしておいたほうが良いでしょう。

図：適当に作った登録画面

VBAからBoard APIを使ってデータの入出力してみた

今回利用するファイル等

事前準備

APIトークンとAPIキーの取得

リクエスト制限

ソースコード

データの取得

group_idの確認について

CallByName関数について

データの更新

APIキーとAPIトークン

関連リンク

コメントを残すコメントをキャンセル

Google Apps Scriptで差し込み印刷的な何か【GAS】

Macbook Air Mid 2013のSSDをNVMeに交換してみた

今回利用するファイル等

事前準備

APIトークンとAPIキーの取得

リクエスト制限

ソースコード

データの取得

group_idの確認について

CallByName関数について

データの更新

APIキーとAPIトークン

関連リンク

コメントを残す コメントをキャンセル

Google Apps Scriptで差し込み印刷的な何か【GAS】

Macbook Air Mid 2013のSSDをNVMeに交換してみた

コメントを残すコメントをキャンセル