2019年1月12日 / 最終更新日時 : 2024年1月12日 officeの杜 Google

Google Apps ScriptとAccessデータベースを連携させる【GAS】

Google Apps Scriptを使うようになってから、クライアントサイドでAccessを使う機会は大分減りましたが、それでもAccess需要がゼロになるという事はありません。まだまだクラウドのデータベースサービスは高価であり、おいそれとクエリを投げようものなら翌月の請求書金額は怖いものになります。また、複雑な計算やクエリを組んでとなると、Accessのほうがまだまだ作りやすく、何よりもレポート機能が強力で価格が安いので、手放せません。

そんなAccessですが、Googleスプレッドシートと連携出来たらより一層利便性が向上し、既存のGoogle Apps Scriptのプログラムと連携出来たらいいなと思い、色々調査してみました。Google Apps Script APIが使えそうなので、これを使ってみて実装をしてみました。

※今回は、スプレッドシートのデータの読み書きですが、Google Apps Script APIを使ってるのでGAS側でコードを書き足せばメールの送信やカレンダーの登録、ドライブの操作、その他GASで可能な事が全てAccess側から実行可能になります。

今回使用するシートやメソッド類,参照設定,ライブラリ

今回使用するスプレッドシート
今回使用するAccessデータベース
Google Apps Script API
Microsoft WinHTTP Services
Microsoft ScriptControl
Microsoft Scripting Runtime (VBA-JSONで使用する)
VBA-JSON (サンプルに入ってるのはv2.3.0)

※今回使用するAccessデータベースは、32bit版と64bit版の2つが入っています。

新方式が登場しました

IE11の廃止に伴い、SeleniumやNode.jsやらといった手段を使わず、またPuppeteerと同様の手法（CDPを叩く）でVBAとEdge/ChromeのみでOAuth2.0認証する手段が登場しました。スクレイピングも可能になっています。以下のエントリーを参考にしてみてください。この手法は最も制限が無く、もっともすぐれた選択肢になると思います。

VBAでOAuth2.0認証 - 新方式を試してみた

IE11を使わない認証対応版

IE11廃止に伴い、本ページの認証部分については、IE11を使わない認証方法を利用する必要があります。この部分について、対応版を作成しました。以下のエントリーを参考に、Puppeteerを使った認証を利用すると、2022年6月以降も、VBAでGoogle API認証が可能になります。

VBAからGoogle APIを叩いてみる – IE11廃止対応版

事前準備とソースコード

Google Apps Script側の準備

今回のスクリプトは以下の２つを実装する必要性があります。また、今回はGoogle Apps Script APIを用いてデータの入出力を行いますので、事前にGoogle Cloud ConsoleにてクライアントIDを作っておく必要があります。

スプレッドシートのデータを取得してJSON加工して返す
Access側からのデータをJSONにて取得してスプレッドシートに反映する

プロジェクトを移動

今回の発表直前の2019年4月8日より、Google Apps ScriptからCloud Platform Projectへ直接アクセスが出来なくなりました。これまでにデプロイしてるものについては、これまで通り「リソース」⇒「Google Cloud Platform API ダッシュボード」からアクセスが可能です。

今回の変更はスプレッドシート上で動かすスクリプトやGoogleの拡張サービスを利用しないタイプのスクリプトであれば特に問題はありませんが、「Apps Script API」や「Google Picker API」、「Cloud SQL接続」などGCP上のAPIを利用する場合には以下の手順を踏んで、Google Apps Scriptにプロジェクトを連結する必要があります。これまでは、自動的にGCP上にGoogle Apps Script用のプロジェクトが生成されていたのですが、今後は自分の組織（もしくはGCPプロジェクト）上で作成されたプロジェクトでなければならないということです。詳細はこちらのページを見てください。

連結する手順は以下の通り

Google Cloud Consoleを開く
左上にある▼をクリックする
ダイアログが出てくるので、新規プロジェクトを作るか？既存のプロジェクトを選択する。この時、G Suiteであれば選択元は「自分のドメイン」を選択する必要があります。
プロジェクト情報パネルから「プロジェクト番号」をコピーする
対象のGoogle Apps Scriptのスクリプトエディタを開く
「リソース」⇒「Cloud Platform プロジェクト」を開く
4.で入手した番号をプロジェクトを変更のテキストボックスに入れて、プロジェクトを設定ボタンをクリックする
無事に移動が完了すればメッセージが表示されます。
この時、元の自動作成されたプロジェクトはシャットダウンされて消えます。これで設定完了です。

今回のこの変更だと１つ作ったプロジェクトに集約する必要があるので、クォータについてプロジェクト毎のカウントだったので問題なかったものが、集約されることで、クォータに引っ掛かる可能性があります。

図：プロジェクト番号をコピーしておきます

図：プロジェクトを他のプロジェクトに紐付けしました。

図：GCPの拡張サービスを使うには手順が必要になった

Cloud Consoleでの作業

ここでは、クライアントIDとクライアントシークレットを取得します。また、Google Apps Script APIを有効にします。以下の手順で取得しましょう。今回使用するスプレッドシートを開いて作業を行います。

スクリプトエディタを開き、メニューから「リソース」⇒「Googleの拡張サービス」を開く
Google Cloud Platform API ダッシュボードのリンクを開く
APIを有効にするをクリックし、検索画面でApps Script APIを探す
「有効にする」をクリックする
次に左のパネルの「認証情報」をクリックする
認証情報を作成をクリックする
OAuthクライアントIDを選択する
クライアントIDの作成では、「その他」を選択する
作成ボタンを押すと、クライアントIDとクライアントシークレットが手に入るので控えておく。
Cloud Consoleを閉じ、スクリプトエディタの画面ではOKを押して閉じる

これで必要な情報の半分が手に入りました。この２つは大切なものなので、漏れたりしないように保存しておく必要があります。また、事前に一度、どのfunctionでも良いので実行して、承認をしておく必要があります。

図：Apps Script APIが今回の主役

図：クライアントID、シークレット取得しておきましょう。

実行可能APIとして導入

ここでは、スクリプトIDとスコープを取得します。同じくスクリプトエディタの画面で行います。以下の手順で手に入れます。

スクリプトエディタのメニューより、「公開」⇒「実行可能APIとして導入」をクリック
公開ボタンを押す。実行可能権限は通常は「自分のみ」でOK。外部に公開しても良い場合だけ、全員にする。この画面に出てるAPI IDは使用しません。
スクリプトエディタのメニューより、「ファイル」⇒「プロジェクトのプロパティ」を開く
情報タブ内の「スクリプトID」を控えておく
スコープタブ内のスコープを控えておく。Google Apps Scriptで使用したAPIによって変動するので、注意。今回は「https://www.googleapis.com/auth/spreadsheets」のみ

これで必要な情報が全て揃いました。これらの情報はAccess側で使用します。

図：実行可能APIとして導入をしないと使えません。

図：スクリプトIDを取得しておきましょう

ソースコード

データを出力するコード

Google Apps Script側のデータの出力用関数は非常にシンプルです。今回は特にフィルタをせずに全データをAccess側へとreturnするので、以下のようなコードになります。但し、取得データはJSON.stringifyで変換して渡しています。

//シートID
var gasheet = "ここにスプレッドシートのIDを入れる";
 
//シートデータを取得する
function dataget() {
  var sheet = SpreadsheetApp.openById(gasheet);
  var ss = sheet.getSheetByName("data").getRange("A2:F").getValues();
 
  return JSON.stringify(ss);
}

//シートID

var gasheet = "ここにスプレッドシートのIDを入れる";

//シートデータを取得する

function dataget() {

var sheet = SpreadsheetApp.openById(gasheet);

var ss = sheet.getSheetByName("data").getRange("A2:F").getValues();

return JSON.stringify(ss);

}

データを入力するコード

データ受け入れ側は少しだけ複雑です。今回はAccess側からJSON化したレコードデータとレコード件数を引数としてparamに入れていますので、これらを加工して、data2というシートにデータを書き込みします。

//シートID
var gasheet = "ここにスプレッドシートのIDを入れる";
 
//受け取ったデータをシートに書き込む
function dataset(jsons){
  try{
    //値をparseして引数を分解する
    var temp = JSON.parse(jsons);  
    var jsondata = temp[0];　　　　　//レコードデータ
    var length = temp[1] - 1;　　　　　　　　//レコード数
    
    //書き込み用配列を用意
    var array = [];
    
    //一時配列の用意とデータのpush
    for(var i = 0;i<length;i++){
      var temparray = [];
      var currentrec = jsondata[i];
      
      temparray.push(currentrec.recid);
      temparray.push(currentrec.dateman);
      temparray.push(currentrec.itemman);
      temparray.push(currentrec.itemcnt);
      temparray.push(currentrec.tanka);
      temparray.push(currentrec.kingaku);
    
      array.push(temparray);
    
    }
    
    //配列データをスプレッドシートに書き込み
    var sheet = SpreadsheetApp.openById(gasheet);
    var ss = sheet.getSheetByName("data2");
    
    var endrow = Number(ss.getLastRow()) + 1;
    var lastColumn = array[0].length;　　//カラムの数を取得する
    var lastRow = array.length;  　　　　   //行の数を取得する
    ss.getRange(endrow,1,lastRow,lastColumn).setValues(array);
    
    //結果をリターンする
    return "OK";
  }catch(e){
    //エラーメッセージをリターンする
    return e.message;
  }
}

