Office関連

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

「Gmail API」β版公開、連動アプリ開発を支援」にもあるように、先日Gmail APIがようやく公開されました。

・Gmail API – Google Developers
https://developers.google.com/gmail/api/

このAPIを使えばGメールのメッセージの読み込みやメール送信ができるようなので、早速VBAマクロから使ってみました。

■ クライアント IDとクライアント シークレットの取得

APIの紹介で、

Designed to let you easily deliver Gmail-enabled features, this new API is a standard Google API, which gives RESTful access to a user’s mailbox under OAuth 2.0 authorization. It supports CRUD operations on true Gmail datatypes such as messages, threads, labels and drafts.

Introducing the new Gmail API – Google Apps Developer Blog より

とあるように、このAPIはOAuth 2.0認証でRESTfulなAPIですので、まずはマクロからOAuth 2.0認証を行わなくてはいけません。

認証方法は「Using OAuth 2.0 for Installed Applications – Google Accounts Authentication and Authorization – Google Developers」にあるように、

  1. Google アカウントでサインインします。
  2. 承認後Authorization codeを取得します。
  3. Authorization codeを元に発行したAccess tokenを取得します。

GmailAPI_01_01

Using OAuth 2.0 for Installed Applications – Google Accounts Authentication and Authorization – Google Developers より

といった流れになります。
ここで必要になるのがクライアント IDクライアント シークレットで、マクロを書く前にまずはこれらを準備する必要があります。

  1. Google Developers ConsoleにアクセスしてGoogle アカウントでサインインします。
  2. プロジェクトを作成」ボタンをクリックして新しいプロジェクトを作成します(プロジェクト名は適当)。
  3. GmailAPI_01_02

    GmailAPI_01_03

    GmailAPI_01_04

  4. API画面から「Gmail API」を有効にします。
  5. GmailAPI_01_05

    GmailAPI_01_06

  6. 認証情報画面から「新しいクライアント IDを作成」ボタンをクリックします。
  7. GmailAPI_01_07

  8. アプリケーションの種類は「インストールされているアプリケーション」、インストールされているアプリケーションの種類は「その他」を選択し、「クライアント IDを作成」ボタンをクリックします。
  9. GmailAPI_01_08

  10. ネイティブ アプリケーションのクライアント IDが作成されるので、作成された「クライアント ID」、「クライアント シークレット」、「リダイレクト URI」をテキストエディタにでもメモしておきます。
  11. GmailAPI_01_09

以上で下準備は完了です。

■ VBAコード

2014/07/01 追記:
添付ファイル&64ビット版Officeに対応したコードも書きました。

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

実際に作成したマクロが下記になります。
(メールアドレスやクライアント ID、クライアント シークレットは自分の環境に合わせて変更する必要があります。)

※ 下記コードはScript Controlを使っているため、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://mail.google.com/"
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, "(送信先メールアドレス)", "Sample Mail", "Hello." & vbCrLf & "kinuasa."
End Sub

Private Sub SendGmail(ByVal MailFrom As String, _
                      ByVal MailTo As String, _
                      ByVal MailSubject As String, _
                      ByVal MailBody 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 = "From: " & MailFrom & vbCrLf & _
               "To: " & MailTo & vbCrLf & _
               "Subject: " & MailSubject & vbCrLf & vbCrLf & _
               MailBody
    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 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 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
        Set iptEmail = .getElementById("Email")
        Set iptPasswd = .getElementById("Passwd")
        Set iptSignIn = .getElementById("signIn")
        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
        Set btnApprove = .getElementById("submit_approve_access")
        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
        Set iptCode = .getElementById("code")
        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 json As String
  Dim access_token As String
  Dim dat As Variant
  
  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 & ")"
          With CreateObject("ScriptControl")
            .Language = "JScript"
            access_token = .CodeObject.eval(json).access_token
          End With
        End If
      End If
    End With
  End If
  GetAccessToken = access_token
End Function

Private Function EncodeURL(ByVal str As String) As String
'URLエンコード
  With CreateObject("ScriptControl")
    .Language = "JScript"
    EncodeURL = .CodeObject.encodeURIComponent(str)
  End With
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

上記マクロは承認作業の自動化も行っているため、問題が発生しなければ実行後すぐに指定アドレスにメールが送信されます。

GmailAPI_01_10

ただ、上記マクロはAPIのテスト用に書いただけなので、メールヘッダの設定やエラー処理が十分ではありません。
日本語のメールやファイルを添付してメールを送信する場合には、もう少し処理を付け加える必要があります。

■ 関連Webページ

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

■ あとがき

とりあえず今回のマクロでVBAからGmail APIを呼び出せるのは確認できました。
コードの細かい説明やメールヘッダの処理実装はまた後日にやる、、、かもしれません・・・。

受信メールに対して自動的に返信するOutlookマクロ前のページ

Gmail APIを使ってメール送信するVBAマクロ(2)次のページ

関連記事

  1. アイコン一覧

    Office 2013 アイコン一覧(T)

    ・Office 2013 アイコン一覧 NUM…

  2. Office関連

    VBAでTTSエンジンの各種情報を列挙する

    今回はTTSエンジンの各種情報を列挙するマクロを紹介します。Mic…

  3. Office関連

    UIAutomationClient参照時にDLL読み込みエラーが発生した時の対処法

    マクロでダイアログやボタンの操作を行う時に便利なUI Automati…

  4. Office関連

    「最速攻略 Wordマクロ/VBA徹底入門」レビュー

    いつもお世話になっているExcel MVPの伊藤さんに9月20日発売予…

  5. Office関連

    Excel Services JavaScript APIを試してみました(2)

    前回の記事で、JavaScriptコードを貼り付けてExcelワークブ…

  6. Office関連

    指定したフォルダ内の画像ファイルを一括挿入するPowerPointマクロ

    大量の画像ファイルを1枚/1スライドで挿入する必要があり、…

コメント

    • 枝豆
    • 2015年 2月 22日 6:04am

    自分の予定をGoogleCalendarに送信するために、上記コードを使わせていただき、大変助かっています。
    ところが、昨日(H27.2.21)午後から、「InernetExplorerは動作を停止しました」と表示され、GoogleCalendarに接続できなくなってしまいました。
    エラーは58行目や91行目のところで発生していると思われます。しかし対処方法が全く分かりません。ご教授いただければ幸いです。よろしくお願いいたします。

    • 枝豆
    • 2015年 2月 22日 6:30am

    大変失礼しました。
    先ほど(H27.2.22)実行してみたら問題なく動作しました。原因は不明です。
    状況から考えると、GoogleCalendar側の問題のように思います。
    今後もよろしくお願いいたします。

    • > 枝豆さん

      当ブログの管理人です。
      非常に冗長で微妙なコードですが、ご参考いただけたようで何よりです。
      また、解決できたとのことで、私も安心いたしました。

    • Kevin
    • 2018年 4月 20日 9:41am

    これをありがとうございました。 私はアメリカ人です。 あなたの投稿が見つかるまで、私はこのソリューションをどこからでも見つけることができませんでした。 あなたは命の恩人です。

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

Time limit is exhausted. Please reload CAPTCHA.

※本ページはプロモーションが含まれています。

Translate

最近の記事

アーカイブ

PAGE TOP