AccessでGoogle認証とファイルのダウンロード

現在、VBAで業務用アプリケーションを作成していますが、アップデータの配布に於いてイントラネット内に配置ですと、外部ではアップデートが出来ないことになります。かといって、VPNの設定などをして入れるようにするというのも考えもの。ということで、アップデータの配布にG SuiteのGoogle Driveを使えないか？

ということで、VBAにてGoogle認証をし、Drive APIを叩いてファイルをダウンロードする手段を考えました。Client IDや
Client Secretがあっても今回の手法の場合、組織内のアカウントでない場合、認証が通らずダウンロードが出来ません。また、この手法の場合、ファイルへのアクセス権が全くなくとも、ファイルオーナーの自分だけはダウンロードが可能になったりします。とても便利。今回はAccess VBAにて作成しています。

難易度：

リンク

1 今回使用するファイルや資料
2 事前準備
- 2.1 プロジェクトの作成
- 2.2 ダウンロードファイルの準備
3 ソースコード
- 3.1 OAuth認証の為のコード
- 3.2 ファイルのダウンロードの為のコード
4 実行と結果
5 関連リンク
- 5.1 関連記事

今回使用するファイルや資料

事前準備

プロジェクトの作成

今回は、Google Apps Scriptは使用しません。が、Google Drive APIは必要になります。そのため、Google Cloud PlatformにてDrive APIの有効化とClient IDおよびClient Secretが必要になります。以下の手順でプロジェクトを作成します。

Google Cloud Platformにアクセスする
ページの上部、Cloud Platformの文字の横にある▼をクリックする
出てきたダイアログの右上、「新しいプロジェクト」をクリックする
プロジェクト名を設定し、作成ボタンをクリックします。
左サイドバーのAPIとサービスをクリックします。
検索にて、Drive APIを検索し、有効にするをクリック。
左サイドバーの認証情報をクリックします。
認証情報を作成をクリックします。
OAuthクライアントIDを選択します。
「OAuth クライアント ID を作成するには、まず同意画面でサービス名を設定する必要があります。」と出るので、同意画面を設定をクリック。
OAuthの同意画面では、アプリケーションの種類を今回は「内部」にしておきます。これで組織外のユーザは認証出来ません。
アプリケーション名を適当に設定し、保存をクリック。
次の画面では、アプリケーションの種類を選びます。ここでは、「その他」を選択します。名前は適当につけて、作成をクリックします。
ここで、OAuthクライアントIDとシークレットが出るので控えておきます。

図：プロジェクトを作成しましょう。

図：組織内のユーザに限定しちゃいましょう。

図：重要なコードなので他人に開示したりしちゃだめです。

ダウンロードファイルの準備

事前にGoogle Driveにファイルをアップロードしておきます。ファイルは今回G Suite内のユーザ共有か？自分だけがアクセスできる状態にしておきます。前者であれば「リンクを知ってるxxxの全員が閲覧可」や後者であれば、「オフ – 特定のユーザだけがアクセス出来ます」の状態にしておきます。

また、アップロードが完了したら、ファイルのIDを控えておきます。ファイルIDはURLの中で、/d/の後ろから/viewの前までの文字列。これが今回VBAからダウンロードするファイルとなります。

例：https://drive.google.com/file/d/1pB38TVRqX7BnxU294RpTMhSsFkXBkwEx/view?usp=sharing

図：ファイルは限定公開の状態にしておきます。

ソースコード

OAuth認証の為のコード

Option Explicit
'--------------------------------------------------
'クライアントIDやシークレット等
'--------------------------------------------------
Public Const client_id As Variant = "ここにクライアントIDを入れてください。"
Public Const client_secret As Variant = "ここにクライアントシークレットを入れてください。"

'--------------------------------------------------
'認証用文字列、スコープ、リダイレクト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/drive"  '半角スペースで区切る
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="

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

'認証の実行とAccess_Token等の保存
Public Function Authgoogle()
    Dim auth_code As String
    Dim tokenget As String
    Dim ret As String
   
    'serverAuthCodeを取得
    auth_code = GetAuthorizationCode()
    
    'Access_Tokenを取得
    tokenget = GetAccessToken(auth_code)
    
    '取得結果を表示
    If tokenget = True Then
      MsgBox "認証が完了しました。"
    Else
      MsgBox "認証に失敗しました。"
    End If
    
End Function

'認証用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
    
    '10秒間sleepさせる（Windows10対策）
    Sleep 7000
    
    
    '認証が実行されたら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 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取得用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)

        'tokenをsettingテーブルに保存
        With rs
          .FindFirst "ID=1"
          .Edit
          !accesstoken = jsn.access_token
          !refreshtoken = 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を取得する関数
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")
   
  'DB接続用
  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 = !accesstoken
    refresh_token = !refreshtoken
  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
          !accesstoken = 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 & "\SysWOW64\cscript.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

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

