LoginSignup
17
20

More than 5 years have passed since last update.

@nicco_mirai

あえてVBAで書くことでGmail APIを完全に理解する

Posted at

CAUTION

この記事の目的はタイトルの通りであり、
Excel VBAからGmail APIでメール送信を行うことを推奨するものではありません。
なぜなら今回使用する250行を超えるコードはOutlookを使えば

    With CreateObject("Outlook.Application").CreateItem(0)
        .To = "hogepiyo@fugafuga.com"
        .Subject = "ウニョラー"
        .Body = "トッピロキー"
        .Attachments.Add "C:\aotogarashi.png"
        .Send
    End With

の7行で置き換えが可能だからです。
よい子は決してマネをしないでください。

目標と手順

今回やりたいことは
タイトル、本文、添付ファイルのついたメールをGmail APIで送信する
で、そのための手順は以下の通りです。

  • 事前準備
    • Google Developers Consoleでプロジェクトを作る
    • Gmail APIを有効にする
    • OAuth クライアントIDを取得する
    • 認可(Authorization)して認可コードを受け取る
    • 認可コードをもとにリフレッシュトークンを取得する【API】
  • message/rfc822形式でメールを作る
  • リフレッシュトークンをアクセストークンに交換する【API】
  • メール送信【API】

事前準備の事前準備

上記手順を遂行する上でVBAちゃんに足りない機能が3つありますので予め用意しておきます。

  • JSONエンコード/デコード
  • HTTP通信
  • Base64エンコード

1つずつ解説します。

JSONエンコード/デコード

Gmail APIはJSON(あるいは無)を返します。
またmessages/sendについてはパラメータをJSONでPOSTするため、
エンコーダとデコーダの両方を用意する必要があります。

VBAでJSONを扱う方法はScriptControlでJScriptTypeInfoを作るアレが一般的かと思いますが、
64bit環境で使えないとかまあ諸々問題もあるので今回は外部ライブラリを使います。
https://github.com/VBA-tools/VBA-JSON
のJsonConverter.basをインポートしてください。

このライブラリについても少し触れましょう。
関数ParseJsonはJSONの文字列を与えると配列を返します。
関数ConvertToJsonは配列を与えるとJSONを返します。
ここでいう配列とは
連想配列{}がDictionary、配列[]がCollectionを指します。
Microsoft Scripting Runtimeへの参照設定がないと怒られるので、
必要であれば該当の箇所をCreateObject("Scripting.Dictionary")
に書き換えてください。

クエリ文字列コンバータ

上でも少し触れましたが、Gmail APIはパラメータをJSONで受け取るものとクエリ文字列で受け取るものとがあります。
JSONほど難しくないにしろクエリ文字列を自分で書くのもバカらしいので
上記ConvertToJsonと使い方を揃えて「連想配列を受けとるとクエリ文字列を返す関数」を作りましょう。

Private Function ConvertToQueryString( _
    ByVal dic As Object) As String

    If dic Is Nothing Then Exit Function
    '受け取った連想配列のkeyとvalueを繋げてクエリ文字列を作る
    Dim key As Variant
    For Each key In dic.keys
        ConvertToQueryString = ConvertToQueryString & "&" & key & "=" & dic.Item(key)
    Next

End Function

これでHTTP通信を行う関数を作る準備が整いました。

HTTP通信

XMLHTTPオブジェクトを使用し、
指定したURIにリクエストを送って返ってきたJSONを連想配列にして渡す関数を作ります。
パラメータの変換には先ほどのConvertToJsonおよびConvertToQueryStringを使用しています。

Private Function KickAPI( _
    ByVal method As String, _
    ByVal tgtAPI As String, _
    Optional ByVal param As Object, _
    Optional ByVal paramType As String, _
    Optional ByVal accessToken As String) As Object

    With CreateObject("MSXML2.XMLHTTP")
        .Open method, tgtAPI, False
        'アクセストークンがあればヘッダーに記述
        If accessToken <> "" Then _
            .SetRequestHeader "Authorization", "Bearer " & accessToken
        'パラメータを指定した形に変換してリクエスト送信
        Select Case paramType
        Case "JSON"
            .SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
            .send (ConvertToJson(param))
        Case "QueryString", ""
            .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            .send (ConvertToQueryString(param))
        End Select
        '不具合が出た場合は↓をアンコメントしてレスポンスを確認
        'Debug.Print .ResponseText
        'JSONが返されたらパース
        Set KickAPI = IIf(.ResponseText = "", _
            CreateObject("Scripting.Dictionary"), _
            ParseJson(.ResponseText))
    End With

End Function

Base64エンコード

Basic認証でおなじみBase64(wiki)へのエンコードはWinAPIを用いる方法と
DOMDocument/Streamを組み合わせる方法がありますが、今回は書くのが楽な後者を使います。

Private Function EncodeBase64( _
    ByVal tgtType As String, _
    ByVal target As String, _
    ByVal urlSafe As Boolean) As String

    Dim base64 As Object
    Set base64 = CreateObject("MSXML2.DOMDocument").createElement("base64")
    base64.DataType = "bin.base64"

    With CreateObject("ADODB.Stream")
        Select Case tgtType
        Case "File"
            .Type = 1 'adTypeBinary
            .Open
            .LoadFromFile target
        Case "Str"
            .Type = 2 'adTypeText
            .Charset = "UTF-8"
            .Open
            .WriteText target
            .Position = 0
            .Type = 1 'adTypeBinary
            .Position = 3
        End Select
        base64.nodeTypedValue = .Read
        .Close
    End With

    EncodeBase64 = base64.Text
    'URLの予約語を取り除く
    If urlSafe = True Then _
        EncodeBase64 = Replace(Replace(EncodeBase64, "+", "-"), "/", "_")

End Function

添付ファイルのエンコード、文字列のエンコード、またそれぞれに対してURLセーフにするかどうかを指定できますが、
これについてはまた後ほど説明します。

事前準備

ようやくここから事前準備ですが、

  • Google Developers Consoleでプロジェクトを作る
  • Gmail APIを有効にする
  • OAuth クライアントIDを取得する

上記についてはネット上に無限に解説が転がっているので省略します。
クライアントIDを取得したら、赤枠で囲ったアイコンからJSONファイルをダウンロードしてください。
01_GoogleDevConsole.png

宣言セクションにいくつかモジュールレベル変数を定義します。

'↓自分のGmailアドレス
Const USER_ID As String = "piyohoge@fugafuga.com"
'↓OAuthクライアントIDを作成したら入力
Const CLIENT_ID As String = "～.apps.googleusercontent.com"
Const CLIENT_SECRET As String = "～"
Const AUTH_URI As String = "https://accounts.google.com/～"
Const TOKEN_URI As String = "https://www.googleapis.com/～"
Const REDIRECT_URI As String = "urn:ietf:wg:oauth:2.0:oob"
'↓認可コードを入手したら入力
Const AUTHORIZATION_CODE = ""
'↓リフレッシュトークンを入手したら入力
Const REFRESH_TOKEN As String = ""

これの4行目～8行目(CLIENT_ID～REDIRECT_URI)にはダウンロードしたJSONの内容を転記します。
※もし万が一業務で使用される場合はこの実装ではなく都度JSONを読み込んでください。
他の解説記事などを読んでいると認可用URIやトークン用URIが固定だったりするのですが、わりと嵌ります。
ダウンロードしたJSONを信じろ。

認可(Authorization)して認可コードを受け取る

URIを組み立ててブラウザで開きます。
せっかくなので楽にやりましょう。

Public Sub GetAuthorizationURI()

    Dim param As Object
    Set param = CreateObject("Scripting.Dictionary")
    With param
        .Add "response_type", "code"
        .Add "client_id", CLIENT_ID
        .Add "redirect_uri", REDIRECT_URI
        .Add "scope", "https://mail.google.com/"
        'エラーが出たらURLエンコードしたこっち
        '.Add "scope", "https%3A%2F%2Fmail.google.com%2F"
    End With

    Debug.Print AUTH_URI & "?" & ConvertToQueryString(param)

End Sub

