「「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を取得します。

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

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

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







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





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



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



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

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

■ 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

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

ただ、上記マクロは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を呼び出せるのは確認できました。
コードの細かい説明やメールヘッダの処理実装はまた後日にやる、、、かもしれません・・・。