Option Explicit

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

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

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

Public Const client_id As Variant = "ここにクライアントIDを入れてください。"

Public Const client_secret As Variant = "ここにクライアントシークレットを入れてください。"

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

'認証用文字列、スコープ、リダイレクト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/drive" '半角スペースで区切る

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="

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

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

Public Function Authgoogle()

Dim auth_code As String

Dim tokenget As String

Dim ret As String

'serverAuthCodeを取得

auth_code = GetAuthorizationCode()

'Access_Tokenを取得

tokenget = GetAccessToken(auth_code)

'取得結果を表示

If tokenget = True Then

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

Else

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

End If

End Function

'認証用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

'10秒間sleepさせる（Windows10対策）

Sleep 7000

'認証が実行されたら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 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取得用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)

'tokenをsettingテーブルに保存

With rs

.FindFirst "ID=1"

.Edit

!accesstoken = jsn.access_token

!refreshtoken = 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を取得する関数

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")

'DB接続用

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 = !accesstoken

refresh_token = !refreshtoken

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

!accesstoken = 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 & "\SysWOW64\cscript.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

Authgoogleを実行することで、認証が実行されます。
続けて、GetAutherizationCodeが実行されて、IEが立ち上がりログインを要求してきます。
sleepを入れている理由は、さっと閉じてしまうと認証結果のコードを取りそこねるのを防ぐためです。
checkAccessTokenは、Access Tokenがexpireしていないかチェックを行い、expireしている場合には、refresh Tokenを使って自動でAccess Tokenを取り直しています。
取得したAccess TokenおよびRefresh Tokenはsettingテーブルに格納しています。
2019年1月1日より、ブラウザ上で表示されるAuthrization Codeの取得の為の仕様が変更になっているため、旧来のgetElementById(“code”)でelement指定しても取れません。auth_code = .Document.getElementsByClassName(“qBHUIf”)(0).valueといった形でClassName指定で取得するようにしています。

ファイルのダウンロードの為のコード

Option Compare Database
'ファイルダウンロード関数（カレントディレクトリにダウンロード）
Public Function getFileDownload()
    'DB接続用
    Dim SQL As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("setting", dbOpenDynaset)
    
    'バイナリファイル生成用
    Dim FileData() As Byte
    Dim FileNum As Long
    
    'ファイルのIDを指定し、URLを組み立てる
    Dim fileid As Variant
    fileid = "ここにファイルのIDを入れてください"
    Dim downurl As String
    downurl = "https://drive.google.com/uc?export=download&id=" & fileid

    'Access_Tokenのexpireチェック
    Dim ret As Variant
    Dim access_token As String
    ret = checkAccessToken()
    
    If ret = False Then
      '取得済みAccess_Token類を呼び出す
      With rs
        .FindFirst "ID=1"
        access_token = !accesstoken
      End With
    Else
      'エラーメッセージを出して、再認証をする
      MsgBox "再認証が必要です。"
      Call Authgoogle
      Exit Function
    End If

    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "GET", downurl, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Authorization", "Bearer " & access_token
        .send
        
        '返ってきた値をもとにデータを処理
        Select Case .status
            Case 200
                'レスポンスヘッダを取得
                Debug.Print .GetAllResponseHeaders()
                
                'バイナリデータを取得
                FileData = .responseBody
                
                'ファイル名を取得する
                tempheader = .GetResponseHeader("Content-Disposition")
                disposition = DEcodeURLMSHTML(Mid(tempheader, InStr(tempheader, "filename*=UTF-8''") + 17))
                
                'ファイルパス組み立て
                FilePath = CurrentProject.Path & "\" & disposition
                
                'バイナリデータを生成する
                FileNum = FreeFile()
                Open FilePath For Binary Access Write As #FileNum
                    Put #FileNum, 1, FileData
                Close #FileNum
            Case Else
                MsgBox "ダウンロード失敗したよ"
                
                '終了処理
                Set db = Nothing
                Set rs = Nothing
                
                Exit Function
        End Select
    End With
    
    '終了処理
    Set db = Nothing
    Set rs = Nothing
    
    MsgBox "カレントディレクトリにファイルダウンロードしたよ。"
End Function

