2018年10月20日 / 最終更新日時 : 2024年1月12日 officeの杜 msoffice

VBAからBox APIを叩いてみる - 準備編

基本普段はG Suiteユーザなので、以前ほどVBAを弄らなくなりましたが、会社では通信環境や開発環境が2000年レベルで制限されているので、VBAがいつまでも現役です。ウェブアプリケーション全盛の今でもVBAが現役で使えるのは、Web APIへアクセスする手段が昔からの手法で可能な面が大きいですね。

さて、そんなウェブサービスの一つに「Box」というストレージサービスがあります。正直一般ユーザではメジャーでもなんでもありません。また機能面でもGoogle Driveのほうが断然扱いやすく、学習コストも低い。このサービスもAPIがありますが、その情報源はほとんどが海外。とは言え、使わざるを得ない状況なので、VBAからAPIを使えるようにチャレンジしてみました。

※Access Token取得部分(getAccessToken, getNewToken)にて、urlencodeのheaderが追加しないと通らなくなっていたので、修正しました。

1 今回使用するファイルとライブラリ
2 新方式が登場しました
3 IE11を使わない認証対応版
4 事前準備
- 4.1 プロキシー設定を調べる
- 4.2 Box側の設定を行う
5 認証を実行するコード
- 5.1 ソースコード
- 5.2 認証の実行
6 期限切れ時に再度Access Tokenを取得する
- 6.1 失効してるかどうかチェックするコード
- 6.2 再度Access Tokenを取得するコード
7 Office 64bit対応
8 関連リンク

今回使用するファイルとライブラリ

新方式が登場しました

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

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

IE11を使わない認証対応版

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

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

事前準備

Box APIを利用するためには、Box Developers Portalより事前準備が必要です。また、企業内で利用する場合には、プロキシーサーバを使っているケースがあるので、そのプロキシーサーバのURLとポート番号がアクセスに必要になります。

プロキシー設定を調べる

企業内で使う場合、ウェブアクセスにプロキシーを使ってる場合には、VBAからアクセスする場合もその設定を利用する必要性があります。プロキシーを経由しなければ外に出ることができないので、プログラムが動作しません。プロキシーの設定はいろいろなパターンがありますが、一般的な設定の調べ方は以下の通り。

サーバーのアドレスとポート番号について、http://を除外して、コロンでポート番号でつなげて利用します。（例：hiroproxy.net:8080）

コントロールパネルより「インターネットオプション」を開く
「接続」タブを開き、「LANの設定」を開く
この画面でプロキシーサーバの部分にアドレスとポート名が入ってるならばこれを控えておく。
場合によっては、詳細設定の中の「HTTP」で指定してるサーバーアドレスとポート番号を控えておく。
自動構成スクリプトを使ってる場合、そこに指定されてるアドレスのファイルの中に、様々なプロキシーアドレスが入っていますので、それを一旦ダウンロードして中身をテキストエディタで開いてみる（通常はpacというファイル）
5.のケースの場合、pacファイル内はIF文を使ってアクセスするサイト別にプロキシーが設定されてることが多いので、もっとも一般的なサイトアクセスもしくはBoxについてだけ定義している場合には、そのサーバーアドレスとポート番号を控えておく。

図：プロキシー設定がない場合はこの作業は不要です。

Box側の設定を行う

Box側ではClient IDやClient Secret等を作る必要性があります。以下の手順でBox Developers Portalにて作成しましょう。

Box Developers Portalにログインする
マイアプリにて「アプリの新規作成」をクリックする
次の画面では「カスタムアプリ」をクリックし、次へ進みます。
認証方法のページでは、「標準OAuth2.0」をクリックし、次へ進みます。
アプリの名前は適当に設定し、「アプリの作成」をクリックします。アプリ名は同じものが設定できませんので注意！！
アプリの表示をクリックして設定データを取得しておきます。
OAuth2.0資格情報の欄にて、クライアントIDおよびクライアント機密コード（Secret）をコピーして控えて置きます。
OAuth2.0リダイレクトURIですが、https://localhostでも良いのですが、Internet Explorerを使うので、この設定ですとAccess Tokenが取れない場合があります。（故に今回はこのサイトを指定しました：https://officeforest.org/）
アプリケーションのスコープでは、許可するアクションにチェックを入れます。
高度な機能では、「ユーザとして操作を実行」を有効にします。
CORSドメインはウェブなどで利用する場合に許可送信元として入力する場合にそのサイトのドメインを入れておきます。
変更を保存するボタンをクリックして完了

