VBAでOAuth2.0認証 - 新方式を試してみた
2022年6月、IE11が終了するということで、以前にVBAにてOAuth2.0認証する手段として記事を投稿したことがあります。しかし、前回の記事では大きな課題を残したまま、実現は出来てるけれどそれまでの認証コードとは違い、別の手間が生じてしまっていてハードルが上がってしまいました。
しかしこの状況を打破するかもしれない、ChromeのDevToolsプロトコルを直接叩いてPuppeteerのように操縦出来、なおかつChromeのバージョンに合わせてWebDriverを更新する手間、当然自分のようにNode.js + PuppeteerをEXE化して間接的に動かすといったようなハードルもなく動かせるかも。ということで今回挑戦してみました。
※今回はGoogle APIのOAuth2.0認証を行うコードです。
目次
今回利用するファイル等
今回のライブラリは、SeleniumVBA、VBA-JSON、WebDriverを必要とせず、単体でChromeのDevToolsを叩いて操縦する為、Puppeteerと同じ手法をVBAで実装したものになります。これにより、SeleniumやWebDriverを使わせないといったような職場でも利用することが出来るだけでなく、様々なハードルが下がり、尚且つWindows11以降でもVBAでChrome操縦をして自動化が可能になります。
また、ChromeだけじゃなくEdgeも操縦出来るように作られているということなので、Chromeの使用も許可しないような厳しい環境下でも利用が可能な素晴らしいライブラリになっています。ということで、今回はEdgeを使ってリクエストを送り全部標準の環境のみで完結することが出来ました。これで、OAuth2.0認証が使えるあらゆるREST APIを気兼ねなく叩くことが可能です。
前回までの課題
課題のまとめ
Windows11の登場以降、VBAでREST APIを叩く事自体は出来ても、IE11が使えなくなった事でWebブラウザの操縦自動化やOAuth2.0の最初の認証の自動化は出来なくなってしまいました。そこで再登場したのがSelenium Basicなのですが色々と課題があり、また代替策として考えたNode.js + Puppeteerも決してハードルが低いというものではありませんでした。課題をまとめると
- Seleniumの場合、Chromeのバージョンに合わせてWebDriverも随時更新をする必要性がある
- WebDriverの自動更新用ライブラリも用意されていますが、そのための実装を加える必要性がある。
- ただし、ChromeのバージョンアップとWebDriverのバージョンアップにはタイムラグがあるので、ケースによっては動かせない期間が生じる。
- Selenium自体開発がすでに終了していて、インストール自体も管理者権限を通常要する（回避する策はあるけれど）
- Node.js + Puppeteer + pkgライブラリを使って生成したEXEを叩く手法もあれど、ハードルが高い。都度変更したい場合、ビルドし直しが必要。
- そもそも企業で使う場合、SeleniumもWebDriverもインストールを許可しないケースが多い。
VBAのみで完結するライブラリが求められていましたが今回、ZeroInstall BrowserDriver for VBAの登場でそれが変わるかもというのが今回のテーマとなります。
仕組みはPuppeteerと同じChrome Devtools Protocol（CDP）を叩くというもので、これはChromeが持ってるローカルのポートをHTTPで叩いて操縦するものになりますが、とっても大変な作業です。これを手軽に実現出来るように実装した事で、前回までの課題をクリアする事ができました。
類似のクラスファイル
今回使用するライブラリの前に、CodeProjectにあるCDPを叩いて操作するライブラリを使った事がありますが、いくつか素直ではない部分がありました。今回利用するライブラリはその点非常に素直に綺麗にコードを書けるので、本ライブラリのほうがおススメ。
CodeProjectのライブラリは、現在のURLを取得するのにJSコードを発行したり、IE時代の書き方を踏襲してるがゆえにちょっと使いにくい。
事前準備
今回はGoogleのAPIを叩くためのOAuth2.0認証を実行し、Access Tokenを取得するまでを実装します。これによりVBAからGoogle Workspaceのアプリに対して命令を送れるようになり、可能性が一気に広がります。
注意点として、このライブラリは起動済みのChromeを捕獲して操縦することは出来ないので、常に新規にChromeを起動して操縦することになります。もし起動していたら一旦閉じてからコードは実行するようにしましょう。
注意点
今回のコードやサンプルについては、あくまで動かすということだけにフォーカスしてるサンプルです。よって、実務で利用する場合には、Client IDやClient Secretといったデータはコードの中には記述せずに安全な場所にファイルとして隔離し、できれば暗号化・複合化の手段を実装して漏洩しないようにアプリ側で実装が必要です。
また、おなじくAccess TokenやRefresh Tokenの値についても同様で、今回はiniファイルに書き出ししていますが、実際にはファイル化したものは暗号化・複合化する手段を実装して読み込み・書き込みをするべきです。
VBA側の準備
以下の手順で新規に用意しておいた拡張子がxlsmのExcelのブックに対して、ライブラリを全部インポートしておきます。
- こちらのページを開き、<>Codeをクリックして、Download ZIPをクリックする
- ZIPファイルを解凍すると、中にフォルダがありsrcを開くと複数のclsファイルが入っています。
- Excel VBAの編集画面を開く
- 2.のclsファイルをすべてインポートする（まとめて掴んで、VBA画面のプロジェクトペインにドラッグアンドドロップすると一気にインポートされます）
図：ライブラリはZIPで固められてる
図：無事に全部インポート出来ました。
Google側の準備
今回は、OAuth2.0認証を行うので、GCP側でClientIDやClient Secretなどを用意する必要があります。ここでは、クライアントIDとクライアントシークレットを取得します。以下の手順で取得しましょう。
- Google Cloud Consoleの認証情報作成を開く
- 認証情報を作成をクリックする
- OAuthクライアントIDを選択する
- クライアントIDの作成では、「ウェブアプリケーション」を選択する
- 承認済みのリダイレクト URIはVBA側と同じリダイレクトURLを指定します。
- 作成ボタンを押すと、クライアントIDとクライアントシークレットが手に入るので控えておく。
- Cloud Consoleを閉じる
これで必要な情報の半分が手に入りました。この２つは大切なものなので、漏れたりしないように保存しておく必要があります。また、今回のケースは内部利用目的なので、OAuth同意画面に於いては、ユーザの種類は「内部」とし、スコープでは、VBA側で指定してるものを指定しています。
※リダイレクトURLは自社のホームページなどのURLを指定します。すると認証後にそこにAuthenticated Codeが表示されるので、このコードを取得してさらにAccess Tokenを取得する仕組みです。適当なURLを指定すると、相手側のサーバでログが残り、そこにAuthenticated Codeが記載されてるのでセキュリティ的にはよろしくありません。今回はこのサイトのホームページを指定しています。
図：クライアントID、シークレット取得しておきましょう。
図：OAuth同意画面の設定
プロキシー設定を調べる
企業内で使う場合、ウェブアクセスにプロキシーを使ってる場合には、VBAからアクセスする場合もその設定を利用する必要性があります。プロキシーを経由しなければ外に出ることができないので、プログラムが動作しません。プロキシーの設定はいろいろなパターンがありますが、一般的な設定の調べ方は以下の通り。
サーバーのアドレスとポート番号について、http://を除外して、コロンでポート番号でつなげて利用します。（例：hiroproxy.net:8080）
- コントロールパネルより「インターネットオプション」を開く
- 「接続」タブを開き、「LANの設定」を開く
- この画面でプロキシーサーバの部分にアドレスとポート名が入ってるならばこれを控えておく。
- 場合によっては、詳細設定の中の「HTTP」で指定してるサーバーアドレスとポート番号を控えておく。
- 自動構成スクリプトを使ってる場合、そこに指定されてるアドレスのファイルの中に、様々なプロキシーアドレスが入っていますので、それを一旦ダウンロードして中身をテキストエディタで開いてみる（通常はpacというファイル）
- 5.のケースの場合、pacファイル内はIF文を使ってアクセスするサイト別にプロキシーが設定されてることが多いので、もっとも一般的なサイトアクセスもしくはGoogleについてだけ定義している場合には、そのサーバーアドレスとポート番号を控えておく。
図：プロキシー設定がない場合はこの作業は不要です。
ソースコード
認証コード
初回認証用のコード
以下は今回のライブラリを使ってのEdgeを使ったOAuth2.0認証のコードになります。クライアントIDやシークレット、リダイレクトURLを入力し、実行すると、認証用URLが開かれるのでログインする。許可を与えるとリダイレクト先に飛び自動的にブラウザは終了。
Authenticated Codeは引き続き、Access Tokenを取得するフローに送られてトークンと引き換えられます。認証が完了するまで無限ループで待機してる状態になります。また今回は特にAPIを叩くわけじゃないのですが、spreadsheetsを叩く想定でscopeに対象のスコープを入れてありますが、半角スペースで区切っていれる必要があります。
リファレンスには記述がなかったのですが、クラスファイル内に現在のURLを取得するメソッドが用意されていたので、driver.urlでURLを取得し、Parse関数（後述）にて、URLからAuthenticated Codeだけを抜き出します。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
'OAuth認証用 Private Const client_id As String = "ここにクライアントIDを入れる" Private Const client_secret As String = "ここにクライアントシークレットをいれる" Private Const oauthurl As String = "https://accounts.google.com/o/oauth2/v2/auth?" Private Const tokenurl As String = "https://oauth2.googleapis.com/token" Private Const grant_type As String = "authorization_code" Private Const response_type As String = "code" Private Const redirecturl As String = "ここにリダイレクトURLを入力する" Private Const scope As String = "openid profile email https://www.googleapis.com/auth/spreadsheets" '半角スペースで区切る 'プロキシURL Const proxyuri As String = "ここにプロキシーURLを入れる" 'Puppeteerで認証コードを実行する Public Function googleAuthorization() 'iniファイルからidとpassを読み込み Dim authcode As String Dim tokenflg As Variant authcode = "" '認証用URLを構築 Dim oauthpage As String Dim param As String Dim execstatus As String Dim tempurl As String 'OAuth認証用URLの組み立て oauthpage = oauthurl & _ "access_type=offline" & "&" & _ "prompt=consent" & "&" & _ "response_type=code" & "&" & _ "State=authenticated" & "&" & _ "redirect_uri=" & redirecturl & "&" & _ "client_id=" & client_id & "&" & _ "scope=" & EncodeURL(scope) 'ライブラリを使ってEdgeを操作 Dim Driver As IWebDriver Set Driver = New EdgeDriver '認証サイトを開く Driver.OpenURL (oauthpage) '1秒待機 Driver.SleepByWinAPI 3000 'Authcodeが入るまで待機 Do While authcode = "" '現在表示されてるURLを取得 tempurl = Driver.url 'code=が含まれてるかどうかを判定 If InStr(LCase(tempurl), "code=") < 1 Then '含まれていないので待機 DoEvents Else authcode = tempurl End If Loop '取得したコードからcode=以下を取得する authcode = Parse(authcode, "code", vbString, "=", "&") '1秒待機 Driver.SleepByWinAPI 1000 'ブラウザを閉じる Driver.CloseWindow 'Access Tokenを取得する tokenflg = GetAccessToken(authcode) '終了処理 If tokenflg = True Then 'Access Tokenを取得できた MsgBox "認証が完了しました。" Exit Function Else 'Access Token取得失敗 MsgBox "認証は失敗しましたよ！！残念！" Exit Function End If End Function |
Access Tokenを取得するコード
Authenticated Codeを元にアクセストークンほかを取得する為のコードです。初回のみRefresh Tokenを取得することが可能です。1時間でトークンは有効期限を迎えるのでexpireする時間などを含めて、iniファイルに書き出すようにしています。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
'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 '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=" & redirecturl & "&" & _ "grant_type=" & grant_type 'POST通信でAccess Token等をリクエスト With CreateObject("WinHttp.WinHttpRequest.5.1") .Open "POST", tokenurl, False '.setProxy 2, proxyuri .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 Debug.Print json 'Token情報をiniファイルに書き込み 'refresh_tokenは初回連携時のみ取得可能 IniWrite "USER", "access_token", jsn.access_token IniWrite "USER", "refresh_token", jsn.refresh_token IniWrite "USER", "expire_in", jsn.expires_in IniWrite "USER", "getdate", Now() IniWrite "USER", "ExpireDate", DateAdd("s", jsn.expires_in, Now()) GetAccessToken = True Else GetAccessToken = False End If Else GetAccessToken = False End If End With End Function |
トークン寿命が切れてるかチェック
API実行時にトークン寿命が切れているかどうかをチェックする関数です。以下の場合、残り50分を切っていたらフラグを1にして返すようにしていますので、お好みの時間をセットして自動リフレッシュにつなげることが可能です。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
'Access Tokenが認証切れかどうかをチェックする '0=OK, 1=失効 Public Function checkExpireToken() As Integer '時間チェック用 Dim expireday As Variant Dim expireman As Variant Dim checkflg As Integer expireman = IniRead("USER", "ExpireDate", "") '日付を計算 expireday = DateDiff("n", Now(), expireman) 'Access Tokenがexpireしているかどうかをチェック(50分以下) If expireday <= 50 Then 'expireする日付まで50分以下の場合 checkflg = 1 Else 'Access Tokenはまだ生きてるので問題ナシ checkflg = 0 End If 'フラグを返す checkExpireToken = checkflg End Function |
トークンをリフレッシュする
トークン寿命が切れていた場合に、リフレッシュトークンを使って新しいAccess Tokenを取得する為のコードです。新しく取得するデータにはリフレッシュトークンは含まれていないのでそのまま流用します。トークンとexpireする時間を再計算してiniファイルに書き出します。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
'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 'JSON受信用 'HTMLDocumentを取得 Set doc = CreateObject("HtmlFile") 'scriptタグを追加 doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>" '送信データを組み立て Dim reftoken As Variant reftoken = IniRead("USER", "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) Debug.Print json 'Token情報を取得する access_token = jsn.access_token expire_in = jsn.expires_in 'iniファイルへ上書きする IniWrite "USER", "access_token", access_token IniWrite "USER", "expire_in", expire_in IniWrite "USER", "getdate", Now() IniWrite "USER", "ExpireDate", DateAdd("s", expire_in, Now()) 'Access Token取得成功 tempflg = True Else 'Access Token取得失敗 tempflg = False End If Case Else 'Access Token取得失敗 tempflg = False End Select End With '値を返す getNewToken = tempflg End Function |
URLからパラメータを取り出す関数
Access Tokenを取得する為のAuthenticated CodeはリダイレクトURLの中にcode=としてパラメータに含まれているため、これを取得する必要性があります。stackoverflowに便利な関数があった為、こちらを利用させていただきました。
以下の関数で、Parseに対して、「Parse(authcode, "code", vbString, "=", "&")」とするだけで、URLからcode=以下の文字列だけを抜き出すことが可能です。authcodeにはリダイレクト後のURLを格納します。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
'URLからパラメータ単位で値を取り出す関数 Function Parse(Txt As Variant, Key As String, _ Optional ReturnType As VbVarType = vbVariant, _ Optional AssignChar As String = "=", _ Optional Delimiter As String = ";") As Variant Dim StartPos As Integer, EndPos As Integer, Result As Variant Result = Null If IsNull(Txt) Then Parse = Null ElseIf Len(Key) = 0 Then EndPos = InStr(Txt, AssignChar) If EndPos = 0 Then Result = Trim(Txt) Else If InStrRev(Txt, " ", EndPos) = EndPos - 1 Then EndPos = InStrRev(Txt, Delimiter, EndPos - 2) Else EndPos = InStrRev(Txt, Delimiter, EndPos) End If Result = Trim(Left(Txt, EndPos)) End If Else StartPos = InStr(Txt, Key & AssignChar) 'Allow for space between Key and Assignment Character If StartPos = 0 Then StartPos = InStr(Txt, Key & " " & AssignChar) If StartPos > 0 Then StartPos = StartPos + Len(Key & " " & AssignChar) Else StartPos = StartPos + Len(Key & AssignChar) End If If StartPos = 0 Then Parse = Null Else EndPos = InStr(StartPos, Txt, AssignChar) If EndPos = 0 Then If Right(Txt, Len(Delimiter)) = Delimiter Then Result = Trim(Mid(Txt, StartPos, _ Len(Txt) - Len(Delimiter) - StartPos + 1)) Else Result = Trim(Mid(Txt, StartPos)) End If Else If InStrRev(Txt, Delimiter, EndPos) = EndPos - 1 Then EndPos = InStrRev(Txt, Delimiter, EndPos - 2) Else EndPos = InStrRev(Txt, Delimiter, EndPos) End If If EndPos < StartPos Then Result = Trim(Mid(Txt, StartPos)) Else Result = Trim(Mid(Txt, StartPos, EndPos - StartPos)) End If End If End If End If Select Case ReturnType Case vbBoolean If IsNull(Result) Or Len(Result) = 0 Or Result = "False" Then Parse = False Else Parse = True If IsNumeric(Result) Then If Val(Result) = 0 Then Parse = False End If End If Case vbCurrency, vbDecimal, vbDouble, vbInteger, vbLong, vbSingle If IsNumeric(Result) Then Select Case ReturnType Case vbCurrency: Parse = CCur(Result) Case vbDecimal: Parse = CDec(Result) Case vbDouble: Parse = CDbl(Result) Case vbInteger: Parse = CInt(Result) Case vbLong: Parse = CLng(Result) Case vbSingle: Parse = CSng(Result) End Select Else Select Case ReturnType Case vbCurrency: Parse = CCur(0) Case vbDecimal: Parse = CDec(0) Case vbDouble: Parse = CDbl(0) Case vbInteger: Parse = CInt(0) Case vbLong: Parse = CLng(0) Case vbSingle: Parse = CSng(0) End Select End If Case vbDate If IsDate(Result) Then Parse = CDate(Result) ElseIf IsNull(Result) Then Parse = 0 ElseIf IsDate(Replace(Result, "#", "")) Then Parse = CDate(Replace(Result, "#", "")) Else Parse = 0 End If Case vbString Parse = Nz(Result, vbNullString) Case Else If IsNull(Txt) Then Parse = Null ElseIf Result = "True" Then Parse = True ElseIf Result = "False" Then Parse = False ElseIf IsNumeric(Result) Then Parse = Val(Result) Else Parse = Result End If End Select End Function Function Nz(tgtVal As Variant, Optional VIN As Variant = Empty) As Variant Nz = IIf(IsNull(tgtVal), VIN, tgtVal) End Function |
URLエンコードする関数
認証をするコードで利用してる、スコープをURLエンコードするための関数。64bitと32bitとではオフィスで利用できるコントロールが異なります。以下は64bit版オフィスでのURLエンコードを行う為の関数です。以下のコードはこちらのサイトから利用いたしました。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 |
Private Function EncodeURL(ByVal sWord As String) As String Dim d As Object Dim elm As Object sWord = Replace(sWord, "\", "\\") sWord = Replace(sWord, "'", "\'") Set d = CreateObject("htmlfile") Set elm = d.createElement("span") elm.setAttribute "id", "result" d.body.appendChild elm d.parentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & sWord & "');", "JScript" EncodeURL = elm.innerText End Function |
関連リンク
- Excel VBAでSeleniumもWebDriverもVBA-JSONも使わないでクロームとエッジを操作するインストール不要のライブラリっぽいものつくってみた
- 【Excel】ZeroInstall BrowserDriver for VBAを使用したWebアプリ操作
- WebDriverManager-for-VBA
- Automate Chrome / Edge using VBA
- Chromium Automation for VBA - CDP Framework (ChromeDevProtocols Framework)
- 64bit版VBAでScriptControlを使用する
- 64ビット環境でのScriptControlの代わり
- VBA 64ビット環境でCreateObject("ScriptControl")がエラーになる
- GoogleAPI OAuth2.0の簡単なメモ
- How to parse URL parameters in VBA?
- Nullの代わりに他の値を使う『Nz関数』をExcelで使う方法
- 【EXCEL VBA】VBAでJSONを利用したい
- 【VBA】Microsoft Graph APIを使って、OneDriveのアイテム一覧を取得する
- あえてVBAで書くことでGmail APIを完全に理解する
