前回、前々回とGmail APIを扱ってきましたが、今回は前々回の記事で紹介したコードを改修して、添付ファイル＆64ビット版Officeに対応したコードを紹介します。

※ 下記コードは日本語本文には対応していますが、件名に日本語を入れると文字化けします。

Option Explicit

'--------------------------------------------------
'※ 要変更
'--------------------------------------------------
Private Const email As String = "(Gメールアドレス(アカウントID))"
Private Const passwd As String = "(Google アカウントのパスワード)"
Private Const client_id As String = "(クライアント ID)"
Private Const client_secret As String = "(クライアント シークレット)"
'--------------------------------------------------

Private Const response_type As String = "code"
Private Const redirect_uri As String = "urn:ietf:wg:oauth:2.0:oob"
Private Const scope As String = "https://www.googleapis.com/auth/gmail.compose"
Private Const grant_type As String = "authorization_code"

Public Sub Sample()
  SendGmail email, _
            "(Toアドレス)", _
            "(Ccアドレス)", _
            "(Bccアドレス)", _
            "Test", _
            "■ 本文テスト：" & vbCrLf & vbCrLf & _
            "あいうえお" & vbCrLf & _
            "かきくけこ" & vbCrLf & _
            "さしすせそ" & vbCrLf & _
            "たちつてと" & vbCrLf & _
            "なにぬねの" & vbCrLf & _
            "はひふへほ" & vbCrLf & _
            "まみむめも", _
            "C:\Test\サンプル.pdf"
End Sub

Private Sub SendGmail(ByVal MailFrom As String, _
                      ByVal MailTo As String, _
                      ByVal MailCc As String, _
                      ByVal MailBcc As String, _
                      ByVal MailSubject As String, _
                      ByVal MailBody As String, _
                      Optional ByVal AttachmentFilePath As String = "")
'Gmail API v1を使ってメール送信
  Dim access_token As String
  Dim mail_dat As String
  Dim raw_dat As String
  Dim dat As Variant
  
  access_token = GetAccessToken
  If Len(Trim(access_token)) > 0 Then
    mail_dat = CreateMailData(MailFrom, _
                              MailTo, _
                              MailCc, _
                              MailBcc, _
                              MailSubject, _
                              MailBody, _
                              AttachmentFilePath)
    raw_dat = EncodeBase64Str(mail_dat)
    dat = "{""raw"": """ & DelBreak(raw_dat) & """}"
    With CreateObject("WinHttp.WinHttpRequest.5.1")
      .Open "POST", "https://www.googleapis.com/gmail/v1/users/me/messages/send"
      .SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
      .SetRequestHeader "Authorization", "Bearer " & access_token
      .Send dat
      Select Case .Status
        Case 200
          MsgBox "メールを送信しました。", vbInformation + vbSystemModal
        Case Else
          MsgBox "エラーが発生しました。" & vbCrLf & vbCrLf & .responseText, vbCritical + vbSystemModal
      End Select
    End With
  End If
End Sub

Private Sub WaitIE(ByRef IEObj As Object)
'表示待ち
  Const READYSTATE_COMPLETE = 4
  While IEObj.Busy Or IEObj.readyState <> READYSTATE_COMPLETE
    DoEvents
  Wend
End Sub

Private Function GetAuthorizationCode() As String
'Authorization code取得
  Dim ie As Object
  Dim url As String
  Dim ancAcaa As Object
  Dim iptEmail As Object
  Dim iptPasswd As Object
  Dim iptSignIn As Object
  Dim iptCode As Object
  Dim btnApprove As Object
  Dim auth_code As String
  
  '初期化
  Set ancAcaa = Nothing
  Set iptEmail = Nothing
  Set iptPasswd = Nothing
  Set iptSignIn = Nothing
  Set iptCode = Nothing
  Set btnApprove = Nothing
  auth_code = ""
  
  url = "https://accounts.google.com/o/oauth2/auth?" & _
        "client_id=" & client_id & "&" & _
        "response_type=" & response_type & "&" & _
        "redirect_uri=" & redirect_uri & "&" & _
        "scope=" & EncodeURL(scope)
  
  Set ie = CreateObject("InternetExplorer.Application")
  With ie
    .Visible = True
    .Navigate url
    WaitIE ie
    
    '複数アカウント存在時の処理
    If InStr(LCase(.document.Location.href), "https://accounts.google.com/servicelogin") Then
      With .document
        On Error Resume Next
        Set ancAcaa = .getElementById("account-chooser-add-account")
        On Error GoTo 0
        If Not ancAcaa Is Nothing Then ancAcaa.Click
      End With
      WaitIE ie
    End If
    
    '未ログイン時のログイン処理
    If InStr(LCase(.document.Location.href), "https://accounts.google.com/servicelogin") Then
      With .document
        On Error Resume Next
        Set iptEmail = .getElementById("Email")
        Set iptPasswd = .getElementById("Passwd")
        Set iptSignIn = .getElementById("signIn")
        On Error GoTo 0
        If Not iptEmail Is Nothing Then iptEmail.Value = email
        If Not iptPasswd Is Nothing Then iptPasswd.Value = passwd
        If Not iptSignIn Is Nothing Then iptSignIn.Click
      End With
      WaitIE ie
    End If
    
    '承認処理
    If InStr(LCase(.document.Location.href), "https://accounts.google.com/o/oauth2/auth") Then
      With .document
        On Error Resume Next
        Set btnApprove = .getElementById("submit_approve_access")
        On Error GoTo 0
        If Not btnApprove Is Nothing Then
          While btnApprove.disabled <> False
            DoEvents
          Wend
          btnApprove.Click
        End If
      End With
      WaitIE ie
    End If
    
    'Authorization code取得処理
    If InStr(LCase(.document.Location.href), "https://accounts.google.com/o/oauth2/approval") Then
      With .document
        On Error Resume Next
        Set iptCode = .getElementById("code")
        On Error GoTo 0
        If Not iptCode Is Nothing Then auth_code = iptCode.Value
      End With
      .Navigate "https://accounts.google.com/o/logout" 'ログアウト
      WaitIE ie
    End If
    .Quit
  End With
  GetAuthorizationCode = auth_code
End Function

Private Function GetAccessToken() As String
'Access token取得
  Dim auth_code As String
  Dim access_token As String
  Dim json As String
  Dim dat As Variant
  Dim d As Object
  Dim elm As Object
  
  access_token = "" '初期化
  auth_code = GetAuthorizationCode
  If Len(Trim(auth_code)) > 0 Then
    dat = "code=" & auth_code & "&" & _
          "client_id=" & client_id & "&" & _
          "client_secret=" & client_secret & "&" & _
          "redirect_uri=" & redirect_uri & "&" & _
          "grant_type=" & grant_type
    With CreateObject("WinHttp.WinHttpRequest.5.1")
      .Open "POST", "https://accounts.google.com/o/oauth2/token"
      .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
      .Send dat
      If .Status = 200 Then
        json = .responseText
        If Len(Trim(json)) > 0 Then
          json = "(" & .responseText & ")"
          Set d = CreateObject("htmlfile")
          Set elm = d.createElement("span")
          elm.setAttribute "id", "result"
          d.body.appendChild elm
          d.parentWindow.execScript "document.getElementById('result').innerText=eval(" & json & ").access_token;"
          access_token = elm.innerText
        End If
      End If
    End With
  End If
  GetAccessToken = access_token
End Function

Private Function CreateMailData(ByVal MailFrom As String, _
                                ByVal MailTo As String, _
                                ByVal MailCc As String, _
                                ByVal MailBcc As String, _
                                ByVal MailSubject As String, _
                                ByVal MailBody As String, _
                                Optional ByVal AttachmentFilePath As String = "") As String
'メールデータ作成
  Dim mail_dat As String
  Dim rnd_str As String
  Dim boundary As String
  Dim enc_atch As String
  Dim fso As Object
  
  mail_dat = "": rnd_str = "": boundary = "": enc_atch = "" '初期化
  rnd_str = MakeRndStr(20)
  boundary = "----_" & rnd_str & "_MULTIPART_MIXED_"
  
  mail_dat = "Content-Type: multipart/mixed;boundary=""" & boundary & """" & vbCrLf
  mail_dat = mail_dat & "Content-Transfer-Encoding: base64" & vbCrLf
  'mail_dat = mail_dat & "Content-Transfer-Encoding: UTF-8" & vbCrLf '日本語件名の場合なぜか「UTF-8」でエラーにならない？
  mail_dat = mail_dat & "From: " & MailFrom & vbCrLf
  mail_dat = mail_dat & "To: " & MailTo & vbCrLf
  If Len(Trim(MailCc)) > 0 Then mail_dat = mail_dat & "Cc: " & MailCc & vbCrLf
  If Len(Trim(MailBcc)) > 0 Then mail_dat = mail_dat & "Bcc: " & MailBcc & vbCrLf
  'mail_dat = mail_dat & "Subject: =?UTF-8?B?" & EncodeBase64Str(MailSubject) & "?=" & vbCrLf
  mail_dat = mail_dat & "Subject: " & MailSubject & vbCrLf
  mail_dat = mail_dat & "MIME-Version: 1.0" & vbCrLf
  mail_dat = mail_dat & "Importance: normal" & vbCrLf
  mail_dat = mail_dat & "Priority: normal" & vbCrLf & vbCrLf
  mail_dat = mail_dat & "--" & boundary & vbCrLf
  mail_dat = mail_dat & "Content-Type: text/plain;charset=""UTF-8""" & vbCrLf
  mail_dat = mail_dat & "Content-Transfer-Encoding: base64" & vbCrLf & vbCrLf
  mail_dat = mail_dat & EncodeBase64Str(MailBody) & vbCrLf & vbCrLf
  If Len(Trim(AttachmentFilePath)) > 0 Then
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(AttachmentFilePath) Then
      enc_atch = EncodeBase64(AttachmentFilePath)
      enc_atch = DelBreak(enc_atch)
      enc_atch = SplitStr(enc_atch, 76)
      mail_dat = mail_dat & "--" & boundary & vbCrLf
      mail_dat = mail_dat & "Content-Type: application/octet-stream;name=""" & fso.GetFileName(AttachmentFilePath) & """" & vbCrLf
      mail_dat = mail_dat & "Content-Transfer-Encoding: base64" & vbCrLf
      mail_dat = mail_dat & "Content-Disposition: attachment;filename=""" & fso.GetFileName(AttachmentFilePath) & """" & vbCrLf & vbCrLf
      mail_dat = mail_dat & enc_atch & vbCrLf & vbCrLf
    End If
  End If
  mail_dat = mail_dat & "--" & boundary & "--" & vbCrLf
  CreateMailData = mail_dat
End Function

Private Function EncodeURL(ByVal str As String) As String
'URLエンコード
  Dim d As Object
  Dim elm As Object
  
  str = Replace(str, "\", "\\")
  str = Replace(str, "'", "\'")
  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('" & str & "');", "JScript"
  EncodeURL = elm.innerText
End Function

Private Function EncodeBase64(ByVal file_path As String) As String
'ファイルをBase64エンコード
  Dim elm As Object
  Dim ret As String
  Const adTypeBinary = 1
  Const adReadAll = -1
  
  ret = "" '初期化
  On Error Resume Next
  Set elm = CreateObject("MSXML2.DOMDocument").createElement("base64")
  With CreateObject("ADODB.Stream")
    .Type = adTypeBinary
    .Open
    .LoadFromFile file_path
    elm.DataType = "bin.base64"
    elm.nodeTypedValue = .Read(adReadAll)
    ret = elm.Text
    .Close
  End With
  On Error GoTo 0
  EncodeBase64 = ret
End Function

Private Function EncodeBase64Str(ByVal str As String) As String
'文字列をBase64エンコード
  Dim ret As String
  Dim d() As Byte
  
  Const adTypeBinary = 1
  Const adTypeText = 2
  
  ret = "" '初期化
  On Error Resume Next
  With CreateObject("ADODB.Stream")
    .Open
    .Type = adTypeText
    .Charset = "UTF-8"
    .WriteText str
    .Position = 0
    .Type = adTypeBinary
    .Position = 3
    d = .Read()
    .Close
  End With
  With CreateObject("MSXML2.DOMDocument").createElement("base64")
    .DataType = "bin.base64"
    .nodeTypedValue = d
    ret = .Text
  End With
  On Error GoTo 0
  EncodeBase64Str = ret
End Function

Private Function DelBreak(ByVal str As String) As String
'改行削除
  Dim ret As String
  
  ret = "" '初期化
  ret = Replace(str, vbNewLine, "")
  ret = Replace(ret, vbCr, "")
  ret = Replace(ret, vbLf, "")
  DelBreak = ret
End Function

Private Function SplitStr(ByVal str As String, ByVal num As Long) As String
'文字列を指定した文字数で分割・結合
  Dim ret As String
  Dim i As Long
  
  ret = "" '初期化
  For i = 1 To Len(str) Step num
    If i = 1 Then
      ret = Mid(str, i, num)
    Else
      ret = ret & vbCrLf & Mid(str, i, num)
    End If
  Next
  SplitStr = ret
End Function

Private Function MakeRndStr(ByVal num As Long) As String
'0-9,A-Zまでのランダムな文字列を生成
  Dim ret As String
  Dim n As Long
  
  ret = "" '初期化
  Do
    n = RndScope(48, 90)
    Select Case n
      Case 58 To 64
      Case Else
        ret = ret & ChrW(n)
    End Select
  Loop Until Len(ret) = num
  MakeRndStr = ret
End Function

Private Function RndScope(ByVal num_min As Long, num_max As Long) As Long
'指定した範囲の乱数を生成
  Dim ret As Long
  
  Randomize
  ret = Int(Rnd() * (num_max - num_min + 1) + num_min)
  RndScope = ret
End Function

上記コード、上にも書いた通り、日本語の件名には対応していません。
「=?UTF-8?B?(略)?=」のようにして、問題無く送信できる場合もあればエラーが発生する場合もあり、同じ件名でもエラーが起きたり起きなかったり、「Content-Transfer-Encoding: UTF-8」なんていう謎のヘッダーを入れたらエラーが起きなくなったりと、とにかく挙動がおかしかったので、結局最後は“件名には日本語を使わない”、というところに落ち着きました。

API側が返すエラーも「Invalid value for ByteString」だけで、正直どこにどんな問題があるのか分かりませんでした・・・。

■ 関連Webページ

・Gmail APIを使ってメール送信するVBAマクロ
//www.ka-net.org/blog/?p=4524
・Gmail APIを使ってメール送信するVBAマクロ(2)
//www.ka-net.org/blog/?p=4538

■ あとがき

最初はメールデータの作成にCDOを使おうとしましたが、CDOで作成したデータだとメールアドレスの「<>」でエラーになったりと、問題がかなり多かったので、結局全て自分で書くことになりました・・・。
厳密にRFC 822に従っているわけではありませんが、これ以上やっていられないので、とりあえずはこれで良しとします。