実行するとイミディエイトウィンドウに組み立てられたURIが表示されます。
認可コードは上記AUTHORIZATION_CODEに転記してください。

認可コードをもとにリフレッシュトークンを取得する【API】

TOKEN_URIに認可コード他もろもろのパラメータをPOSTするとアクセストークンを取得できますが、
access_typeにofflineを設定することで同時にリフレッシュトークンも取得することができます。
参考：Google APIのAccess Tokenをお手軽に取得する

Public Sub GetRefreshToken()

    Dim param As Object
    Set param = CreateObject("Scripting.Dictionary")
    With param
        .Add "code", AUTHORIZATION_CODE
        .Add "client_id", CLIENT_ID
        .Add "client_secret", CLIENT_SECRET
        .Add "redirect_uri", REDIRECT_URI
        .Add "grant_type", "authorization_code"
        .Add "access_type", "offline"
    End With

    Debug.Print KickAPI("POST", TOKEN_URI, param).Item("refresh_token")

End Sub

こちらも同様に実行するとイミディエイトウィンドウにリフレッシュトークンが表示されますので、
REFRESH_TOKENに転記してください。

message/rfc822形式でメールを作る

https://developers.google.com/gmail/api/v1/reference/users/messages/send?hl=ja
をざっくり要約すると

  • https://w ww.googleapis.com/gmail/v1/users/userId/messages/sendに
  • message/rfc822形式で作ったメールを
  • rawパラメータにセットしたJSONを
  • POSTしろ

ということになりますので、まずはメールを作りましょう。
この段落の目標地点はこれ↓です。
MIME（Multipurpose Internet Mail Extensions）～後編

クラスモジュールを作る

マルチパートメールの構造が

  • ヘッダーとボディを持つ構造体の入れ子
  • ヘッダーのデータ形式はKye-Valueストア

ということを考えると、最初から文字列で作っていくよりも
オブジェクトのプロパティにデータを持たせて文字列にコンバートした方が楽かつスマートです。

Mime
Public Header As Object
Public Body As Object

Private Sub Class_Initialize()
    Set Header = CreateObject("Scripting.Dictionary")
    Set Body = New Collection
End Sub

Public Function ConvertToStr(ByVal boundaryStr As String) As String

    ConvertToStr = DicToStr(Header) & "--" & boundaryStr & vbCrLf
    Dim part As Variant
    For Each part In Body
        ConvertToStr = ConvertToStr & _
            DicToStr(part.Header) & part.Body(1) & vbCrLf & "--" & boundaryStr & vbCrLf
    Next
    ConvertToStr = Left(ConvertToStr, Len(ConvertToStr) - 2) & "--"

End Function

Private Function DicToStr(ByVal dic As Object) As String

    Dim key As Variant
    For Each key In dic
        DicToStr = DicToStr & key & ": " & dic(key) & vbCrLf
    Next
    DicToStr = DicToStr & vbCrLf

End Function

このMimeクラスはDictionaryオブジェクト(連想配列)の入ったHeaderプロパティと
Collectionオブジェクト(配列)の入ったBodyプロパティを持ち、
ConvertToStrメソッドでそれらを組み合わせたマルチパートメール文字列を生成します。

クラスを使う関数を作る

