【コピペでOK】Outlook差出人をセルで変更｜Excel VBAで送信元切替＆自動送信

メール自動vbaを作ってみたけど、差出人の変え方がわからない…
送信元を変更できるVBAを作りたい！

ひとつのOutlookで複数のアカウントを管理するとき、差出人の選択は意外と面倒な作業です。そこで本記事では、差出人アドレスを変更できるメール自動送信VBAを紹介します。

またこれまで紹介したVBAを改良し、「表示／送信」のフラグをセルに書くだけで、下書き表示・即送信を判別してくれる機能も追加しています。コードはコピペするだけで動作し、初心者でも実務にそのまま使用できます。

ぜひこの記事を参考にして、メール業務の効率化をしてみてください！また、単純な自動化であれば下記リンクのメール自動化VBAがおすすめです。ぜひこちらも参考にしてみてください。

【結論】コピペで使えるメール作成 VBA
メール自動作成 VBA の動作
メール自動送信 VBA の使い方
さいごに

【結論】コピペで使えるメール作成 VBA

以下のコードをコピペするだけで、Outlookの添付付きメールを自動作成できます。

実行の際、あらかじめ宛先／CCなどの項目の作成が必要です。詳しくはこの後紹介します。

Sub SendEmail_Attachment()
    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim ws As Worksheet
    Dim lRow As Long, i As Long, j As Long
    Dim strTo As String, strCC As String, strSub As String, strBody As String, strFrom As String
    Dim strAttachment As String

    ' Outlookのインスタンス取得（すでに起動していればそれを使う）
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = New Outlook.Application
    End If
    On Error GoTo 0

    ' メール送信リストが記載されたシートを設定
    Set ws = ThisWorkbook.Sheets("Sheet1")

    ' 最終行を取得
    lRow = ws.Cells(Rows.Count, 2).End(xlUp).Row

    ' 1行ずつデータを取得し、メールを送信
    For i = 2 To lRow
        ' 宛先・CC・件名・本文を取得
        strFrom = ws.Cells(i, 1).Value
        strTo = ws.Cells(i, 2).Value
        strCC = ws.Cells(i, 3).Value
        strSub = ws.Cells(i, 4).Value
        strBody = ws.Cells(i, 5).Value & vbCrLf _
                  & ws.Cells(i, 6).Value & vbCrLf _
                  & ws.Cells(i, 7).Value & vbCrLf _
                  & ws.Cells(i, 8).Value

        ' メール作成
        Set olMail = olApp.CreateItem(olMailItem)
        With olMail
            .SendUsingAccount = Session.Accounts(strFrom)
            .To = strTo
            .CC = strCC
            .Subject = strSub
            .Body = strBody

            ' 添付ファイル（9列目以降）
            For j = 9 To 13
                strAttachment = ws.Cells(i, j).Value
                If strAttachment <> "" And Dir(strAttachment) <> "" Then
                    .Attachments.Add strAttachment
                End If
            Next j

            Select Case ws.Cells(i, 14).Value
                Case "送信"
                    .Send
                Case Else
                    .Display
            End Select
        
        End With

        ' メモリ解放
        Set olMail = Nothing
    Next i

Cleanup:
    Set olApp = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description, vbExclamation
    Resume Cleanup
End Sub

※当サイトで紹介している他のコピペコードは、コチラにまとめています！