Office関連

Outlookを使ってGmail送信を行うVBAマクロ

下記G Suite アップデート ブログにある通り、今年の6月には“安全性の低いアプリ”によるGmailカレンダーといったGoogleのサービスに新規接続ができなくなり、2021年2月には、安全性の低いアプリへの接続はすべて無効になります。

当ブログで以前書いた下記記事、「CDOを使ってGmail送信するVBAマクロ」も使えなくなるわけですね。

今回はCDOの代わりにOutlookを使ってGmail送信を行うVBAマクロをご紹介します。

Option Explicit

Public Sub Sample()
  Dim olApp As Object
  Dim v As Variant
  Const olFormatPlain = 1 'Outlook.OlBodyFormat
  
  'Outlookが起動していないと送信できない場合があるので事前に起動
  On Error Resume Next
  Set olApp = GetObject(, "Outlook.Application")
  If olApp Is Nothing Then
    Shell "OUTLOOK.EXE", vbNormalFocus
    Do
      Set olApp = GetObject(, "Outlook.Application")
      DoEvents
    Loop While olApp Is Nothing
  End If
  On Error GoTo 0
  
  '添付ファイル
  v = Array("C:\temp\job_barista_man.png", _
            "C:\temp\job_barista_woman.png", _
            "C:\temp\job_cafe_tenin_woman.png")
  
  SendGmailUsingOutlook _
    MailApp:=olApp, _
    AccountAddress:="*****@gmail.com", _
    MailTo:="*****@hogehoge.org", _
    MailCc:="", _
    MailBcc:="", _
    MailSubject:="【テストメール】", _
    MailBody:=ChrW(&H4E3A) & ChrW(&H4E86) & ChrW(&H68C0) & ChrW(&H67E5) & ChrW(&H6D4B) & _
              ChrW(&H8BD5) & ChrW(&H73AF) & ChrW(&H5883) & vbNewLine & ChrW(&H8BF7) & ChrW(&H628A) & _
              ChrW(&H6570) & ChrW(&H636E) & ChrW(&H53D1) & ChrW(&H7ED9) & ChrW(&H6211), _
    MailBodyFormat:=olFormatPlain, _
    AttachmentFilePath:=v, _
    FlgSend:=True
End Sub

Private Sub SendGmailUsingOutlook( _
  ByVal MailApp As Object, _
  ByVal AccountAddress As String, _
  ByVal MailTo As String, _
  ByVal MailCc As String, _
  ByVal MailBcc As String, _
  ByVal MailSubject As String, _
  ByVal MailBody As String, _
  Optional ByVal MailBodyFormat As Long = 1, _
  Optional ByVal AttachmentFilePath As Variant = Empty, _
  Optional ByVal FlgSend As Boolean = True)
'Outlookを使ってGmail送信を行うVBAマクロ
'※要Gmailアカウントの追加
'https://support.office.com/ja-jp/article/70191667-9c52-4581-990e-e30318c2c081 参照
  
  Dim accGmail As Object 'Outlook.Account
  Dim i As Long
  Const olMailItem = 0
  
  Set accGmail = MailApp.Session.Accounts.Item(AccountAddress)
  If accGmail Is Nothing Then Exit Sub
  With MailApp.CreateItem(olMailItem)
    .To = MailTo
    If Len(Trim(MailCc)) > 0 Then .CC = MailCc
    If Len(Trim(MailBcc)) > 0 Then .BCC = MailBcc
    .Subject = MailSubject
    .BodyFormat = MailBodyFormat
    If Not IsEmpty(AttachmentFilePath) Then
      For i = LBound(AttachmentFilePath) To UBound(AttachmentFilePath)
        .Attachments.Add AttachmentFilePath(i)
      Next
    End If
    .Body = MailBody
    Set .SendUsingAccount = accGmail
    If FlgSend Then
      .Send
    Else
      .Display
    End If
  End With
End Sub

MailItemオブジェクトを作って送るだけの、何のひねりも無いコードです。

ただ、テスト環境では、添付ファイルを指定した際にOutlookが起動していない状態だと上手く送信できなかったため、事前にOutlookを起動するようにしています。

仕様上、上記コードを実行する前に、OutlookにGmailアカウントを設定しておく必要があります。
設定方法は下記サイトで詳しく説明されているので、こちらをご参照ください。

CDOが使えなくなる以上、Outlookを使うのが簡単だと思うのですが、想像以上に送信に時間が掛かりました。
下記記事のように、直接APIを叩いた方が使い勝手が良いかもしれません。
(VBAで実装するのは面倒ですが・・・)

関連記事

  1. Office関連

    Excel 2016 Previewで追加された新しい関数

    ※ 下記情報はOffice 2016 Preview版を元にしています…

  2. Office アドイン

    [Officeアドイン]Word JavaScript APIの機能紹介

    Office Dev Center - Changelogを見ると分か…

  3. Office関連

    Office 2013関連資料のリンク

    Office 2013関連資料のリンクをメモしておきます。・O…

  4. Office関連

    [リボン・カスタマイズ]カスタムタブを共有する。

    ※ 2015/2/18 コードに一部誤りがあったので修正しました。…

  5. Office関連

    ブラウザで簡単にOfficeドキュメントを確認できる「Office Web ビューアー」

    @seinoro さんのツイート(下記)で知ったサービス「View O…

コメント

  • コメント (0)

  • トラックバックは利用できません。

  1. この記事へのコメントはありません。

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP