ExcelでGmailからメール送信 | VBA プログラミングで社内アプリ開発

以前にExcel VBAでOutlook経由でメール送信を行う方法を教えたけど、今回はOutlookは使用せずに、Gmailアカウントからメール送信をする方法を教えるよ。

(Outlook経由でのメール送信は下記を参照)

[Excel VBA] Outlookを経由してメール送信

ExcelのVBAで実はメール送信も出来ちゃう！今回はOutlookがインストールされていて、それ経由で送信する方法を教えるよ。宛先やCC、件名、本文、添付ファイルの保存先をリストにしておいて、リストの一番上から順々にメール送信し...

Gmailから送信するためにはまずGmailで下記の2つの設定が必要だよ。

IMAPを有効化する

GmailのIMAPサーバーの設定方法

「GmailのIMAPって何だろう？」、「OutlookとGmailを同期させたい」などと思っている方は多いです。IMAPの意味と使い方を理解し、上手に利用できれば、Gmailをさらに有効活用することができます。

安全性の低いアプリの許可を有効にする

安全性の低いアプリと Google アカウント - Google アカウントヘルプ

アカウントを安全に保つため、2022 年 5 月 30 日より、Google は、ユーザー名とパスワードのみで Google アカウントにログインするサードパーティ製のアプリとデバイスについてサポートを終了いたします。重要:この期限は Google Workspace または Google Cloud Identit...

「アプリの許可をオンにする」のリンクは、Gmailにログインした状態で、下記のところをクリックすると、有効・無効の切り替えの場所に行けるよ。

ただ、これをすることでセキュリティのレベルが下がるので、なるべくプライベートのGmailとかは使わないほうがいいかな。

次にエクセルのシートはこんな感じにしてね。セルの位置はプログラム上で固定されているから、間違えないようにご注意を。

次に参照設定。メニューバーのツールから参照設定を開いて、今回は下記のように、「Microsoft CDO for Windows 2000 Library」にチェックをつけてOK。

それではコードです。今回はエクセルVBA関係では知らない人はいないくらい有名な下記のサイトを参考にさせていただきました！（ほぼコピペ？）

Excelでお仕事！(ジャンプ！)


'   CDOでメールを送信する
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
'   [参照設定]
'   ・Microsoft CDO for Windows 2000 Library
'   　(or Microsoft CDO for Exchange 2000 Library)
'*******************************************************************************
Option Explicit

Const GMAIL_PORT_NUMBER As Integer = 465

'*******************************************************************************
' メール送信テストプログラム(添付ファイルあり)
'*******************************************************************************
Sub ClickMailSend()

    Dim MailSmtpServer As String
    Dim MailFrom As String
    Dim MailTo As String
    Dim MailCC As String
    Dim MailBCC As String
    Dim MailSubject As String
    Dim MailBody As String
    Dim MailAddFile(4) As String
    Dim strMSG As String
    Dim CurrentRow As Integer
    Dim MailPassword As String

    ' 送信確認
    If MsgBox("メールを送信します。" & vbCr & _
        "よろしいですか？", vbYesNo) <> vbYes Then Exit Sub
    
    MailSmtpServer = Cells(2, 2).Text   'SMTPサーバー名
    MailFrom = Cells(3, 2).Text         '送信元アドレス
    MailPassword = Cells(4, 2).Text     'パスワード
    '開始行
    CurrentRow = 7
    
    Do
    
        MailTo = Cells(CurrentRow, 1).Text           ' 宛先
        MailCC = Cells(CurrentRow, 2).Text           ' CC
        MailBCC = Cells(CurrentRow, 3).Text          ' BCC
        MailSubject = Cells(CurrentRow, 4).Text      ' 件名
        MailBody = Cells(CurrentRow, 5).Text         ' 本文
        
        
        MailAddFile(0) = Cells(CurrentRow, 6).Text   '添付
        MailAddFile(1) = Cells(CurrentRow, 7).Text
        MailAddFile(2) = Cells(CurrentRow, 8).Text
        MailAddFile(3) = Cells(CurrentRow, 9).Text
        MailAddFile(4) = Cells(CurrentRow, 10).Text
        
        ' メール送信
        strMSG = SendMailByCDO(MailSmtpServer, MailFrom, MailTo, MailCC, MailBCC, _
            MailSubject, MailBody, MailPassword, MailAddFile)
        
        ' 文字コードを任意に指定する場合は以下のようにします。(こちらだとiPhoneで文字化けしないかも)
'        strMSG = SendMailByCDO(MailSmtpServer, MailFrom, MailTo, MailCC, MailBCC, _
'            MailSubject, MailBody, MailPassword, MailAddFile, cdoISO_2022_JP)
            
        CurrentRow = CurrentRow + 1
        
    Loop Until Cells(CurrentRow, 1).Text = ""
    

End Sub

