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

現在、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回はファイルのダウンロードを実行する必要があります。

MENU

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

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

事前準備

プロジェクトの作成

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

ソースコード

OAuth認証の為のコード

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

実行と結果

関連リンク

いいね:

関連記事

最近の投稿

人気の投稿とページ

おすすめ