//シートID

var gasheet = "ここにスプレッドシートのIDを入れる";

//受け取ったデータをシートに書き込む

function dataset(jsons){

try{

//値をparseして引数を分解する

var temp = JSON.parse(jsons);

var jsondata = temp[0];　　　　　//レコードデータ

var length = temp[1] - 1;　　　　　　　　//レコード数

//書き込み用配列を用意

var array = [];

//一時配列の用意とデータのpush

for(var i = 0;i<length;i++){

var temparray = [];

var currentrec = jsondata[i];

temparray.push(currentrec.recid);

temparray.push(currentrec.dateman);

temparray.push(currentrec.itemman);

temparray.push(currentrec.itemcnt);

temparray.push(currentrec.tanka);

temparray.push(currentrec.kingaku);

array.push(temparray);

}

//配列データをスプレッドシートに書き込み

var sheet = SpreadsheetApp.openById(gasheet);

var ss = sheet.getSheetByName("data2");

var endrow = Number(ss.getLastRow()) + 1;

var lastColumn = array[0].length;　　//カラムの数を取得する

var lastRow = array.length; 　　　　 //行の数を取得する

ss.getRange(endrow,1,lastRow,lastColumn).setValues(array);

//結果をリターンする

return "OK";

}catch(e){

//エラーメッセージをリターンする

return e.message;

}

ポイント

データを取得して返すケースは非常に単純にJSON.stringifyしてデータを返すのみです。
データを受け取って書き込むケースでは、コード冒頭で配列から引数を分解しています。
書き込み用配列は２次元配列に組み上げて、JSON文字列から一つずつ値を取得し、pushしています。
データは一気に追記の形でdata2シートの最終行に書き込みをさせています。
最後にreturnでメッセージを返すのを忘れずに。
コードを変更したら、必ず実行可能APIとして導入を再度実行し、バージョンを変更して更新しましょう。これを行わないとコードが反映されません。

Accessデータベース側を準備する

データの取得やテーブルデータをPOST通信で送り込む仕組みが必要です。また、今回はデータにフィルタを掛けずに取得して、特定のIDを元に差分だけをマスターテーブルにインサートするようにしていますので、その為のクエリも必要です。今回は、Windows8.1 / Access2013で動作確認をしています。

※アーリーバインディングする場合には、参照設定よりMicrosoft Script ControlとMicrosoft WinHTTP Serviceをチェックしておく必要性があります。

図：参照設定する場合はチェックをいれておきましょう

テーブル構造とクエリ

今回のテーブル構造はシンプルです。Googleスプレッドシート側に合わせています。また、自分のテーブルデータとGoogleスプレッドシート側のデータの差分は、レコードIDを持って不一致クエリを実施し、インサートします。Googleスプレッドシート側のレコードIDは手動ではなく、なんらかのUIを持って自動的に割り当てするような仕組みにしておくと良いですね（今回は、GAS側のレコードIDは文字列を含めた文字列型のIDにしてあります。例：A001）。

よって、同じフィールドを持ったテーブル２個（１つはマスター、１つはGAS側のデータを受け入れるテンポラリ用）、不一致クエリ１個で作成します。また、Access_TokenとRefresh_Tokenを格納する隠しテーブルも用意しておきましょう。

※不一致クエリはそのままGAS側のデータ受け入れるテンポラリ用テーブルへの追加クエリに変更しておいて下さい。

図：テーブル設計はこんな感じ

図：不一致・追加クエリを作っておく

ソースコード

今回はこちらのサイトのコードを改造・修正して使っています。修正ポイントや改造ポイント他注意点等をポイントにまとめてあります。また、今回はJSONコードの取得の為にVBA-JSONを利用していますので、以下の作業が必要です。

VBA-JSONで配布されているJsonConverter.basをインポートしておく必要があります。
参照設定よりMicrosoft Scripting Runtimeをチェックしておく必要があります。
Google Apps Script側で取得したスクリプトID, クライアントID, クライアントシークレットを記述に追記しましょう

OAuth2.0認証するコード

Option Explicit
'--------------------------------------------------
'クライアントIDやシークレット等
'--------------------------------------------------
Private Const script_id As String = "ここにスクリプトIDを入れる"
Private Const client_id As String = "ここにクライアントIDを入れる"
Private Const client_secret As String = "ここにクライアントシークレットを入れる"
 
'--------------------------------------------------
'認証用文字列、スコープ、リダイレクトURI等
'--------------------------------------------------
Private Const response_type As String = "code"
Private Const redirect_uri As String = "urn:ietf:wg:oauth:2.0:oob"
Private Const grant_type As String = "authorization_code"
Private Const scope As String = "profile email https://www.googleapis.com/auth/spreadsheets"  '半角スペースで区切る
Private Const oauthurl As String = "https://accounts.google.com/o/oauth2/auth?"
Private Const tokenurl As String = "https://www.googleapis.com/oauth2/v4/token"
Private Const reftokenurl As String = "https://accounts.google.com/o/oauth2/token"
Private Const tokeninfo As String = "https://www.googleapis.com/oauth2/v3/tokeninfo?access_token="
 
'認証の実行とAccess_Token等の保存
Public Sub Authgoogle()
    Dim auth_code As String
    Dim tokenget As String
  
    'serverAuthCodeを取得
    auth_code = GetAuthorizationCode()
    
    'Access_Tokenを取得
    tokenget = GetAccessToken(auth_code)
    
    '取得結果を表示
    If tokenget = True Then
      MsgBox "認証が完了しました。"
    Else
      MsgBox "認証に失敗しました。"
    End If
    
End Sub
 
'Access_Tokenが期限切れかどうかをチェックする
Public Sub testTokenInfo()
    Call checkAccessToken
End Sub
 
'認証用serverAuthCodeの取得
Public Function GetAuthorizationCode() As String
  '各種変数の宣言
  Dim ie As Object
  Dim url As String
  Dim iptCode As Object
  Dim auth_code As String
  Const READYSTATE_COMPLETE = 4
  
  '初期化
  Set ie = Nothing
  Set iptCode = Nothing
  auth_code = ""
  
  'OAuth認証用URLの組み立て
  url = oauthurl & _
        "client_id=" & client_id & "&" & _
        "response_type=" & response_type & "&" & _
        "redirect_uri=" & redirect_uri & "&" & _
        "scope=" & EncodeURL(scope)
  'IEを起動し認証URLを開く
  Set ie = CreateObject("InternetExplorer.Application")
  With ie
    .Visible = True
    .AddressBar = False
    .MenuBar = False
    .StatusBar = False
    .Toolbar = False
    .Width = 600
    .Height = 480
    .Navigate url
    
    '認証が実行されるまで待機
    While .Busy Or _
          .ReadyState <> READYSTATE_COMPLETE Or _
          InStr(LCase(.LocationURL), "https://accounts.google.com/o/oauth2/approval") < 1
      DoEvents
    Wend
    
    '認証が実行されたらserverAuthCodeを取得
    On Error Resume Next
    auth_code = .Document.getElementsByClassName("qBHUIf")(0).value
    
    'ログアウトさせる
    .Navigate "https://accounts.google.com/o/logout"
    While .Busy Or .ReadyState <> READYSTATE_COMPLETE
      DoEvents
    Wend
    .Quit
  End With
  
  '取得したserverAuthCodeを返す
  GetAuthorizationCode = auth_code
End Function
 
'Access_Token他を取得するコード
Private Function GetAccessToken(ByVal auth_code As String) As Boolean
  Dim access_token As String
  Dim json As String
  Dim dat As Variant
  Dim jsonstr As Object
  Dim ret As Boolean
  
  Dim SQL As String
  Dim db As DAO.Database
  Dim RS As DAO.Recordset
  Set db = CurrentDb()
  Set RS = db.OpenRecordset("setting", dbOpenDynaset)
  
  access_token = "" '初期化
  
  'Access_Token取得用POST文字列の組み立て
  dat = "code=" & auth_code & "&" & _
        "client_id=" & client_id & "&" & _
        "client_secret=" & client_secret & "&" & _
        "redirect_uri=" & redirect_uri & "&" & _
        "grant_type=" & grant_type & "&" & _
        "&access_type=offline"
        
  'POST通信でAccess Token等をリクエスト
  With CreateObject("WinHttp.WinHttpRequest.5.1")
    .Open "POST", tokenurl, False
    .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
    .Send dat
    If .status = 200 Then
      '返ってきたJSON文字列を取得
      json = .ResponseText
      If Len(Trim(json)) > 0 Then
        'JSON文字列より各種値を取得・保存
        Set jsonstr = JsonConverter.ParseJson(json)
        access_token = jsonstr("access_token")
        
        'tokenをsettingテーブルに保存
        With RS
          .FindFirst "ID=1"
          .Edit
          !access_token = jsonstr("access_token")
          !refresh_token = jsonstr("refresh_token")
          .Update
        End With
        
        ret = True
      Else
        ret = False
      End If
    Else
      ret = False
    End If
  End With
  
  '終了処理
  RS.Close: Set RS = Nothing
  db.Close: Set db = Nothing
 
  '値を返す
　　　GetAccessToken　= ret
End Function
 
'Access_Tokenをチェックし、refresh_tokenで新しいAccess_Tokenを取得する関数
Public Function checkAccessToken() As Boolean
  Dim access_token As String
  Dim refresh_token As String
  Dim json As String
  Dim dat As Variant
  Dim jsonstr As Object
  Dim ngflag As Boolean
  Dim xmlHttp  As Object
  Dim url As String
  Dim strRes As String
  Dim status As String
  Dim expirein As Integer
  
  Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
  
  Dim SQL As String
  Dim db As DAO.Database
  Dim RS As DAO.Recordset
  Set db = CurrentDb()
  Set RS = db.OpenRecordset("setting", dbOpenDynaset)
  
  '取得済みAccess_Token類を呼び出す
  With RS
    .FindFirst "ID=1"
    access_token = !access_token
    refresh_token = !refresh_token
  End With
 
  'Access_Tokenを'tokeninfoでexpireしてるかチェック
  url = tokeninfo & access_token
  With xmlHttp
    .Open "GET", url, False
    .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
    .Send
    strRes = .ResponseText
    status = .status
  End With
 
  If status = 200 Then
    'expireしていなければ200が返ってくる
    
    'expires_inが60以下ならrefreshしてしまう
    Set jsonstr = JsonConverter.ParseJson(strRes)
    expirein = CInt(jsonstr("expires_in"))
    
    If expirein <= 60 Then
      ngflag = True
    Else
      ngflag = False
    End If
    
  Else
    'expireしてると400が返ってくる
    ngflag = True
  End If
    
  'ngflagをもとにrefresh_Tokenを使って新しいtokenを取得する
  If ngflag = True Then
    'refresh_TokenでPOSTするパラメータを組み立て
    dat = "client_id=" & client_id & "&" & _
        "client_secret=" & client_secret & "&" & _
        "grant_type=refresh_token" & _
        "&refresh_token=" & refresh_token
 
    'POSTで新しいAccess_Tokenを取得する
    With xmlHttp
      .Open "POST", reftokenurl, False
      .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
      .Send (dat)
      strRes = .ResponseText
      status = .status
    End With
 
    '新しく取得したAccess_Tokenを格納する
    If status = 200 Then
      Set jsonstr = JsonConverter.ParseJson(strRes)
      access_token = jsonstr("access_token")
    
      With RS
        .FindFirst "ID=1"
        .Edit
        !access_token = access_token
        .Update
      End With
      
      ngflag = False
    Else
      ngflag = True
    End If
 
  End If
 
  '終了処理
  Set xmlHttp = Nothing
  RS.Close: Set RS = Nothing
  db.Close: Set db = Nothing
  
  '値を返す
  checkAccessToken = ngflag
 
End Function
 
'URLエンコードする為の関数
Public Function EncodeURL(value As String) As String
    Dim script As Object
    Dim js As Object
    
    Set script = CreateObject("ScriptControl")
    script.Language = "JavaScript"
    Set js = script.CodeObject
    EncodeURL = js.encodeURIComponent(value)
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

Option Explicit

'--------------------------------------------------

'クライアントIDやシークレット等

'--------------------------------------------------

Private Const script_id As String = "ここにスクリプトIDを入れる"

Private Const client_id As String = "ここにクライアントIDを入れる"

Private Const client_secret As String = "ここにクライアントシークレットを入れる"

'--------------------------------------------------

'認証用文字列、スコープ、リダイレクトURI等

'--------------------------------------------------

Private Const response_type As String = "code"

Private Const redirect_uri As String = "urn:ietf:wg:oauth:2.0:oob"

Private Const grant_type As String = "authorization_code"

Private Const scope As String = "profile email https://www.googleapis.com/auth/spreadsheets" '半角スペースで区切る

Private Const oauthurl As String = "https://accounts.google.com/o/oauth2/auth?"

Private Const tokenurl As String = "https://www.googleapis.com/oauth2/v4/token"

Private Const reftokenurl As String = "https://accounts.google.com/o/oauth2/token"

Private Const tokeninfo As String = "https://www.googleapis.com/oauth2/v3/tokeninfo?access_token="

'認証の実行とAccess_Token等の保存

Public Sub Authgoogle()

Dim auth_code As String

Dim tokenget As String

'serverAuthCodeを取得

auth_code = GetAuthorizationCode()

'Access_Tokenを取得

tokenget = GetAccessToken(auth_code)

'取得結果を表示

If tokenget = True Then

MsgBox "認証が完了しました。"

Else

MsgBox "認証に失敗しました。"

End If

End Sub

'Access_Tokenが期限切れかどうかをチェックする

Public Sub testTokenInfo()

Call checkAccessToken

End Sub

'認証用serverAuthCodeの取得

Public Function GetAuthorizationCode() As String

'各種変数の宣言

Dim ie As Object

Dim url As String

Dim iptCode As Object

Dim auth_code As String

Const READYSTATE_COMPLETE = 4

'初期化

Set ie = Nothing

Set iptCode = Nothing

auth_code = ""

'OAuth認証用URLの組み立て

url = oauthurl & _

"client_id=" & client_id & "&" & _

"response_type=" & response_type & "&" & _

"redirect_uri=" & redirect_uri & "&" & _

"scope=" & EncodeURL(scope)

'IEを起動し認証URLを開く

Set ie = CreateObject("InternetExplorer.Application")

With ie

.Visible = True

.AddressBar = False

.MenuBar = False

.StatusBar = False

.Toolbar = False

.Width = 600

.Height = 480

.Navigate url

'認証が実行されるまで待機

While .Busy Or _

.ReadyState <> READYSTATE_COMPLETE Or _

InStr(LCase(.LocationURL), "https://accounts.google.com/o/oauth2/approval") < 1

DoEvents

Wend

'認証が実行されたらserverAuthCodeを取得

On Error Resume Next

auth_code = .Document.getElementsByClassName("qBHUIf")(0).value

'ログアウトさせる

.Navigate "https://accounts.google.com/o/logout"

While .Busy Or .ReadyState <> READYSTATE_COMPLETE

DoEvents

Wend

.Quit

End With

'取得したserverAuthCodeを返す

GetAuthorizationCode = auth_code

End Function

'Access_Token他を取得するコード

Private Function GetAccessToken(ByVal auth_code As String) As Boolean

Dim access_token As String

Dim json As String

Dim dat As Variant

Dim jsonstr As Object

Dim ret As Boolean

Dim SQL As String

Dim db As DAO.Database

Dim RS As DAO.Recordset

Set db = CurrentDb()

Set RS = db.OpenRecordset("setting", dbOpenDynaset)

access_token = "" '初期化

'Access_Token取得用POST文字列の組み立て

dat = "code=" & auth_code & "&" & _

"client_id=" & client_id & "&" & _

"client_secret=" & client_secret & "&" & _

"redirect_uri=" & redirect_uri & "&" & _

"grant_type=" & grant_type & "&" & _

"&access_type=offline"

'POST通信でAccess Token等をリクエスト

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "POST", tokenurl, False

.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"

.Send dat

If .status = 200 Then

'返ってきたJSON文字列を取得

json = .ResponseText

If Len(Trim(json)) > 0 Then

'JSON文字列より各種値を取得・保存

Set jsonstr = JsonConverter.ParseJson(json)

access_token = jsonstr("access_token")

'tokenをsettingテーブルに保存

With RS

.FindFirst "ID=1"

.Edit

!access_token = jsonstr("access_token")

!refresh_token = jsonstr("refresh_token")

.Update

End With

ret = True

Else

ret = False

End If

Else

ret = False

End If

End With

'終了処理

RS.Close: Set RS = Nothing

db.Close: Set db = Nothing

'値を返す

　　　GetAccessToken　= ret

End Function

'Access_Tokenをチェックし、refresh_tokenで新しいAccess_Tokenを取得する関数

Public Function checkAccessToken() As Boolean

Dim access_token As String

Dim refresh_token As String

Dim json As String

Dim dat As Variant

Dim jsonstr As Object

Dim ngflag As Boolean

Dim xmlHttp As Object

Dim url As String

Dim strRes As String

Dim status As String

Dim expirein As Integer

Set xmlHttp = CreateObject("MSXML2.XMLHTTP")

Dim SQL As String

Dim db As DAO.Database

Dim RS As DAO.Recordset

Set db = CurrentDb()

Set RS = db.OpenRecordset("setting", dbOpenDynaset)

'取得済みAccess_Token類を呼び出す

With RS

.FindFirst "ID=1"

access_token = !access_token

refresh_token = !refresh_token

End With

'Access_Tokenを'tokeninfoでexpireしてるかチェック

url = tokeninfo & access_token

With xmlHttp

.Open "GET", url, False

.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"

.Send

strRes = .ResponseText

status = .status

End With

If status = 200 Then

'expireしていなければ200が返ってくる

'expires_inが60以下ならrefreshしてしまう

Set jsonstr = JsonConverter.ParseJson(strRes)

expirein = CInt(jsonstr("expires_in"))

If expirein <= 60 Then

ngflag = True

Else

ngflag = False

End If

Else

'expireしてると400が返ってくる

ngflag = True

End If

'ngflagをもとにrefresh_Tokenを使って新しいtokenを取得する

If ngflag = True Then

'refresh_TokenでPOSTするパラメータを組み立て

dat = "client_id=" & client_id & "&" & _

"client_secret=" & client_secret & "&" & _

"grant_type=refresh_token" & _

"&refresh_token=" & refresh_token

'POSTで新しいAccess_Tokenを取得する

With xmlHttp

.Open "POST", reftokenurl, False

.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"

.Send (dat)

strRes = .ResponseText

status = .status

End With

'新しく取得したAccess_Tokenを格納する

If status = 200 Then

Set jsonstr = JsonConverter.ParseJson(strRes)

access_token = jsonstr("access_token")

With RS

.FindFirst "ID=1"

.Edit

!access_token = access_token

.Update

End With

ngflag = False

Else

ngflag = True

End If

'終了処理

Set xmlHttp = Nothing

RS.Close: Set RS = Nothing

db.Close: Set db = Nothing

'値を返す

checkAccessToken = ngflag

End Function

'URLエンコードする為の関数

Public Function EncodeURL(value As String) As String

Dim script As Object

Dim js As Object

Set script = CreateObject("ScriptControl")

script.Language = "JavaScript"

Set js = script.CodeObject

EncodeURL = js.encodeURIComponent(value)

End Function

Authgoogle()がメインのaccess_tokenを取得する為のコードです
testTokenInfo()が取得済みAccess Tokenがexpireしていないかどうかのチェックと、expireしてる場合のrefresh_tokenを使って、新しいaccess_tokenを取得するコードです。
データベース起動時にAutoexecマクロを使って、expireチェックをし、refreshしておくとスムーズにデータを取得したり、データを送信するルーチンに繋げられると思います。
2019年1月1日より、ブラウザ上で表示されるAuthrization Codeの取得の為の仕様が変更になっているため、旧来のgetElementById("code")でelement指定しても取れません。auth_code = .Document.getElementsByClassName("qBHUIf")(0).valueといった形でClassName指定で取得するようにしています。

図：認証を実行してみた

データを取得するコード

Google Apps Script側のdataget関数を叩いてスプレッドシートのデータを以下のような形で取り込みます。

dataget関数を実行してスプレッドシートのデータを取得
temp_gasテーブルにデータを流し込む
temp_gasとmasterテーブルの不一致分をmasterテーブルへと追加するクエリを実行

差分のみを追加するようにしています。今回parameterを使っていませんが、ここに例えば日付でフィルタをGAS側へ渡して、GAS側でそれに基いてフィルタして返して上げるのがもっとも良いやり取りの仕方だと思います。

'データを取得するルーチン
Public Sub getSheetData()
  '変数と定数の宣言
  Dim access_token As String
  Dim ret As String
  Dim param As String
  Dim js As New ScriptControl
  Dim ar As Object
  Dim alength As Variant
  Const function_name As String = "dataget" '実行するGAS関数名
  
  '変数の初期化
  param = ""
  js.Language = "JScript"
  
  'DAO関係の変数の宣言と初期化
  Dim SQL As String
  Dim db As DAO.Database
  Dim RS As DAO.Recordset
  Dim rst As DAO.Recordset
  
  Set db = CurrentDb()
  Set RS = db.OpenRecordset("setting", dbOpenDynaset)
  Set rst = db.OpenRecordset("temp_gas", dbOpenDynaset)
  
  '一時テーブルの中身をクリアする
  SQL = "DELETE * FROM temp_gas"
  db.Execute SQL
  
  '配列データ処理用
  Dim tempStr As Variant
  Dim tempArray As Variant
  
  'Access_Tokenのexpireチェック
  ret = checkAccessToken()
  
  If ret = False Then
    '取得済みAccess_Token類を呼び出す
    With RS
      .FindFirst "ID=1"
      access_token = !access_token
    End With
  Else
    'エラーメッセージを出して、再認証をする
    MsgBox "再認証が必要です。"
    Call Authgoogle
    Exit Sub
  End If
  
  'access_tokenを使ってデータを取得する
  ret = ExecuteGASFunction(access_token, script_id, function_name, param)
  
  If ret = "" Then
    MsgBox "データを取得できませんでした。"
    Exit Sub
  End If
  
  '取得したデータをscriptcontrolで処理をする
  Set ar = js.Eval(ret)
  Dim tempday As String
 
  For Each tempStr In ar
    'カンマ区切りを配列に変換
    tempArray = Split(tempStr, ",")
    
    '日付データを変換
    tempday = Mid(tempArray(1), 1, 4) & "/" & Mid(tempArray(1), 6, 2) & "/" & Mid(tempArray(1), 9, 2)
    
    '配列データをもとに新規レコード追加
    With rst
      .AddNew
      !レコードID = tempArray(0)
      !日付 = CDate(tempday)
      !商品名 = tempArray(2)
      !数量 = tempArray(3)
      !単価 = tempArray(4)
      !金額 = tempArray(5)
      .Update
    End With
  Next
  
  '追加クエリの実行
  DoCmd.OpenQuery "差分追加"
  
  '終了処理
  rst.Close: Set rst = Nothing
  RS.Close: Set RS = Nothing
  db.Close: Set db = Nothing
  Set js = Nothing
  
  MsgBox "データの取得が完了しました。"
End Sub
 
'Google Apps Script Execution APIを実行してシートデータを取得する
Private Function ExecuteGASFunction(ByVal access_token As String, _
                                    ByVal script_id As String, _
                                    ByVal function_name As String, _
                                    ByVal parameters As String, _
                                    Optional ByVal dev_mode As String = "false") As String
                                    
  'Google Apps Script Execution API呼び出し
  Dim ret As String
  Dim url As String
  Dim json As String
  Dim dat As Variant
  Dim jsonstr As Object
  
  '変数を初期化（parametersは使わない）
  ret = ""
  dat = "{'function':'" & function_name & "','parameters':'" & parameters & "','devMode':" & dev_mode & "}"
  url = "https://script.googleapis.com/v1/scripts/" & script_id & ":run"
  
  'POST通信でAPIを叩いてデータを取得
  With CreateObject("WinHttp.WinHttpRequest.5.1")
    .Open "POST", url, False
    .SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
    .SetRequestHeader "Authorization", "Bearer " & access_token
    '.setProxy 2, proxyuri
    .Send dat
    
    '返ってきた値をもとにデータを処理
    Select Case .status
      Case 200
        'JSONデータを取得する
        json = .ResponseText
        Set jsonstr = JsonConverter.ParseJson(json)
        ret = jsonstr("response")("result")
    End Select
  End With
  
  '値を返す
  ExecuteGASFunction = ret
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

'データを取得するルーチン

Public Sub getSheetData()

'変数と定数の宣言

Dim access_token As String

Dim ret As String

Dim param As String

Dim js As New ScriptControl

Dim ar As Object

Dim alength As Variant

Const function_name As String = "dataget" '実行するGAS関数名

'変数の初期化

param = ""

js.Language = "JScript"

'DAO関係の変数の宣言と初期化

Dim SQL As String

Dim db As DAO.Database

Dim RS As DAO.Recordset

Dim rst As DAO.Recordset

Set db = CurrentDb()

Set RS = db.OpenRecordset("setting", dbOpenDynaset)

Set rst = db.OpenRecordset("temp_gas", dbOpenDynaset)

'一時テーブルの中身をクリアする

SQL = "DELETE * FROM temp_gas"

db.Execute SQL

'配列データ処理用

Dim tempStr As Variant

Dim tempArray As Variant

'Access_Tokenのexpireチェック

ret = checkAccessToken()

If ret = False Then

'取得済みAccess_Token類を呼び出す

With RS

.FindFirst "ID=1"

access_token = !access_token

End With

Else

'エラーメッセージを出して、再認証をする

MsgBox "再認証が必要です。"

Call Authgoogle

Exit Sub

End If

'access_tokenを使ってデータを取得する

ret = ExecuteGASFunction(access_token, script_id, function_name, param)

If ret = "" Then

MsgBox "データを取得できませんでした。"

Exit Sub

End If

'取得したデータをscriptcontrolで処理をする

Set ar = js.Eval(ret)

Dim tempday As String

For Each tempStr In ar

'カンマ区切りを配列に変換

tempArray = Split(tempStr, ",")

'日付データを変換

tempday = Mid(tempArray(1), 1, 4) & "/" & Mid(tempArray(1), 6, 2) & "/" & Mid(tempArray(1), 9, 2)

'配列データをもとに新規レコード追加

With rst

.AddNew

!レコードID = tempArray(0)

!日付 = CDate(tempday)

!商品名 = tempArray(2)

!数量 = tempArray(3)

!単価 = tempArray(4)

!金額 = tempArray(5)

.Update

End With

'追加クエリの実行

DoCmd.OpenQuery "差分追加"

'終了処理

rst.Close: Set rst = Nothing

RS.Close: Set RS = Nothing

db.Close: Set db = Nothing

Set js = Nothing

MsgBox "データの取得が完了しました。"

End Sub

'Google Apps Script Execution APIを実行してシートデータを取得する

Private Function ExecuteGASFunction(ByVal access_token As String, _

ByVal script_id As String, _

ByVal function_name As String, _

ByVal parameters As String, _

Optional ByVal dev_mode As String = "false") As String

'Google Apps Script Execution API呼び出し

Dim ret As String

Dim url As String

Dim json As String

Dim dat As Variant

Dim jsonstr As Object

'変数を初期化（parametersは使わない）

ret = ""

dat = "{'function':'" & function_name & "','parameters':'" & parameters & "','devMode':" & dev_mode & "}"

url = "https://script.googleapis.com/v1/scripts/" & script_id & ":run"

'POST通信でAPIを叩いてデータを取得

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "POST", url, False

.SetRequestHeader "Content-Type", "application/json; charset=UTF-8"

.SetRequestHeader "Authorization", "Bearer " & access_token

'.setProxy 2, proxyuri

.Send dat

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

Select Case .status

Case 200

'JSONデータを取得する

json = .ResponseText

Set jsonstr = JsonConverter.ParseJson(json)

ret = jsonstr("response")("result")

End Select

End With

'値を返す

ExecuteGASFunction = ret

End Function

データを送信するコード

データの送信は、GAS側へJSON化したレコードデータと、レコード件数の２つをparametersに入れて送ります。JSONデータは手動で組み上げ、データの取得時にも使用したExecuteGASFunction関数に送っています。masterテーブルのデータをそのまま送っていますが、実際にはクエリなどでデータ数を絞ってから送るのがベストです。

'データを送信するルーチン
Public Sub setSheetData()
  '変数と定数の宣言
  Dim access_token As String
  Dim ret As String
  Dim param As String
  Dim jsondata As String
  Dim dlength As Integer
  Dim counter As Integer
  Const function_name As String = "dataset" '実行するGAS関数名
 
  'DAO関係の変数の宣言と初期化
  Dim SQL As String
  Dim db As DAO.Database
  Dim RS As DAO.Recordset
  Dim rst As DAO.Recordset
  
  Set db = CurrentDb()
  Set RS = db.OpenRecordset("setting", dbOpenDynaset)
  Set rst = db.OpenRecordset("master", dbOpenTable)
  counter = 0
 
  'テーブルデータからJSONデータを作成
  Dim recid As String
  Dim dateman As String
  Dim itemname As String
 
  'レコード件数を取得する
  dlength = rst.RecordCount
  
  jsondata = "["
  Do Until rst.EOF
    'counterが0以外の時カンマを追加する
    If counter = 0 Then
    Else
      jsondata = jsondata & ","
    End If
  
    'JSONデータを作成する
    jsondata = jsondata & "{"
      '文字列データをダブルコーテーションで括っておく
      recid = """" & rst!レコードID & """"
      dateman = """" & rst!日付 & """"
      itemname = """" & rst!商品名 & """"
      
      'JSONとして組み立てる
      jsondata = jsondata & """recid""" & ":" & recid & ","
      jsondata = jsondata & """dateman""" & ":" & dateman & ","
      jsondata = jsondata & """itemman""" & ":" & itemname & ","
      jsondata = jsondata & """itemcnt""" & ":" & rst!数量 & ","
      jsondata = jsondata & """tanka""" & ":" & rst!単価 & ","
      jsondata = jsondata & """kingaku""" & ":" & rst!金額
      
    jsondata = jsondata & "}"
    
    'カウントアップと次のレコードへ移動
    counter = counter + 1
    rst.MoveNext
  Loop
  jsondata = jsondata & "]"
  
  'parameters用の配列にデータとレコード件数を入れる
  param = "[" & jsondata & "," & dlength & "]"
 
  'Access_Tokenのexpireチェック
  ret = checkAccessToken()
  
  If ret = False Then
    '取得済みAccess_Token類を呼び出す
    With RS
      .FindFirst "ID=1"
      access_token = !access_token
    End With
  Else
    'エラーメッセージを出して、再認証をする
    MsgBox "再認証が必要です。"
    Call Authgoogle
    Exit Sub
  End If
  
  'access_tokenを使ってデータを取得する
  ret = ExecuteGASFunction(access_token, script_id, function_name, param)
  Debug.Print ret
  
  'メッセージ
  If ret = "OK" Then
    MsgBox "データの送信完了しました。"
  Else
    MsgBox ret
  End If
  
  '終了処理
　　　　rst.Close: Set rst = Nothing
  RS.Close: Set RS = Nothing
  db.Close: Set db = Nothing
 
End Sub

'データを送信するルーチン

Public Sub setSheetData()

'変数と定数の宣言

Dim access_token As String

Dim ret As String

Dim param As String

Dim jsondata As String

Dim dlength As Integer

Dim counter As Integer

Const function_name As String = "dataset" '実行するGAS関数名

'DAO関係の変数の宣言と初期化

Dim SQL As String

Dim db As DAO.Database

Dim RS As DAO.Recordset

Dim rst As DAO.Recordset

Set db = CurrentDb()

Set RS = db.OpenRecordset("setting", dbOpenDynaset)

Set rst = db.OpenRecordset("master", dbOpenTable)

counter = 0

'テーブルデータからJSONデータを作成

Dim recid As String

Dim dateman As String

Dim itemname As String

'レコード件数を取得する

dlength = rst.RecordCount

jsondata = "["

Do Until rst.EOF

'counterが0以外の時カンマを追加する

If counter = 0 Then

Else

jsondata = jsondata & ","

End If

'JSONデータを作成する

jsondata = jsondata & "{"

'文字列データをダブルコーテーションで括っておく

recid = """" & rst!レコードID & """"

dateman = """" & rst!日付 & """"

itemname = """" & rst!商品名 & """"

'JSONとして組み立てる

jsondata = jsondata & """recid""" & ":" & recid & ","

jsondata = jsondata & """dateman""" & ":" & dateman & ","

jsondata = jsondata & """itemman""" & ":" & itemname & ","

jsondata = jsondata & """itemcnt""" & ":" & rst!数量 & ","

jsondata = jsondata & """tanka""" & ":" & rst!単価 & ","

jsondata = jsondata & """kingaku""" & ":" & rst!金額

jsondata = jsondata & "}"

'カウントアップと次のレコードへ移動

counter = counter + 1

rst.MoveNext

Loop

jsondata = jsondata & "]"

'parameters用の配列にデータとレコード件数を入れる

param = "[" & jsondata & "," & dlength & "]"

'Access_Tokenのexpireチェック

ret = checkAccessToken()

If ret = False Then

'取得済みAccess_Token類を呼び出す

With RS

.FindFirst "ID=1"

access_token = !access_token

End With

Else

'エラーメッセージを出して、再認証をする

MsgBox "再認証が必要です。"

Call Authgoogle

Exit Sub

End If

'access_tokenを使ってデータを取得する

ret = ExecuteGASFunction(access_token, script_id, function_name, param)

Debug.Print ret

'メッセージ

If ret = "OK" Then

MsgBox "データの送信完了しました。"

Else

MsgBox ret

End If

'終了処理

　　　　rst.Close: Set rst = Nothing

RS.Close: Set RS = Nothing

db.Close: Set db = Nothing

End Sub

VBAコードの64bit対応

今回のソースコードは、Access 32bit版でなければ動作しません。コードの中で使われている「Microsoft ScriptControl 1.0」が64bit対応していない為です。Microsoft365以降は64bit版が標準でインストールされるようになってきている為、このままでは連携ができません。また、VBS-JSONも64bit環境では不具合が確認されています。

この問題をクリアする為に、64bit対応では以下のようにコードを変更する必要があります。参照設定からScript Controlは外しておきましょう。64bit版ではVBA-JSONも利用しない書き方に変更します。

'Access_Token他を取得するコード
Private Function GetAccessToken(ByVal auth_code As String) As Boolean
  Dim access_token As String
  Dim Json As String
  Dim dat As Variant
  Dim jsonstr As Object
  Dim ret As Variant
  
  Dim SQL As String
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Set db = CurrentDb()
  Set rs = db.OpenRecordset("setting", dbOpenDynaset)
  
  'JSONをパースする用の変数
  Dim doc, jsn
  'HTMLDocumentを取得
  Set doc = CreateObject("HtmlFile")
  'scriptタグを追加
  doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"

  access_token = "" '初期化
  
  'Access_Token取得用POST文字列の組み立て
  dat = "code=" & auth_code & "&" & _
        "client_id=" & client_id & "&" & _
        "client_secret=" & client_secret & "&" & _
        "redirect_uri=" & redirect_uri & "&" & _
        "grant_type=" & grant_type & "&" & _
        "&access_type=offline"
        
  'POST通信でAccess Token等をリクエスト
  With CreateObject("WinHttp.WinHttpRequest.5.1")
    .Open "POST", tokenurl, False
    .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
    .Send dat
    If .status = 200 Then
      '返ってきたJSON文字列を取得
      Json = .ResponseText
      If Len(Trim(Json)) > 0 Then
        'JSON文字列より各種値を取得・保存
        'パース関数でJSONオブジェクトを取得
        Set jsn = doc.JsonParse(Json)

        access_token = jsn.access_token
        
        'tokenをsettingテーブルに保存
        With rs
          .FindFirst "ID=1"
          .Edit
          !access_token = jsn.access_token
          !refresh_token = jsn.refresh_token
          .Update
        End With

        rs.Close: Set rs = Nothing
        db.Close: Set db = Nothing
        
        GetAccessToken = True
      Else
        GetAccessToken = False
      End If
    Else
      GetAccessToken = False
    End If
  End With
End Function


'Access_Tokenをチェックし、refresh_tokenで新しいAccess_Tokenを取得する関数
Private Function checkAccessToken() As Boolean
  Dim access_token As String
  Dim refresh_token As String
  Dim Json As String
  Dim dat As Variant
  Dim jsonstr As Object
  Dim ngflag As Boolean
  Dim xmlHttp  As Object
  Dim url As String
  Dim strRes As String
  Dim status As String
  Dim expirein As Integer
  Dim ret As Variant
  
  Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
  
  Dim SQL As String
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Set db = CurrentDb()
  Set rs = db.OpenRecordset("setting", dbOpenDynaset)
  
  'JSONをパースする用の変数
  Dim doc, jsn
  'HTMLDocumentを取得
  Set doc = CreateObject("HtmlFile")
  'scriptタグを追加
  doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
  
  '取得済みAccess_Token類を呼び出す
  With rs
    .FindFirst "ID=1"
    access_token = !access_token
    refresh_token = !refresh_token
  End With

  'Access_Tokenを'tokeninfoでexpireしてるかチェック
  url = tokeninfo & access_token
  With xmlHttp
    .Open "GET", url, False
    .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
    .Send
    strRes = .ResponseText
    status = .status
  End With

  If status = 200 Then
    'expireしていなければ200が返ってくる
    ngflag = False
    
    'expires_inが60以下ならrefreshしてしまう
    Set jsn = doc.JsonParse(strRes)

    expirein = CInt(jsn.expires_in)
    
    If expirein <= 60 Then
      ngflag = True
    Else
      ngflag = False
    End If
    
  Else
    'expireしてると400が返ってくる
    ngflag = True
  End If
    

  'ngflagをもとにrefresh_Tokenを使って新しいtokenを取得する
  'reftokenurlを使用する
  If ngflag = True Then
    'refresh_TokenでPOSTするパラメータを組み立て
    dat = "client_id=" & client_id & _
        "&client_secret=" & client_secret & _
        "&grant_type=refresh_token" & _
        "&refresh_token=" & refresh_token

    'POSTで新しいAccess_Tokenを取得する
    With xmlHttp
      .Open "POST", reftokenurl, False
      .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
      .Send (dat)
      strRes = .ResponseText
      status = .status
    End With

    '新しく取得したAccess_Tokenを格納する
    If status = 200 Then
        'HTMLDocumentを取得
        Set doc = CreateObject("HtmlFile")
        'scriptタグを追加
        doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
        
        Set jsn = doc.JsonParse(strRes)
        access_token = jsn.access_token
        
        With rs
          .FindFirst "ID=1"
          .Edit
          !access_token = access_token
          .Update
        End With

        ngflag = False
    Else
        ngflag = True
        MsgBox "再認証が必要です。再認証後再度実行してください。"
        Call Authgoogle
    End If

  End If

  '終了処理
  Set xmlHttp = Nothing
  rs.Close: Set rs = Nothing
  db.Close: Set db = Nothing
  
  '値を返す
  checkAccessToken = ngflag

End Function

'URLエンコードする為の関数
Public Function EncodeURL(ByVal str As String) As String
    
    #If Win64 Then
        '64bitの場合のコード
        Dim s As String, com As String, ret As String
        Dim ScriptFilePath As String, ExeFilePath As String
         
        ret = "" '初期化
         
        'スクリプト用コード設定
        s = "Option Explicit" & vbCrLf
        s = s & vbCrLf
        s = s & "Dim Args, ret" & vbCrLf
        s = s & vbCrLf
        s = s & "Set Args = WScript.Arguments" & vbCrLf
        s = s & "If Args.Count < 1 Then WScript.Quit" & vbCrLf
        s = s & "With CreateObject(""ScriptControl"")" & vbCrLf
        s = s & "  .Language = ""JScript""" & vbCrLf
        s = s & "  ret = .CodeObject.encodeURIComponent(Args(0))" & vbCrLf
        s = s & "End With" & vbCrLf
        s = s & "Set Args = Nothing" & vbCrLf
        s = s & "WScript.Echo ret"
         
        ScriptFilePath = VBA.Environ$("TEMP") & "enc.vbs"
        With CreateObject("Scripting.FileSystemObject")
          With .CreateTextFile(ScriptFilePath, True)
            .Write s
            .Close
          End With
          If .FileExists(ScriptFilePath) Then
            ExeFilePath = .GetSpecialFolder(0).Path & "SysWOW64cscript.exe"
            If .FileExists(ExeFilePath) Then
              com = ExeFilePath & " //Nologo """ & ScriptFilePath & """ """ & str & """"
              ret = CreateObject("WScript.Shell").Exec(com).StdOut.ReadAll
            End If
            .DeleteFile ScriptFilePath
          End If
        End With
        EncodeURL = ret
    #Else
        '32bitの場合のコード
        Dim script As Object
        Dim js As Object
        
        Set script = CreateObject("ScriptControl")
        script.Language = "JavaScript"
        Set js = script.CodeObject
        EncodeURL = js.encodeURIComponent(str)
    #End If
    
End Function


'データを取得するルーチン
Public Sub getSheetData()
  '変数と定数の宣言
  Dim access_token As String
  Dim ret As String
  Dim param As String
  Const function_name As String = "dataget" '実行するGAS関数名

  '配列データ処理用
  Dim tempStr As Variant
  Dim tempArray As Variant
  
  '変数の初期化
  param = ""
  
  'JSONをパースする用の変数
  Dim doc, jsn
  'HTMLDocumentを取得
  Set doc = CreateObject("HtmlFile")
  'scriptタグを追加
  doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"

  'DAO関係の変数の宣言と初期化
  Dim SQL As String
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Dim rst As DAO.Recordset
  
  Set db = CurrentDb()
  Set rs = db.OpenRecordset("setting", dbOpenDynaset)
  Set rst = db.OpenRecordset("temp_gas", dbOpenDynaset)
  
  '一時テーブルの中身をクリアする
  SQL = "DELETE * FROM temp_gas"
  db.Execute SQL
  
  'Access_Tokenのexpireチェック
  ret = checkAccessToken()
  
  If ret = False Then
    '取得済みAccess_Token類を呼び出す
    With rs
      .FindFirst "ID=1"
      access_token = !access_token
    End With
  Else
    'エラーメッセージを出して、再認証をする
    MsgBox "再認証が必要です。"
    Call Authgoogle
    Exit Sub
  End If
  
  'access_tokenを使ってデータを取得する
  ret = ExecuteGASFunction(access_token, script_id, function_name, param)
  
  If ret = "" Then
    MsgBox "データを取得できませんでした。"
    Exit Sub
  End If
  
  '取得したデータをscriptcontrolで処理をする
  Dim tempday As String

  If ret = "" Then
    MsgBox "データを取得できませんでした。"
    Exit Sub
  Else
    jsn = doc.JsonParse(ret)
  End If

  '取得したデータ処理をする
  Dim arrlength As Variant
  Dim cnt As Variant
  cnt = 0

  'カンマ区切りを配列に変換
  Dim i As Variant
  tempArray = Split(jsn, ",")
  arrlength = UBound(tempArray) - LBound(tempArray) + 1 - 1
  
  'Googleスプレッドシートのデータを取り込む
  'stepはシート側のカラムの数を指定する
  For i = 0 To arrlength Step 6
      '日付データを変換
      tempday = Mid(tempArray(Eval(i + 1)), 1, 4) & "/" & Mid(tempArray(Eval(i + 1)), 6, 2) & "/" & Mid(tempArray(Eval(i + 1)), 9, 2)
  
      '配列データをもとに新規レコード追加
      With rst
        .AddNew
            !レコードID = tempArray(i)
            !日付 = CDate(tempday)
            !商品名 = tempArray(Eval(i + 2))
            !数量 = tempArray(Eval(i + 3))
            !単価 = tempArray(Eval(i + 4))
            !金額 = tempArray(Eval(i + 5))
        .Update
      End With
  Next

  
  '追加クエリの実行
  DoCmd.OpenQuery "差分追加"
  
  '終了処理
  rs.Close: Set rs = Nothing
  db.Close: Set db = Nothing
  
  MsgBox "データの取得が完了しました。"

End Sub


'Google Apps Script Execution APIを実行してシートデータを取得する
Private Function ExecuteGASFunction(ByVal access_token As String, _
                                    ByVal script_id As String, _
                                    ByVal function_name As String, _
                                    ByVal parameters As String, _
                                    Optional ByVal dev_mode As String = "false") As String
                                    
  'Google Apps Script Execution API呼び出し
  Dim ret As Variant
  Dim url As String
  Dim Json As String
  Dim dat As Variant
  Dim jsonstr As Object

  'JSONをパースする用の変数
  Dim doc, jsn
  'HTMLDocumentを取得
  Set doc = CreateObject("HtmlFile")
  'scriptタグを追加
  doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
  
  '変数を初期化
  ret = ""
  dat = "{'function':'" & function_name & "','parameters':'" & parameters & "','devMode':" & dev_mode & "}"
  url = "https://script.googleapis.com/v1/scripts/" & script_id & ":run"
  
  'POST通信でAPIを叩いてデータを取得
  With CreateObject("WinHttp.WinHttpRequest.5.1")
    .Open "POST", url, False
    .SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
    .SetRequestHeader "Authorization", "Bearer " & access_token
    .Send dat
    
    '返ってきた値をもとにデータを処理
    Select Case .status
      Case 200
        'JSONデータを取得する
        Json = .ResponseText

        'パース関数でJSONオブジェクトを取得
        Set jsn = doc.JsonParse(Json)

        ret = jsn.response.result
    End Select
  End With
  
  '値を返す
  ExecuteGASFunction = ret
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

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

'Access_Token他を取得するコード

Private Function GetAccessToken(ByVal auth_code As String) As Boolean

Dim access_token As String

Dim Json As String

Dim dat As Variant

Dim jsonstr As Object

Dim ret As Variant

Dim SQL As String

Dim db As DAO.Database

Dim rs As DAO.Recordset

Set db = CurrentDb()

Set rs = db.OpenRecordset("setting", dbOpenDynaset)

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

Dim doc, jsn

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

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

access_token = "" '初期化

'Access_Token取得用POST文字列の組み立て

dat = "code=" & auth_code & "&" & _

"client_id=" & client_id & "&" & _

"client_secret=" & client_secret & "&" & _

"redirect_uri=" & redirect_uri & "&" & _

"grant_type=" & grant_type & "&" & _

"&access_type=offline"

'POST通信でAccess Token等をリクエスト

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "POST", tokenurl, False

.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"

.Send dat

If .status = 200 Then

'返ってきたJSON文字列を取得

Json = .ResponseText

If Len(Trim(Json)) > 0 Then

'JSON文字列より各種値を取得・保存

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

Set jsn = doc.JsonParse(Json)

access_token = jsn.access_token

'tokenをsettingテーブルに保存

With rs

.FindFirst "ID=1"

.Edit

!access_token = jsn.access_token

!refresh_token = jsn.refresh_token

.Update

End With

rs.Close: Set rs = Nothing

db.Close: Set db = Nothing

GetAccessToken = True

Else

GetAccessToken = False

End If

Else

GetAccessToken = False

End If

End With

End Function

'Access_Tokenをチェックし、refresh_tokenで新しいAccess_Tokenを取得する関数

Private Function checkAccessToken() As Boolean

Dim access_token As String

Dim refresh_token As String

Dim Json As String

Dim dat As Variant

Dim jsonstr As Object

Dim ngflag As Boolean

Dim xmlHttp As Object

Dim url As String

Dim strRes As String

Dim status As String

Dim expirein As Integer

Dim ret As Variant

Set xmlHttp = CreateObject("MSXML2.XMLHTTP")

Dim SQL As String

Dim db As DAO.Database

Dim rs As DAO.Recordset

Set db = CurrentDb()

Set rs = db.OpenRecordset("setting", dbOpenDynaset)

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

Dim doc, jsn

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

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

'取得済みAccess_Token類を呼び出す

With rs

.FindFirst "ID=1"

access_token = !access_token

refresh_token = !refresh_token

End With

'Access_Tokenを'tokeninfoでexpireしてるかチェック

url = tokeninfo & access_token

With xmlHttp

.Open "GET", url, False

.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"

.Send

strRes = .ResponseText

status = .status

End With

If status = 200 Then

'expireしていなければ200が返ってくる

ngflag = False

'expires_inが60以下ならrefreshしてしまう

Set jsn = doc.JsonParse(strRes)

expirein = CInt(jsn.expires_in)

If expirein <= 60 Then

ngflag = True

Else

ngflag = False

End If

Else

'expireしてると400が返ってくる

ngflag = True

End If

'ngflagをもとにrefresh_Tokenを使って新しいtokenを取得する

'reftokenurlを使用する

If ngflag = True Then

'refresh_TokenでPOSTするパラメータを組み立て

dat = "client_id=" & client_id & _

"&client_secret=" & client_secret & _

"&grant_type=refresh_token" & _

"&refresh_token=" & refresh_token

'POSTで新しいAccess_Tokenを取得する

With xmlHttp

.Open "POST", reftokenurl, False

.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"

.Send (dat)

strRes = .ResponseText

status = .status

End With

'新しく取得したAccess_Tokenを格納する

If status = 200 Then

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

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

Set jsn = doc.JsonParse(strRes)

access_token = jsn.access_token

With rs

.FindFirst "ID=1"

.Edit

!access_token = access_token

.Update

End With

ngflag = False

Else

ngflag = True

MsgBox "再認証が必要です。再認証後再度実行してください。"

Call Authgoogle

End If

'終了処理

Set xmlHttp = Nothing

rs.Close: Set rs = Nothing

db.Close: Set db = Nothing

'値を返す

checkAccessToken = ngflag

End Function

'URLエンコードする為の関数

Public Function EncodeURL(ByVal str As String) As String

#If Win64 Then

'64bitの場合のコード

Dim s As String, com As String, ret As String

Dim ScriptFilePath As String, ExeFilePath As String

ret = "" '初期化

'スクリプト用コード設定

s = "Option Explicit" & vbCrLf

s = s & vbCrLf

s = s & "Dim Args, ret" & vbCrLf

s = s & vbCrLf

s = s & "Set Args = WScript.Arguments" & vbCrLf

s = s & "If Args.Count < 1 Then WScript.Quit" & vbCrLf

s = s & "With CreateObject(""ScriptControl"")" & vbCrLf

s = s & " .Language = ""JScript""" & vbCrLf

s = s & " ret = .CodeObject.encodeURIComponent(Args(0))" & vbCrLf

s = s & "End With" & vbCrLf

s = s & "Set Args = Nothing" & vbCrLf

s = s & "WScript.Echo ret"

ScriptFilePath = VBA.Environ$("TEMP") & "enc.vbs"

With CreateObject("Scripting.FileSystemObject")

With .CreateTextFile(ScriptFilePath, True)

.Write s

.Close

End With

If .FileExists(ScriptFilePath) Then

ExeFilePath = .GetSpecialFolder(0).Path & "SysWOW64cscript.exe"

If .FileExists(ExeFilePath) Then

com = ExeFilePath & " //Nologo """ & ScriptFilePath & """ """ & str & """"

ret = CreateObject("WScript.Shell").Exec(com).StdOut.ReadAll

End If

.DeleteFile ScriptFilePath

End If

End With

EncodeURL = ret

#Else

'32bitの場合のコード

Dim script As Object

Dim js As Object

Set script = CreateObject("ScriptControl")

script.Language = "JavaScript"

Set js = script.CodeObject

EncodeURL = js.encodeURIComponent(str)

#End If

End Function

'データを取得するルーチン

Public Sub getSheetData()

'変数と定数の宣言

Dim access_token As String

Dim ret As String

Dim param As String

Const function_name As String = "dataget" '実行するGAS関数名

'配列データ処理用

Dim tempStr As Variant

Dim tempArray As Variant

'変数の初期化

param = ""

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

Dim doc, jsn

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

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

'DAO関係の変数の宣言と初期化

Dim SQL As String

Dim db As DAO.Database

Dim rs As DAO.Recordset

Dim rst As DAO.Recordset

Set db = CurrentDb()

Set rs = db.OpenRecordset("setting", dbOpenDynaset)

Set rst = db.OpenRecordset("temp_gas", dbOpenDynaset)

'一時テーブルの中身をクリアする

SQL = "DELETE * FROM temp_gas"

db.Execute SQL

'Access_Tokenのexpireチェック

ret = checkAccessToken()

If ret = False Then

'取得済みAccess_Token類を呼び出す

With rs

.FindFirst "ID=1"

access_token = !access_token

End With

Else

'エラーメッセージを出して、再認証をする

MsgBox "再認証が必要です。"

Call Authgoogle

Exit Sub

End If

'access_tokenを使ってデータを取得する

ret = ExecuteGASFunction(access_token, script_id, function_name, param)

If ret = "" Then

MsgBox "データを取得できませんでした。"

Exit Sub

End If

'取得したデータをscriptcontrolで処理をする

Dim tempday As String

If ret = "" Then

MsgBox "データを取得できませんでした。"

Exit Sub

Else

jsn = doc.JsonParse(ret)

End If

'取得したデータ処理をする

Dim arrlength As Variant

Dim cnt As Variant

cnt = 0

'カンマ区切りを配列に変換

Dim i As Variant

tempArray = Split(jsn, ",")

arrlength = UBound(tempArray) - LBound(tempArray) + 1 - 1

'Googleスプレッドシートのデータを取り込む

'stepはシート側のカラムの数を指定する

For i = 0 To arrlength Step 6

'日付データを変換

tempday = Mid(tempArray(Eval(i + 1)), 1, 4) & "/" & Mid(tempArray(Eval(i + 1)), 6, 2) & "/" & Mid(tempArray(Eval(i + 1)), 9, 2)

'配列データをもとに新規レコード追加

With rst

.AddNew

!レコードID = tempArray(i)

!日付 = CDate(tempday)

!商品名 = tempArray(Eval(i + 2))

!数量 = tempArray(Eval(i + 3))

!単価 = tempArray(Eval(i + 4))

!金額 = tempArray(Eval(i + 5))

.Update

End With

'追加クエリの実行

DoCmd.OpenQuery "差分追加"

'終了処理

rs.Close: Set rs = Nothing

db.Close: Set db = Nothing

MsgBox "データの取得が完了しました。"

End Sub

'Google Apps Script Execution APIを実行してシートデータを取得する

Private Function ExecuteGASFunction(ByVal access_token As String, _

ByVal script_id As String, _

ByVal function_name As String, _

ByVal parameters As String, _

Optional ByVal dev_mode As String = "false") As String

'Google Apps Script Execution API呼び出し

Dim ret As Variant

Dim url As String

Dim Json As String

Dim dat As Variant

Dim jsonstr As Object

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

Dim doc, jsn

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

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

'変数を初期化

ret = ""

dat = "{'function':'" & function_name & "','parameters':'" & parameters & "','devMode':" & dev_mode & "}"

url = "https://script.googleapis.com/v1/scripts/" & script_id & ":run"

'POST通信でAPIを叩いてデータを取得

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "POST", url, False

.SetRequestHeader "Content-Type", "application/json; charset=UTF-8"

.SetRequestHeader "Authorization", "Bearer " & access_token

.Send dat

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

Select Case .status

Case 200

'JSONデータを取得する

Json = .ResponseText

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

Set jsn = doc.JsonParse(Json)

ret = jsn.response.result

End Select

End With

'値を返す

ExecuteGASFunction = ret

End Function

Windows10 64bit対応

このエントリーは前項のVBA 64bit対応と同じく、64bit Windows10の場合に於ける「IEを使ったOAuth2認証」をする場合に生じる問題とその解決方法です。問題の箇所はInternet Explorerのobject生成時にあり、以下のようなエラーが出ます。また、この問題はIEの保護モードの有無でも生じる場合がある。以下の作業を行い、32bitのIEを起動するようにしましょう。

インターネットオプションを起動する
詳細設定タブをクリックする
拡張保護モードで64bitプロセッサを有効にするのチェックを外す
拡張保護モードを有効にするのチェックを外す。
これでコードを実行してみる。32bit版IE11なので問題なく動くはず。

図：64bit版IEを利用するメリットは全くありません。

ポイント

access_tokenは1時間でexpireしてしまいますので、expire後はrefresh_tokenを使って新しいaccess_tokenを取得する必要があります。今回は認証系のコードでその部分を追加しています。
refresh_tokenで新しいtokenを取得した場合、再認証は必要ありません。
また、expireしてるかどうかのチェックの為にtokeninfoに投げて結果を受け取るコードも必要です。
オリジナルのコードの中ではAPI IDを指定していますが、現在はスクリプトIDでなければ利用できません。
access_tokenおよびrefresh_tokenは、settingテーブルの1行目に値を格納させています。
expireしてなくても、残り時間が60秒以下の場合には、refreshを実行するようにしてあります。
refresh_tokenを取得する為、最初の認証時にaccess_type=offlineを追加してあります。
JsonConvert.parseJsonで得たデータの中のresponse.resultに当たる部分だけを取り出しています。
取得したデータはカンマ区切りになってるので、splitで配列化、その後日付だけは型を整えてDAOでレコードを追加しています。
temp_gasに入ったレコードを差分追加クエリの実行にて、masterテーブルへと追加しています。
一方、Access側でのJSONへの変換はJsonConverter.ConvertToJsonを利用して変換も良いのですが、今回は手動でJSONオブジェクトを組み立てて送信させています。
Google Apps Scriptでは一度に送信できるデータのサイズは25MBがリミットのようなので、あまり大きなデータを送ると失敗します。
今回はAccess側にフォームを設けていません。実際にはフォームとボタン類を配置して、各Subルーチンを割り当てて利用しましょう。
出来れば、Access_Tokenをrevokeし、別のアカウントで再認証出来るように仕組みを追加すると尚良いでしょう。その際のrevoke用のエンドポイントは、https://accounts.google.com/o/oauth2/revoke?token={token}です
json文字列を組み立てる部分でやたらとダブルコーテーションが記述されていますが、これは文字としてダブルコーテーションでプロパティ名やその値を括らなければならないので、このような書き方をしています。エスケープしないと、文字としてのダブルコーテーションが認識されないので、ちょっと面倒ですね。
Cloud SQLを使わずスプレッドシートで十分なレベルのデータ量ならば、VPN無し・DBなしで様々な業務アプリがAccessでも構築出来ます（バックエンド処理を全部、GASに任せられますし、DB接続する場合もJDBC Serviceを使えばGAS側に任せられますし）。
Google Apps Script APIを使えば、レガシー資産をクラウド対応させたり、CordovaのようなHTML5のスマートフォンアプリに強力な機能を持たせる事が出来るので、VBAでも使えるのはありがたい。
複数のGoogleスプレッドシートを扱う場合は、１個だけ今回の処理を記述したGoogleスプレッドシートを用意し、複数のスプレッドシートはリスト化しておけば、この１個からそれらを読み書き可能です。よって、複数のシートに今回の処理を記述する必要はありません。
企業内で使う場合、Proxy Serverが存在していることがあります。その場合WinHTTPに.setProxyオプションを使って、プロキシーのURLを指定しましょう（例：.setProxy 2, proxyuri）