図：リダイレクトURLの設定が嵌りどころだったりします。

認証を実行するコード

ここまでの情報でOAuth2.0認証を実行し、Access Token他を取得する準備が整いました。今回はAccessを利用しているので、Access Token、Refresh Token、expireする時間を取得してテーブルに格納します（本来は第三者が容易にこのコードを知られないようにする仕組みを用意しましょう）。

ソースコード

Option Compare Database

'OAuth認証用
Private Const client_id As String = "クライアントIDをここに入力する"
Private Const client_secret As String = "クライアント機密コードをここに入力する"
Private Const oauthurl As String = "https://account.box.com/api/oauth2/authorize?"
Private Const tokenurl As String = "https://api.box.com/oauth2/token"
Private Const grant_type As String = "authorization_code"
Private Const redirecturl As String = "ここにリダイレクトURLを入力する"

'プロキシURL
Const proxyuri As String = "ここにプロキシURLを入力する"

'Boxで認証コードを実行する
Public Function boxAuthorization()
    '-- IE を起動する
    Dim objBrowser As Object
    Set objBrowser = CreateObject("InternetExplorer.Application")
    Const READYSTATE_COMPLETE = 4
    
    '変数を宣言する
    Dim tempurl As String
    Dim authcode As String
    Dim tokenflg As Boolean
    
    With objBrowser
        '-- IEを表示
        .Visible = True

        '-- 表示位置を設定
        .Top = 100  'Y位置（上下）
        .Left = 200  'X位置（左右）
        .Height = 800  'IEウィンドウの高さ
        .Width = 650 'IEウィンドウの幅
        
        'その他の設定
        .AddressBar = False
        .MenuBar = False
        .StatusBar = False
        .Toolbar = False

        '-- 認証画面を表示
        .Navigate oauthurl & "response_type=code&client_id=" & client_id & "&state=authenticated"

        '-- IEが表示されるまで待機
        On Error Resume Next
        Do While .Busy = True Or .ReadyState <> 4
            DoEvents
        Loop
        
        '認証が実行されるまで待機
        While .Busy Or _
              .ReadyState <> READYSTATE_COMPLETE Or _
              InStr(LCase(.LocationURL), redirecturl) < 1
          DoEvents
        Wend
        
        'URLの値を取得する
        tempurl = objBrowser.LocationURL
        
        'ログアウトさせる
        While .Busy Or .ReadyState <> READYSTATE_COMPLETE
          DoEvents
        Wend
        .Quit
    End With
    
    '取得したコードからcode=以下を取得する
    authcode = Mid(tempurl, InStr(tempurl, "code=") + 5)
    
    'Access Tokenを取得する
    tokenflg = getAccessToken(authcode)
    
    '終了処理
    If tokenflg = True Then
        'Access Tokenを取得できた
        MsgBox "認証が完了しました。"
        Exit Function
    Else
        'Access Token取得失敗
        MsgBox "認証は失敗しましたよ！！残念！"
        Exit Function
    End If
    
End Function