'MSHTMLを使ったURLデコード関数
Function DEcodeURLMSHTML(ByVal sWord As String) As String
    Dim d As Object
    Dim elm As MSHTML.HTMLSpanElement
    Dim objD As HTMLDocument: Set objD = New MSHTML.HTMLDocument
    sWord = Replace(sWord, "\", "\\")
    sWord = Replace(sWord, "'", "\'")
    Set d = CreateObject("htmlfile")
    Set elm = objD.createElement("span")
    elm.setAttribute "id", "result"
    objD.appendChild elm
    objD.parentWindow.execScript "document.getElementById('result').innerText = decodeURIComponent('" & sWord & "');", "JScript"
    DEcodeURLMSHTML = elm.innerText
End Function

Option Compare Database

'ファイルダウンロード関数（カレントディレクトリにダウンロード）

Public Function getFileDownload()

'DB接続用

Dim SQL As String

Dim db As DAO.Database

Dim rs As DAO.Recordset

Set db = CurrentDb()

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

'バイナリファイル生成用

Dim FileData() As Byte

Dim FileNum As Long

'ファイルのIDを指定し、URLを組み立てる

Dim fileid As Variant

fileid = "ここにファイルのIDを入れてください"

Dim downurl As String

downurl = "https://drive.google.com/uc?export=download&id=" & fileid

'Access_Tokenのexpireチェック

Dim ret As Variant

Dim access_token As String

ret = checkAccessToken()

If ret = False Then

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

With rs

.FindFirst "ID=1"

access_token = !accesstoken

End With

Else

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

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

Call Authgoogle

Exit Function

End If

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "GET", downurl, False

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

.setRequestHeader "Authorization", "Bearer " & access_token

.send

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

Select Case .status

Case 200

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

Debug.Print .GetAllResponseHeaders()

'バイナリデータを取得

FileData = .responseBody

'ファイル名を取得する

tempheader = .GetResponseHeader("Content-Disposition")

disposition = DEcodeURLMSHTML(Mid(tempheader, InStr(tempheader, "filename*=UTF-8''") + 17))

'ファイルパス組み立て

FilePath = CurrentProject.Path & "\" & disposition

'バイナリデータを生成する

FileNum = FreeFile()

Open FilePath For Binary Access Write As #FileNum

Put #FileNum, 1, FileData

Close #FileNum

Case Else

MsgBox "ダウンロード失敗したよ"

'終了処理

Set db = Nothing

Set rs = Nothing

Exit Function

End Select

End With

'終了処理

Set db = Nothing

Set rs = Nothing

MsgBox "カレントディレクトリにファイルダウンロードしたよ。"

End Function

'MSHTMLを使ったURLデコード関数

Function DEcodeURLMSHTML(ByVal sWord As String) As String

Dim d As Object

Dim elm As MSHTML.HTMLSpanElement

Dim objD As HTMLDocument: Set objD = New MSHTML.HTMLDocument

sWord = Replace(sWord, "\", "\\")

sWord = Replace(sWord, "'", "\'")

Set d = CreateObject("htmlfile")

Set elm = objD.createElement("span")

elm.setAttribute "id", "result"

objD.appendChild elm

objD.parentWindow.execScript "document.getElementById('result').innerText = decodeURIComponent('" & sWord & "');", "JScript"

DEcodeURLMSHTML = elm.innerText

End Function

WinHttpRequestでリクエストするURLはDriveのファイルダウンロードURL直にアクセスさせます。
Box APIを叩くでも利用したコードにて、バイナリファイルを組み立てて、カレントディレクトリに保存しています。
DecodeURLMSHTMLという関数を利用しています。利用する為には、参照設定にて「Microsoft HTML Object Library」が必要です。
ファイル名などの情報は、Content-Dispositionヘッダー内に含まれていて、ここから取り出します。ヘッダの内容は以下のような感じ

実行と結果

今回のファイルはAccessで作成していますが、主要なコマンドはリボンに組み込んであります。あらかじめ、Google Cloud Platformで控えておいた「Client ID」および「Client Secret」またGoogle DriveのファイルのIDを記述しておき、以下の手順で実行します。

Google認証を実行し、Googleへログインする
settingテーブルにAccess TokenとRefresh Tokenが格納されます。
続けて、ドライブファイルダウンロードを実行すると、このファイルと同じフォルダ内に対象のファイルがダウンロードされます。

図：これでオンライン配信がより確実に行える！！

Accessファイルのオンラインアップデート配信では、XMLファイルおよびアップデート用のインストーラやZIPファイルをGoogle Driveに格納し、外部ユーザに限定配信（組織のユーザのみ）が可能なので、VPNといった仕組みが不要です。対象のアカウントが削除されれば、Access Tokenは無効化されます。

※つまり、バージョン確認用のXMLのアクセスに１回、ファイルのダウンロードに１回の合計2回はファイルのダウンロードを実行する必要があります。