Private Function CreateMail( _
    ByVal mailTo As String, _
    ByVal mailSubject As String, _
    ByVal mailBody As String, _
    ByVal AttachedFilePath As String, _
    ByVal boundaryStr As String) As String

    Dim mail As Mime
    Set mail = New Mime

    'ヘッダー
    With mail.Header
        .Add "To", mailTo
        .Add "Subject", "=?utf-8?B?" & EncodeBase64("Str", mailSubject, False) & "?="
        .Add "MIME-Version", "1.0"
        .Add "Content-Type", "multipart/mixed; boundary=""" & boundaryStr & """"
    End With

    'ボディ(1) 本文
    mail.Body.Add New Mime
    With mail.Body(1)
        With .Header
            .Add "Content-Type", "text/plain; charset=""utf-8"""
            .Add "Content-Transfer-Encoding", "base64"
        End With
        .Body.Add EncodeBase64("Str", mailBody, False)
    End With

    Dim AttachedFileName As String
    AttachedFileName = CreateObject("Scripting.FileSystemObject").GetFileName(AttachedFilePath)

    'ボディ(2) 添付ファイル
    mail.Body.Add New Mime
    With mail.Body(2)
        With .Header
            .Add "Content-Type", "application/octet-stream; name=""" & AttachedFileName & """"
            .Add "Content-Transfer-Encoding", "base64"
            .Add "Content-Disposition", "attachment; filename=""" & AttachedFileName & """"
        End With
        .Body.Add EncodeBase64("File", AttachedFilePath, False)
    End With

    CreateMail = mail.ConvertToStr(boundaryStr)

End Function

タイトル及び添付ファイルはそれぞれURLセーフではないBase64でエンコードします。
こうして出来上がったメール全体をもう一度URLセーフなBase64でエンコードすることにより、
文字化けせずにメールを送信することができます。

確認

test
Debug.Print CreateMail( _
    "hogepiyo@fugafuga.com", _
    "ウニョラー", _
    "トッピロキー", _
    "C:\aotogarashi.png", _
    "HippoloKeiNyaporn")
return
To: hogepiyo@fugafuga.com
Subject: =?utf-8?B?44Km44OL44On44Op44O8?=
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="HippoloKeiNyaporn"

--HippoloKeiNyaporn
Content-Type: text/plain; charset="utf-8"
Content-Transfer-Encoding: base64

44OI44OD44OU44Ot44Kt44O8
--HippoloKeiNyaporn
Content-Type: application/octet-stream; name="aotogarashi.png"
Content-Transfer-Encoding: base64
Content-Disposition: attachment; filename="aotogarashi.png"

iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeCAIAAAC0Ujn1AAAABGdBTUEAALGPC/xhBQAAACBj
SFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAABmJLR0QA/wD/AP+g
vaeTAAAAB3RJTUUH4gkSBAAdBFcpSQAAA89JREFUSMfNlktMnFUUx8+59/uYGQoyoOKIj1JK
hKBWpIEItG5q6cK00IXRlS4whjStxGjSNtKFIbGtBg2x1kahGx+JkvhKaxeoTUsaQqeNUh9o
S3kIM87jozAMzDDzffccF59BpIN0KE08q5vcc3/53/855+YiM8OtCXGLuP9vNDMzpLb0ptDE
hIgImJK+cjSxEiiM2bFgdDglfYVoZhIoY+Z0V/9Bl569tFlphqUsImbmY+d2/fJnDzMrsq5P
W4FqlkIiwvdXjpvKKvNsUmQKlNfnaWn6SwLFsZ4j3w226beNtDzeAwCIqfWlodoiS6Do7O14
7Ys9lwdCp0/B0B+jtqU3hSYmTWjG7MSh7gP5jryhQRXog3z5AADgAggDM1N6aFvaqyf2usiy
Zhwz3sSBxpaq8krTMlGgDSVWCIgowG7EG2kJU5nMfHboTGHLnWXNa2EjbG/avrAx5hfBmasD
Ro+9Xr6MDCxQAMDh7jfC/og5FoEIvL3/LQAQKBNm0uRYVoY7bk2fGnyHgasKGuxTy6OJlBTa
wW9bu/tOirAz+dvc3t371t9fPDDyw8d9H4xGf5e5U1s2lASM2NaiXeV31dlcBMT/fq9NZepS
P3ru3dbPd3MoM+iNPfvkc++93t5+orWr/6PMHM3hcFpW0l3ga9/mLcypUGwKkHY7LqmamJhZ
l/qn/Z+1nWyWEy5ff6x0bWn1tgefaHuUda24qDQ6G/1xyBcYDj5du7Mwp0KRJYU+T1ismpgY
mIh0qQPA8b73D3/5UjSoJgLs0MRDj60LZ4QF5uQJ97jfNz4agDA01Tcd2XNUSmRmREyBVqQE
ivm9ydjUC12N3svf6GbmHMqCuzNzsvTYXCI8JYxQ9NrYNZiCnZsbXn7qldqHawGAmRaN5WLV
l8YvGXEjTvE3ew5dCf9UdnuRS4LFVjyeDBoz/lA04pt2oqNxy/P11Tu2VtYBABEh4kK9f6OJ
CQEjsciFkQufeD887+tlTQkd3I4sDUR8LjY5PT0SNBKTJsTBs8azuWTTvmf2V5RU2DOhSGky
dcHQ9uHri1919nb8Gv450+WaUwkjYkjQJGToSs/V89a71z1yX3lNSXVlSZU72w0AlrIQUQoJ
S4dmX2THxvrh4PDFq+f9Ib8ArX5Dw4t1zffm3uPUnblrclH8Y6IihYBLKf23IUSIOBYe6zzd
4bnDk+XMrimuKcovWpikSNnVX1jn5dH2vC86oEgBgD3fgIBwo7gUHWIXxCYIFAJX4X+yzKCn
FclkEhGJSNd1IcRq/p6SyaRlWYlEgohWWfWi+AuRsmwTF/dycwAAACV0RVh0ZGF0ZTpjcmVh
dGUAMjAxOC0wOS0xOFQwNDowMDoyOSswMDowMP7ImCYAAAAldEVYdGRhdGU6bW9kaWZ5ADIw
MTgtMDktMThUMDQ6MDA6MjkrMDA6MDCPlSCaAAAAGXRFWHRTb2Z0d2FyZQBBZG9iZSBJbWFn
ZVJlYWR5ccllPAAAAABJRU5ErkJggg==
--HippoloKeiNyaporn--

メール送信【API】

あとは先ほど作成したメールを受け取ってGmail APIをキックする関数を作って完了です。

Private Function sendMail(ByVal mail As String) As String

    Dim apiList As Object
    Set apiList = CreateObject("Scripting.Dictionary")
    With apiList
        .Add "TokenGet", TOKEN_URI
        .Add "MailSend", "https://www.googleapis.com/gmail/v1/users/" & USER_ID & "/messages/send"
        .Add "MailDelete", "https://www.googleapis.com/gmail/v1/users/" & USER_ID & "/messages/"
        .Add "TokenInfo", TOKEN_URI & "info"
    End With

    Dim param As Object
    Set param = CreateObject("Scripting.Dictionary")

    'リフレッシュトークンをアクセストークンに交換
    Dim accessToken As String
    With param
        .Add "refresh_token", REFRESH_TOKEN
        .Add "client_id", CLIENT_ID
        .Add "client_secret", CLIENT_SECRET
        .Add "redirect_uri", REDIRECT_URI
        .Add "grant_type", "refresh_token"
    End With
    accessToken = KickAPI("POST", apiList("TokenGet"), param, "QueryString").Item("access_token")
    param.RemoveAll

    'メール送信
    Dim mailID As String
    param.Add "raw", EncodeBase64("Str", mail, True)
    mailID = KickAPI("POST", apiList("MailSend"), param, "JSON", accessToken).Item("id")
    param.RemoveAll

    '*-*-*-*-*送信したメールをボックスから削除*-*-*-*-*
    'apiList("MailDelete") = apiList("MailDelete") & mailID
    'KickAPI "DELETE", apiList("MailDelete"), , , accessToken

    '*-*-*-*-*トークンの有効期限を確認*-*-*-*-*
    'param.Add "access_token", accessToken
    'Debug.Print KickAPI("POST", apiList("TokenInfo"), param).Item("expires_in")
    'param.RemoveAll

    sendMail = mailID

End Function

EncodeBase64("Str", mail, True)の第3引数がTrueになっていることに注意してください。
送信するメールはURLセーフである必要があります。

またmessages/sendは送信したメールのID(を含むJSON)を返すため、
それを用いて送信済みボックスから履歴を削除することもできます。
※ある程度sleepを挟む必要はありますので調整してください。

終わりに

冒頭で堂々とCAUTIONとか書いておいてアレですが、実際に1年ほど前に業務で使いかけたコードです。
色々と勉強になりましたが、本当に別の言語を使った方がいいです。好きですけどね、VBA。

17
20
3

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
17
20