2020/06/10 (更新日: 2023/11/27)

【最新】ExcelマクロでOutlookのメールを送信者（差出人）指定して送る方法｜VBAコード掲載

こんにちは、副業エンジニアのてつをです。今回は、ExcelマクロでOutlookのメールを送信者指定して送信する方法をご紹介いたします。この記事を書こうと思った経緯としては、私も送信者指定してメールを送りたいなと思いいろいろと調べていた時、いろいろな記事はあったものの、コードをコピーしてそのまま利用できるものが一つもなく、結局かなり苦労した思い出があるからです。

なのでここでは、コードをコピーしたらそのまま利用できるような形でご紹介させていただきます。

では早速、本題に入っていきましょう。

今回は、会社で自分のメールアドレスではなくメーリスから顧客リストへメールを一斉送信する場面を想定したいと思います。

コードを記述する前の準備
メール送信コードをコピーして貼り付け
Excelマクロの実行（送信者が変わっていることを確認）

1．コードを記述する前の準備

メールアカウントの確認

Outlookのメールアカウントを確認します。Outlookを開いてメールの新規作成をしてください。

するとこのような画面が開けるかと思います。

ここで、差出人をクリックするとメールアカウントを複数持っている方は差出人を変更することができるかと思います。

この差出人を、Excelマクロで指定してメールを送信するのが今回の課題です。

もし、メールアカウントを複数お持ちでない方はアカウントの追加をお願いいたします。

Excelに送信先のリストとメール本文を準備

次に、マクロを書く前に必要な情報をExcelに書いていきます。今回は、自分ではなく会社のメーリングリストから大勢のお客さんに対してメールを送ることを想定しているので、Excelには2つのシートを作成していただきます。

リスト：送信先の一覧
メール：メールの本文や差出人など

まず、シートを2つ準備します。1つ目は送信先の一覧シートです。シートの名前を”リスト”としてください。

中身はこんな感じです。

書く項目としては、A列に送信状況、C列に氏名、D列に会社名、E列にメールアドレスが最低限あれば問題ないでしょう。
この配置は全く同じようにしていただく必要があります。後程、コードをまるまるコピーして利用できるようにするためです。
残りは記録したい内容を追加していただければと思います。

続いて、メールシートを作成します、

中身はこんな感じです。

内容は、B1セルに送信者、B2セルに件名、B3セルに本文が最低限あれば大丈夫でしょう。
B1セルは、プルダウンから複数のメールアドレスの中から1つを選択できるように入力制限を与えてあげてください。
B3セルの本文は、上の図と同じように、1行目に■■（マクロでこの■■が会社名に入れ替わるようになる）と2行目に○○（マクロでこの○○がお客さんの氏名に入れ替わる）と3行目以降に本文を書いてみてください。

これでシートの準備は完了です。

VBAの設定を変更してOutlookをマクロで操作可能に

マクロの記述の前に、マクロでOutlookを操作できるよう設定を変更します。

まず開発タブからVisual Basicを選択してください。

（開発タブがない方はファイル＞オプション＞リボンのユーザー設定より開発にチェックを入れてください。）

次に、VBAのツールから参照設定を選択してください。

すると以下のような画面が表示されます。

ここでMicrosoft Outlook 16.0 Object Libraryにチェックを入れてOKをクリック。

これで準備が完了です。

2．メール送信コードをコピーして貼り付け

コードを指定の位置に貼り付ける

コードを貼り付けるところは、ThisWorkbookになります。

それでは、以下のコードを貼り付けてください。

Sub Savebatchmail()

'---コード1｜定義
    Dim toaddress, ccaddress, bccaddress As String  '変数設定：To宛先、cc宛先、bcc宛先
    Dim subject, mailBody, credit As String '変数設定：件名、メール本文、クレジット、添付
    Dim outlookObj As Object   'Outlookで使用するオブジェクト生成
    Dim mailItemObj As Object      'Outlookで使用するオブジェクト生成
    Dim olkApp
    Dim acctToSend
    SEND_ACCOUNT = Worksheets("メール").Range("B1")
    Dim MaxRow: MaxRow = Worksheets("リスト").Range("E2").End(xlDown).Row
    Dim wsMail As Worksheet
    Set wsMail = ThisWorkbook.Sheets("メール")
    Dim wsList As Worksheet
    Set wsList = ThisWorkbook.Sheets("リスト")
    