'認証コードを持ってPOST通信でアクセストークンを取得する
Public Function getAccessToken(authcode As String) As Boolean
    '変数を宣言する
    Dim JsonObject As Object, item As Object
    Dim strRes As Variant
    Dim dat As Variant

    'JSONをパースする用の変数
    Dim doc, jsn
    Dim access_token As String
    Dim refresh_token As String
    Dim expire_in As Integer
    
    'データベース接続用
    Dim SQL As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    
    'JSON受信用
    'HTMLDocumentを取得
    Set doc = CreateObject("HtmlFile")
    'scriptタグを追加
    doc.write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
    
    '送信データを組み立て
    dat = "grant_type=" & grant_type & _
        "&code=" & authcode & _
        "&client_id=" & client_id & _
        "&client_secret=" & client_secret
    
    'POST通信でAPIを叩いてデータを取得
    With CreateObject("WinHttp.WinHttpRequest.5.1")
      .Open "POST", tokenurl, False
      .setProxy 2, proxyuri  'プロキシサーバつかってない場合はコメントアウト
      .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
      .send dat
      
      '返ってきた値をもとにデータを処理
      Select Case .status
        Case 200
            'JSONデータを取得する
            Json = .responseText
            
            If Len(Trim(Json)) > 0 Then
                'パース関数でJSONオブジェクトを取得
                Set jsn = doc.JsonParse(Json)
                
                'Token情報を取得する
                access_token = jsn.access_token
                refresh_token = jsn.refresh_token
                expire_in = jsn.expires_in
                
                'DBへ接続する
                Set db = CurrentDb()
                Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)
                
                'tokeninfoへ上書きする
                With rs
                    .FindFirst "ID=1"
                    .Edit
                    !access_token = access_token
                    !refresh_token = refresh_token
                    !expire_in = expire_in
                    !getdate = Now()
                    !expiredate = DateAdd("s", expire_in, Now())
                    .Update
                End With
            
                'DB接続解除
                rs.Close: Set rs = Nothing
                db.Close: Set db = Nothing
                
                '値を返す
                getAccessToken = True
            
            Else
                getAccessToken = False
            End If
          
        Case Else
            getAccessToken = False
      End Select
    End With
    
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

Option Compare Database

'OAuth認証用

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

Private Const client_secret As String = "クライアント機密コードをここに入力する"

Private Const oauthurl As String = "https://account.box.com/api/oauth2/authorize?"

Private Const tokenurl As String = "https://api.box.com/oauth2/token"

Private Const grant_type As String = "authorization_code"

Private Const redirecturl As String = "ここにリダイレクトURLを入力する"

'プロキシURL

Const proxyuri As String = "ここにプロキシURLを入力する"

'Boxで認証コードを実行する

Public Function boxAuthorization()

'-- IE を起動する

Dim objBrowser As Object

Set objBrowser = CreateObject("InternetExplorer.Application")

Const READYSTATE_COMPLETE = 4

'変数を宣言する

Dim tempurl As String

Dim authcode As String

Dim tokenflg As Boolean

With objBrowser

'-- IEを表示

.Visible = True

'-- 表示位置を設定

.Top = 100 'Y位置（上下）

.Left = 200 'X位置（左右）

.Height = 800 'IEウィンドウの高さ

.Width = 650 'IEウィンドウの幅

'その他の設定

.AddressBar = False

.MenuBar = False

.StatusBar = False

.Toolbar = False

'-- 認証画面を表示

.Navigate oauthurl & "response_type=code&client_id=" & client_id & "&state=authenticated"

'-- IEが表示されるまで待機

On Error Resume Next

Do While .Busy = True Or .ReadyState <> 4

DoEvents

Loop

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

While .Busy Or _

.ReadyState <> READYSTATE_COMPLETE Or _

InStr(LCase(.LocationURL), redirecturl) < 1

DoEvents

Wend

'URLの値を取得する

tempurl = objBrowser.LocationURL

'ログアウトさせる

While .Busy Or .ReadyState <> READYSTATE_COMPLETE

DoEvents

Wend

.Quit

End With

'取得したコードからcode=以下を取得する

authcode = Mid(tempurl, InStr(tempurl, "code=") + 5)

'Access Tokenを取得する

tokenflg = getAccessToken(authcode)

'終了処理

If tokenflg = True Then

'Access Tokenを取得できた

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

Exit Function

Else

'Access Token取得失敗

MsgBox "認証は失敗しましたよ！！残念！"

Exit Function

End If

End Function

'認証コードを持ってPOST通信でアクセストークンを取得する

Public Function getAccessToken(authcode As String) As Boolean

'変数を宣言する

Dim JsonObject As Object, item As Object

Dim strRes As Variant

Dim dat As Variant

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

Dim doc, jsn

Dim access_token As String

Dim refresh_token As String

Dim expire_in As Integer

'データベース接続用