'*******************************************************************************
' メール送信(CDO)
'*******************************************************************************
' [引数]
'  ①MailSmtpServer : SMTPサーバ名(又はIPアドレス)
'  ②MailFrom       : 送信元アドレス
'  ③MailTo         : 宛先アドレス(複数の場合はカンマで区切る)
'  ④MailCc         : CCアドレス(複数の場合はカンマで区切る)
'  ⑤MailBcc        : BCCアドレス(複数の場合はカンマで区切る)
'  ⑥MailSubject    : 件名
'  ⑦MailBody       : 本文(改行はvbCrLf付加)
'  ⑧MailAddFile    : 添付ファイル(複数の場合はカンマで区切るか配列渡し) ※Option
'  ⑨MailCharacter  : 文字コード指定(デフォルトはShift-JIS)              ※Option
' [戻り値]
'  正常時："OK", エラー時："NG"+エラーメッセージ
'*******************************************************************************
Private Function SendMailByCDO(MailSmtpServer As String, _
                               MailFrom As String, _
                               MailTo As String, _
                               MailCC As String, _
                               MailBCC As String, _
                               MailSubject As String, _
                               MailBody As String, _
                               MailPassword As String, _
                               Optional MailAddFile As Variant, _
                               Optional MailCharacter As String)
    Const cnsOK = "OK"
    Const cnsNG = "NG"
    Dim objCDO As New CDO.Message
    Dim vntFILE As Variant
    Dim IX As Long
    Dim strCharacter As String, strBody As String, strChar As String

    On Error GoTo SendMailByCDO_ERR
    SendMailByCDO = cnsNG

    ' 文字コード指定の確認
    If MailCharacter <> "" Then
        ' 指定ありの場合は指定値をセット
        strCharacter = MailCharacter
    Else
        ' 指定なしの場合はShift-JISとする
        strCharacter = cdoShift_JIS
    End If

    ' 本文の改行コードの確認
    ' Lfのみの場合Cr+Lfに変換
    strBody = Replace(MailBody, vbLf, vbCrLf)
    ' 上記で元がCr+Lfの場合Cr+Cr+LfになるのでCr+Lfに戻す
    MailBody = Replace(strBody, vbCr & vbCrLf, vbCrLf)

    With objCDO
        With .Configuration.Fields                          ' 設定項目
            .Item(cdoSendUsingMethod) = cdoSendUsingPort    ' 外部SMTP指定
            .Item(cdoSMTPServer) = MailSmtpServer           ' SMTPサーバ名
            .Item(cdoSMTPServerPort) = GMAIL_PORT_NUMBER    ' ポート№
            .Item(cdoSMTPConnectionTimeout) = 60            ' タイムアウト
            .Item(cdoSMTPAuthenticate) = cdoAnonymous       ' 0
            .Item(cdoLanguageCode) = strCharacter           ' 文字セット指定
            .Item(cdoSMTPUseSSL) = True
            .Item(cdoSMTPAuthenticate) = 1
            .Item(cdoSendUserName) = MailFrom
            .Item(cdoSendPassword) = MailPassword
            .Item(cdoSendUsingMethod) = 2
            .Update                                         ' 設定を更新
        End With
        .MimeFormatted = True
        .Fields.Update
        .From = MailFrom                        ' 送信者
        .To = MailTo                            ' 宛先
        If MailCC <> "" Then .CC = MailCC       ' CC
        If MailBCC <> "" Then .BCC = MailBCC    ' BCC
        .Subject = MailSubject                  ' 件名
        .TextBody = MailBody                    ' 本文
        .TextBodyPart.Charset = strCharacter    ' 文字セット指定(本文)
        ' 添付ファイルの登録(複数対応)
        If ((VarType(MailAddFile) <> vbError) And _
            (VarType(MailAddFile) <> vbBoolean) And _
            (VarType(MailAddFile) <> vbEmpty) And _
            (VarType(MailAddFile) <> vbNull)) Then
            If IsArray(MailAddFile) Then
                For IX = LBound(MailAddFile) To UBound(MailAddFile)
                    If CStr(MailAddFile(IX)) <> "" Then
                        .AddAttachment MailAddFile(IX)
                    End If
                Next IX
            ElseIf MailAddFile <> "" Then
                vntFILE = Split(CStr(MailAddFile), ",")
                For IX = LBound(vntFILE) To UBound(vntFILE)
                    If Trim(vntFILE(IX)) <> "" Then
                        .AddAttachment Trim(vntFILE(IX))
                    End If
                Next IX
            End If
        End If
        .Send                                   ' 送信
    End With
    Set objCDO = Nothing
    SendMailByCDO = cnsOK
    
    MsgBox ("送信完了！")
    Exit Function

'-------------------------------------------------------------------------------
SendMailByCDO_ERR:
    SendMailByCDO = cnsNG & Err.Number & " " & Err.Description
    On Error Resume Next
    Set objCDO = Nothing
    MsgBox ("送信に失敗しました。")

End Function

'-----------------------------<< End of Source >>-------------------------------

少し長いけど、処理内容を確認したい場合はF8キーでステップ実行してみてね。

ソースコードを参考にさせて頂いたサイト主様に感謝です！

もしこのファイル自体が欲しい方は、お問い合わせフォームから連絡してね。

それではまた。