'---コード2｜差出人、本文、署名を取得---
    Dim I As Integer
    Dim j As Integer
    'Dim title As Range
    Dim step1 As String
    For I = 2 To MaxRow
        If wsList.Cells(I, 1) &lt;&gt; "NG" And wsList.Cells(I, 1) &lt;&gt; "済" Then
                    toaddress = wsList.Cells(I, 5).Value   'To宛先
                    'ccaddress = Range("B3").Value   'cc宛先
                    'bccaddress = Range("B4").Value  'bcc宛先
                    subject = wsMail.Range("B2").Value     '件名
                    mailBody = wsMail.Range("B3").Value    'メール本文
                    mailBody = Replace(mailBody, "■■", wsList.Cells(I, 4).Value) '会社名
                    mailBody = Replace(mailBody, "○○", wsList.Cells(I, 3).Value) '氏名
                    credit = wsMail.Range("B4").Value      '著名
            
'---コード3｜メールを作成し、差出人、本文、署名を入れ込む---
                    Set outlookObj = CreateObject("Outlook.Application")
                    Set mailItemObj = outlookObj.CreateItem(olMailItem)
                        ' Outlook のオブジェクトを取得
                    Set olkApp = CreateObject("Outlook.Application")
                    Set acctToSend = olkApp.Session.Accounts.Item(SEND_ACCOUNT)
                    Set mailItemObj.SendUsingAccount = acctToSend '差出人をセット
                    
                            mailItemObj.BodyFormat = 3      'リッチテキストに変更
                            mailItemObj.To = toaddress      'to宛先をセット
                            'mailItemObj.CC = ccaddress      'cc宛先をセット
                            'mailItemObj.BCC = bccaddress    'bcc宛先をセット
                            mailItemObj.subject = subject   '件名をセット
                    
'---コード4｜メール本文を改行する
                            mailItemObj.Body = mailBody '&amp; vbCrLf &amp; vbCrLf &amp; credit   'メール本文 改行 改行 クレジット
                    
                
'---コード5｜自動で添付ファイルを付ける---
                    'Dim attached As String
                    'Dim myattachments As Outlook.Attachments 'Outlookで使用するオブジェクト生成
                    'Set myattachments = mailItemObj.Attachments
                    'attached = Range("B6").Value     '添付ファイル
                    'myattachments.Add attached
            
'---コード6｜メールを送信する---
                    mailItemObj.Save   '下書き保存（誤送信防止のため、即時送信にはしない）
                    wsList.Cells(I, 1) = "済"  'メールを作成したら、1行目に済を入れる
        End If
    Next I
'---コード7｜outlookを閉じる(オブジェクトの解放)---
    Set outlookObj = Nothing
    Set mailItemObj = Nothing
    Set olkApp = Nothing
    Set acctToSend = Nothing

End Sub


Sub Which_Account_Number()
'Don't forget to set a reference to Outlook in the VBA editor
    Dim OutApp As Outlook.Application
    Dim I As Long

    Set OutApp = CreateObject("Outlook.Application")

    For I = 1 To OutApp.Session.Accounts.Count
        MsgBox OutApp.Session.Accounts.Item(I) &amp; " : This is account number " &amp; I
    Next I
End Sub



Public Sub SendUsingAccountFromExcel()
    Dim olkApp
    Dim objItem
    Dim acctToSend
    ' Outlook のオブジェクトを取得
    Set olkApp = CreateObject("Outlook.Application")
    ' メールアイテムを作成
    Set objItem = olkApp.CreateItem(0)
    ' 宛先、件名、本文を指定
    objItem.To = SEND_TO_ADDRESS
    objItem.subject = MAIL_SUBJECT
    objItem.Body = MAIL_BODY
    ' 送信アカウントを取得
    Set acctToSend = olkApp.Session.Accounts.Item(SEND_ACCOUNT)
    ' 送信アカウントを指定
    Set objItem.SendUsingAccount = acctToSend
    ' メールを送信
    objItem.Send
End Sub

貼り付けた結果、以下のようになればOKです。