Dim SQL As String

Dim db As DAO.Database

Dim rs As DAO.Recordset

'JSON受信用

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

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

'送信データを組み立て

dat = "grant_type=" & grant_type & _

"&code=" & authcode & _

"&client_id=" & client_id & _

"&client_secret=" & client_secret

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

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "POST", tokenurl, False

.setProxy 2, proxyuri 'プロキシサーバつかってない場合はコメントアウト

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

.send dat

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

Select Case .status

Case 200

'JSONデータを取得する

Json = .responseText

If Len(Trim(Json)) > 0 Then

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

Set jsn = doc.JsonParse(Json)

'Token情報を取得する

access_token = jsn.access_token

refresh_token = jsn.refresh_token

expire_in = jsn.expires_in

'DBへ接続する

Set db = CurrentDb()

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

'tokeninfoへ上書きする

With rs

.FindFirst "ID=1"

.Edit

!access_token = access_token

!refresh_token = refresh_token

!expire_in = expire_in

!getdate = Now()

!expiredate = DateAdd("s", expire_in, Now())

.Update

End With

'DB接続解除

rs.Close: Set rs = Nothing

db.Close: Set db = Nothing

'値を返す

getAccessToken = True

Else

getAccessToken = False

End If

Case Else

getAccessToken = False

End Select

End With

End Function

IE11で動作検証しています。URLのリダイレクトURLのあとにcode=という形で、認証コードが帰ってきます（Access Tokenじゃないいですよ）。
認証コードを持って、getAccessTokenに渡し、Access Tokenを取得させています。
取得したAccess Token、Refresh Token、expire_in（有効期限）、取得時刻、期限切れ時刻をテーブルに格納しています。
expireする時刻はおよそ60分後です。
expireした場合には次項で紹介する、refresh Tokenを使ったAccess Tokenの取得を実行するようにします。
プロキシーを使わない場合には、setProxyの行をコメントアウトしてください。
Access Tokenの取得はWinHttpRequestを使ってPOSTで送信します。

認証の実行

上記のboxAuthorizationを実行すると、IEが起動しBoxのログイン画面が出ます。そこでログインに認証を実行すると、Access Tokenが取得されて、tokeninfoテーブルにそれぞれデータが追記される仕組みになっています。

デバッグしてみると、最後リダイレクト先に遷移した際のURLの後半に認証コードが含まれています。リダイレクト先がlocalhostの場合、ここが失敗してcodeが入っていないことがあります。

例：https://officeforest.org/wp/?state=authenticated&code=ここに認証コードが入ってる

図：Boxへのログイン画面が出てきます。

図：認証を要求してくるので許可しましょう。

期限切れ時に再度Access Tokenを取得する

およそ60分でAccess Tokenは失効するようになっています（これはOAuth2.0の共通の仕様です）。そのため、この実装のままでは再度利用しようとした時にはすでにそのAccess Tokenは失効済みで、もう一度認証を実行しなければなりません（セキュリティを求めるならばこのままの仕様でも良いかもしれませんが）。

しかし、OAuth2.0ではその手間を排除するために、Refresh Tokenを使って再びAccess Tokenを取得する仕組みが備わっています。そのためには現在のAccess Tokenが失効しているかどうか？チェックする仕組みも必要です。この項目ではこの２つを実装します。

失効してるかどうかチェックするコード

'Access Tokenが認証切れかどうかをチェックする
'0=OK, 1=失効, 2=refresh期限切れ
Public Function checkExpireToken() As Integer
    'DB接続用
    Dim SQL As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)
    Dim checkflg As Integer

    '60日オーバーチェック
    Dim checkday As Variant
    Dim sixtyday As Variant
    Dim expireday As Variant
    sixtyday = DateAdd("d", 60, rs!expiredate)
    checkday = DateDiff("d", Now(), sixtyday)
    expireday = DateDiff("n", Now(), rs!expiredate)
    
    '60日リミットまでの日数が残り1日以下の場合
    If checkday <= 1 Then
        '認証コードで新しいTokenを取得する
        checkflg = 2
    End If
    
    'Access Tokenがexpireしているかどうかをチェック(50分以下)
    If expireday <= 50 Then
        'expireする日付まで50分以下の場合
        checkflg = 1
    Else
        'Access Tokenはまだ生きてるので問題ナシ
        checkflg = 0
    End If


    '終了処理
    Set db = Nothing
    Set rs = Nothing
    
    'フラグを返す
    checkExpireToken = checkflg

