Office関連

Gmail APIを使ってメール送信するVBAマクロ(3)

前回前々回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.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.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

GmailAPI_03_01

上記コード、上にも書いた通り、日本語の件名には対応していません。
=?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に従っているわけではありませんが、これ以上やっていられないので、とりあえずはこれで良しとします。

関連記事

  1. Office関連

    PHPWordを使ってPHPからWordファイルを出力してみる。

    最近オトカドールやルミティアジュエルやらの記事ばかり書いていますが、今…

  2. Office関連

    [リボン・カスタマイズ]グループの表示・非表示をトグルボタンで切り替える。

    数年前に書いた記事に下記コメントをいただきました。Excelに…

  3. Office関連

    Windows 10 Technical PreviewにOffice XPをインストールしてみまし…

    「最新ビルドを詳細レビュー! Windows 10 Technical…

  4. Office関連

    PDFファイル上のフィールドの値を操作するVBAマクロ

    「PDFファイルに差し込み印刷するVBAマクロ」で、Acrobatを操…

コメント

    • しろやん
    • 2017年 2月 04日

    お世話になります。
    有用な公開していただきありがとうございます。
    このマクロを使わせていただこうと思っています。
    テストをしてみましたところ、メールを送信後、
    googleのアカウントからログアウトしてしまいます。
    引き続きメール送信や、GoogleDriveの利用をしたいので、
    ログアウトしないようにしたいのですが、
    どこを直せば良いかお教えください。
    お手数をおかけいたしますが、よろしくお願いします。

    • しろやん
    • 2017年 2月 04日

    お世話になります。
    先程、質問いたしましたログアウトについては、164行目をコメント化することで、
    ログアウトしないようになりました。有難うございました。
    PCを64bitマシン(win-7)に変えて、試験しましたところ、
    「ActivwXコンポーネントはオブジェクトを作成できません」とエラーメッセージで止まってしまいます。
    IEを事前に立ち上げて、Googleアカウントでログインしておいても同様です。
    有効な対処法がありましたらお教えください。
    よろしくお願いします。

    • > しろやん様

      はじめまして、当ブログの管理人です。
      ご質問いただきました件につきまして、

      > 「ActivwXコンポーネントはオブジェクトを作成できません」とエラーメッセージで止まってしまいます。

      メッセージから察すると、恐らくはどこかのCreateObject文で動作が止まってしまっているのではないかと思います。
      コードが64ビット環境に対応していない可能性もありますので、まずはステップ実行して、どこで引っかかっているのかを突き止めることをお薦めいたします。

      また、当コードはGmail APIを半ば無理やりVBAマクロから呼び出すものですので、単にメール送信を行うだけであれば、下記記事のようにCDOを使うか、BASP21 ProやOutlookといった外部コンポーネントを利用した方がコードが見やすく、シンプルになります。

      ・CDOを使ってGmail送信を行うVBAマクロ(UTF-8対応版)
      https://www.ka-net.org/blog/?p=7459

  1. この記事へのトラックバックはありません。

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP