一斉メール送信(Excel&VBA&Outlook)

説明動画

スキルがある方は下記のコードを自力で組み合わせして、作ることも可能です。

ソースコード

'======================================================================
'Project Name    : <Small Business Services>
'File Name       : <一斉メール送信.xlsb>
'Encoding        : <VBA>
'Creation Date   : <2021/08/12 16:09>
'
'Copyright c <2021> www.zhuzhuming.com. All rights reserved.
'
'This source code or any portion thereof must not be
'reproduced or used in any manner whatsoever.
'======================================================================

Sub Auto_Send_Mail()
       
    'マクロ負荷計測
    Dim TIMEIN As Single
    Dim TIMEOUT As Single
    Dim TIMEDIFF As Single
    TIMEIN = Timer
    
    Dim inputPara(5) As String
    Dim mailBodyHeader As String
    Dim mailBodyFix As String
    
    Dim mailSendTo As String, mailSendCC As String, mailSubject As String, mailBody As String
    
    '画面描画の停止
    Call ScreenDrawStop(True)
    
    mailSubject = Sheets("メール内容").Range("C44").Value
    mailBodyFix = Sheets("メール内容").Range("C46").Value
    
    Dim Row As Integer
    Row = 4
    
    Do While Range("C" & Row).Value <> ""

        '会社名
        inputPara(0) = Range("C" & Row).Value
        
        '部署名
        inputPara(1) = Range("G" & Row).Value
        
        '担当者名
        inputPara(2) = Range("H" & Row).Value
        
        '宛先 Ｅ－ｍａｉｌアドレス
        inputPara(3) = Range("I" & Row).Value
        
        'CC Ｅ－ｍａｉｌアドレス
        inputPara(4) = Range("J" & Row).Value
        
        '今回送信要否フラグ
        inputPara(5) = Range("N" & Row).Value
        
        If inputPara(5) = "○" Then
        
            mailBodyHeader = inputPara(0) & " " & inputPara(1) & " " & inputPara(2) & "様"
            mailBody = mailBodyHeader & vbCrLf & mailBodyFix
            
            mailSendTo = inputPara(3)
            mailSendCC = inputPara(4)
            Call mail_send(mailSendTo, mailSendCC, mailSubject, mailBody)
            
            Range("L" & Row).Value = Range("L" & Row).Value + 1
            Range("M" & Row).Value = Date + Time
            
        End If
        
        Debug.Print ("Row=" & Row)
        Row = Row + 1
    Loop
    
    '画面描画の再開
    Call ScreenDrawStop(False)
    
    TIMEOUT = Timer
    TIMEDIFF = TIMEOUT - TIMEIN
    
    MsgBox "お疲れ様でした!" & vbCrLf & "処理にかかった時間は" & Round(TIMEDIFF, 1) & "秒です。"
    
End Sub

Sub ScreenDrawStop(ByVal Flag As Boolean)

    With Application
        .EnableEvents = Not Flag
        .ScreenUpdating = Not Flag
        .DisplayAlerts = Not Flag
        .Calculation = IIf(Flag, xlCalculationManual, xlCalculationAutomatic)
    End With
    
End Sub

Function mail_send(mailSendTo As String, mailSendCC As String, mailSubject As String, mailBody As String)

        Dim objOutlook As Outlook.Application
        Set objOutlook = New Outlook.Application
        
        Dim objMailItem As Outlook.MailItem
        Set objMailItem = objOutlook.CreateItem(olMailItem)
        
        With objMailItem
            .To = mailSendTo                         'メール宛先
            .cc = mailSendCC                         'メールCC
            .subject = mailSubject                   'メール件名
            .body = mailBody                         'メール本文
            .BodyFormat = olFormatPlain              'メールの形式
            '.Display
            .Send
        End With

End Function

前提条件

• Outlookで送信メール設定が済んでいること
• Excelソフトがインストールされてある
• VBAが使えるExcelソフトとなっていること