End Function

'Access Tokenが認証切れかどうかをチェックする

'0=OK, 1=失効, 2=refresh期限切れ

Public Function checkExpireToken() As Integer

'DB接続用

Dim SQL As String

Dim db As DAO.Database

Dim rs As DAO.Recordset

Set db = CurrentDb()

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

Dim checkflg As Integer

'60日オーバーチェック

Dim checkday As Variant

Dim sixtyday As Variant

Dim expireday As Variant

sixtyday = DateAdd("d", 60, rs!expiredate)

checkday = DateDiff("d", Now(), sixtyday)

expireday = DateDiff("n", Now(), rs!expiredate)

'60日リミットまでの日数が残り1日以下の場合

If checkday <= 1 Then

'認証コードで新しいTokenを取得する

checkflg = 2

End If

'Access Tokenがexpireしているかどうかをチェック(50分以下)

If expireday <= 50 Then

'expireする日付まで50分以下の場合

checkflg = 1

Else

'Access Tokenはまだ生きてるので問題ナシ

checkflg = 0

End If

'終了処理

Set db = Nothing

Set rs = Nothing

'フラグを返す

checkExpireToken = checkflg

End Function

Boxは60分でAccess Tokenが失効します。
また、取得した日から60日で再度認証を要求する仕様になっているので、60日リミットチェックも必要です。
3種のフラグで受け取った側で処理を分岐させてあげます。

再度Access Tokenを取得するコード

'refresh tokenを持って新しいAccess Tokenを取得する
Public Function getNewToken() As Boolean
    '変数を宣言する
    Dim JsonObject As Object, item As Object
    Dim strRes As Variant
    Dim dat As Variant
    Dim tempflg As Boolean

    'JSONをパースする用の変数
    Dim doc, jsn
    Dim access_token As String
    Dim refresh_token As String
    Dim expire_in As Integer
    
    'データベース接続用
    Dim SQL As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)

    'JSON受信用
    'HTMLDocumentを取得
    Set doc = CreateObject("HtmlFile")
    'scriptタグを追加
    doc.write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
    
    '送信データを組み立て
    Dim reftoken As Variant
    reftoken = rs!refresh_token
    
    dat = "grant_type=refresh_token" & _
        "&refresh_token=" & reftoken & _
        "&client_id=" & client_id & _
        "&client_secret=" & client_secret

    'POST通信でAPIを叩いてデータを取得
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "POST", tokenurl, False
        '.setProxy 2, proxyuri  'プロキシサーバのURLとポート番号
        '.setRequestHeader "Content-Type", "application/json; charset=UTF-8"
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .send dat

        '返ってきた値をもとにデータを処理
        Select Case .status
            Case 200
                'JSONデータを取得する
                Json = .responseText
            
                If Len(Trim(Json)) > 0 Then
                    'パース関数でJSONオブジェクトを取得
                    Set jsn = doc.JsonParse(Json)
            
                    'Token情報を取得する
                    access_token = jsn.access_token
                    refresh_token = jsn.refresh_token
                    expire_in = jsn.expires_in
            
                    'tokeninfoへ上書きする
                    With rs
                        .FindFirst "ID=1"
                        .Edit
                        !access_token = access_token
                        !refresh_token = refresh_token
                        !expire_in = expire_in
                        !getdate = Now()
                        !expiredate = DateAdd("s", expire_in, Now())
                        .Update
                    End With
                    
                    'Access Token取得成功
                    tempflg = True
                Else
                    'Access Token取得失敗
                    tempflg = False
                End If
            Case Else
                'Access Token取得失敗
                tempflg = False
        End Select
    End With
    
    '終了処理
    Set db = Nothing
    Set rs = Nothing

    '値を返す
    getNewToken = tempflg

End Function

'refresh tokenを持って新しいAccess Tokenを取得する

Public Function getNewToken() As Boolean

'変数を宣言する

Dim JsonObject As Object, item As Object

Dim strRes As Variant

Dim dat As Variant

Dim tempflg As Boolean

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

Dim doc, jsn

Dim access_token As String

Dim refresh_token As String

Dim expire_in As Integer

'データベース接続用

Dim SQL As String

Dim db As DAO.Database

Dim rs As DAO.Recordset

Set db = CurrentDb()

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

'JSON受信用

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

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

'送信データを組み立て

Dim reftoken As Variant

reftoken = rs!refresh_token

dat = "grant_type=refresh_token" & _

"&refresh_token=" & reftoken & _

"&client_id=" & client_id & _

"&client_secret=" & client_secret

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

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "POST", tokenurl, False

'.setProxy 2, proxyuri 'プロキシサーバのURLとポート番号

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

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

.send dat

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

Select Case .status

Case 200

'JSONデータを取得する

Json = .responseText

If Len(Trim(Json)) > 0 Then

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

Set jsn = doc.JsonParse(Json)

'Token情報を取得する

access_token = jsn.access_token

refresh_token = jsn.refresh_token

expire_in = jsn.expires_in

'tokeninfoへ上書きする

With rs

.FindFirst "ID=1"

.Edit

!access_token = access_token

!refresh_token = refresh_token

!expire_in = expire_in

!getdate = Now()

!expiredate = DateAdd("s", expire_in, Now())

.Update

End With

'Access Token取得成功

tempflg = True

Else

'Access Token取得失敗

tempflg = False

End If

Case Else

'Access Token取得失敗

tempflg = False

End Select

End With

'終了処理

Set db = Nothing

Set rs = Nothing

'値を返す

getNewToken = tempflg

End Function

ほぼAccess Tokenを取得するコードと同じですが、dat変数の中でrefresh tokenを指定しています。
再び新しいAccess TokenとRefresh Token等がもらえるので、tokeninfoテーブルに格納しています。

Office 64bit対応

本コードは、64bit VBAですと、boxAuthorization()にて問題がでます。問題の箇所はInternet Explorerのobject生成時にあり、以下のようなエラーが出ます。また、この問題はIEの保護モードの有無でも生じる場合がある。32bit VBAでは上記のコードで問題なく動くのですが。

図：こんな感じのエラーがBusyやreadystateのあたりで出る。

これを解消するには、以下の手順で修正します。

参照設定で「Microsoft Internet Control」を追加する
CreateObject("InternetExplorer.Application")を、New InternetExplorerMediumに置き換える

ただしこの方法には問題があって、起動し確かにAuthcodeが取得できるんですが、.Quitで閉じる事ができません。IEが起動した直後、セキュリティ中レベルでのインスタンスに切り替わり、プログラム側から操作が出来なくなる為。閉じられなくなると困るのでInternetExplorerMediumを利用した場合には以下のようなコードになります（起動しているiexplorer.exeを閉じるループを回しています）。

また、最後3秒間ほどsleepを入れていますが、これも入れておかないとIEが閉じませんので、入れてあります（msgboxを適当に表示しても閉じるのですが、msgboxだと邪魔なので）

    '-- IE を起動する
    Dim objBrowser As Object
    Set objBrowser = New InternetExplorerMedium
    
    Const READYSTATE_COMPLETE = 4
    
    '変数を宣言する
    Dim tempurl As String
    Dim authcode As String
    Dim tokenflg As Boolean
    
    With objBrowser
        '-- IEを表示
        .Visible = True

        '-- 表示位置を設定
        .Top = 100  'Y位置（上下）
        .Left = 200  'X位置（左右）
        .Height = 800  'IEウィンドウの高さ
        .Width = 650 'IEウィンドウの幅
        
        'その他の設定
        .AddressBar = False
        .MenuBar = False
        .StatusBar = False
        .Toolbar = False

        '-- 認証画面を表示
        .Navigate oauthurl & "response_type=code&client_id=" & client_id & "&state=authenticated"
        
        '認証が実行されるまで待機
        On Error Resume Next
        While .Busy Or _
              .ReadyState <> 4 Or _
              InStr(LCase(.LocationURL), "https://www.google.com/") < 1
              Debug.Print InStr(LCase(.LocationURL), "https://www.google.com/")
          DoEvents
        Wend
        
        'URLの値を取得する
        tempurl = objBrowser.LocationURL
        
        .Quit
    End With
    
    '取得したコードからcode=以下を取得する
    authcode = Mid(tempurl, InStr(tempurl, "code=") + 5)

    '3秒間スリープさせる（これが味噌）
    Sleep 3000
    
    Dim objSh As Object
    Dim objW As Object
    Dim i As Integer
    
    Set objSh = CreateObject("Shell.Application")
    
    For i = objSh.Windows.Count To 1 Step -1
        Set objW = objSh.Windows(i - 1)
        If objW.FullName Like "*iexplore.exe" Then
            objW.Quit
        End If
    Next
    
    'Access Tokenを取得する
    tokenflg = getAccessToken(authcode)
    
    '終了処理
    If tokenflg = True Then
        'Access Tokenを取得できた
        MsgBox "認証が完了しました。"
        'ウィンドウハンドルを取得し直す
    Else
        'Access Token取得失敗
        MsgBox "認証は失敗しましたよ！！残念！"
    End If
    
    '閉じる
    'ウィンドウハンドルを取得し直す
    Set objBrowser = Nothing

'-- IE を起動する

Dim objBrowser As Object

Set objBrowser = New InternetExplorerMedium

Const READYSTATE_COMPLETE = 4

'変数を宣言する

Dim tempurl As String

Dim authcode As String

Dim tokenflg As Boolean

With objBrowser

'-- IEを表示

.Visible = True

'-- 表示位置を設定

.Top = 100 'Y位置（上下）

.Left = 200 'X位置（左右）

.Height = 800 'IEウィンドウの高さ

.Width = 650 'IEウィンドウの幅

'その他の設定

.AddressBar = False

.MenuBar = False

.StatusBar = False

.Toolbar = False

'-- 認証画面を表示

.Navigate oauthurl & "response_type=code&client_id=" & client_id & "&state=authenticated"

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

On Error Resume Next

While .Busy Or _

.ReadyState <> 4 Or _

InStr(LCase(.LocationURL), "https://www.google.com/") < 1

Debug.Print InStr(LCase(.LocationURL), "https://www.google.com/")

DoEvents

Wend

'URLの値を取得する

tempurl = objBrowser.LocationURL

.Quit

End With

'取得したコードからcode=以下を取得する

authcode = Mid(tempurl, InStr(tempurl, "code=") + 5)

'3秒間スリープさせる（これが味噌）

Sleep 3000

Dim objSh As Object

Dim objW As Object

Dim i As Integer

Set objSh = CreateObject("Shell.Application")

For i = objSh.Windows.Count To 1 Step -1

Set objW = objSh.Windows(i - 1)

If objW.FullName Like "*iexplore.exe" Then

objW.Quit

End If

'Access Tokenを取得する

tokenflg = getAccessToken(authcode)

'終了処理

If tokenflg = True Then

'Access Tokenを取得できた

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

'ウィンドウハンドルを取得し直す

Else

'Access Token取得失敗

MsgBox "認証は失敗しましたよ！！残念！"

End If

'閉じる

'ウィンドウハンドルを取得し直す

Set objBrowser = Nothing

素直に以下の作業を行い、32bitのIEを起動するようにしましょう。

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

この作業を各クライアントでやってもらうというのも不毛なので、レジストリを操作するモジュールを利用して、VBAからセットしてやる方法がスマートです。以下のコードでこの２つの設定を無効化する事が可能です。

'IEの拡張保護モードおよび64bit設定を無効にする
Call RegSetValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Main", "Isolation64Bit", REG_DWORD, 0)
Call RegSetValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Main", "Isolation", REG_SZ, "PMIL")

'IEの拡張保護モードおよび64bit設定を無効にする

Call RegSetValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Main", "Isolation64Bit", REG_DWORD, 0)

Call RegSetValue(HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Main", "Isolation", REG_SZ, "PMIL")