Excel Macro to Send Multiple Emails w/ Attachments using Microsoft Outlook 2007

**arnel_101** · 03-17-2017, 08:26 AM

Hi ExcelFox,

I am trying to create an excel macro that will automatically send multiple emails with corresponding attachments to multiple recipients but my knowledge is not enough to run the codes. I decided to post it here because I believe somebody can help me or at least give me an idea on how to properly set the codes.

In this regard, I am wondering if there could be someone that can help me with this. I have attached the excel macro sample template that will give you enough data to come up with the output I needed. (Please, column A to G of 'Sheet1' will be the fields to be filled in with the NEW data).

Please let me know should you need any additional details. Any inputs and ideas from your end will be highly appreciated. Thanks!

Warmest regards,
Arnel

**Admin** · 03-21-2017, 05:09 PM

Hi Arnel,

Welcome to ExcelFox!!!

try this. Untested.

Code:

Option Explicit

Sub SendMassEmail()
    
    Dim i               As Long
    Dim j               As Long
    Dim InvNum          As String
    Dim Amount          As String
    Dim Accnt           As String
    Dim Attach(1 To 3)  As Variant
    Dim FilePath        As String
    Dim EBodyO          As String
    Dim EBodyN          As String
    Dim Location        As String
    Dim Subject         As String
    Dim SendTo          As String
    Dim SendCc          As String
    Dim Data
    
    Data = Sheet1.Range("a2").CurrentRegion.Value2
    
    Const Col_InvNum    As Long = 2
    Const Col_Amount    As Long = 3
    Const Col_FPath     As Long = 4
    Const Col_Accont    As Long = 8
    Const Col_SendTo    As Long = 9
    Const Col_SendCc    As Long = 10
    Const Col_Location  As Long = 11
    
    Const Txt_Invoice       As String = "replace_invoice_here"
    Const Txt_Amount        As String = "replace_amount_here"
    Const Txt_Accountant    As String = "Carmen Moran"
    
    EBodyO = Sheet6.Range("a1").Value
    
    For i = 2 To UBound(Data, 1)
        InvNum = Data(i, Col_InvNum)
        Amount = Format(Data(i, Col_Amount), "$ #,##.00")
        FilePath = Data(i, Col_FPath)
        If Not Right(FilePath, 1) = Application.PathSeparator Then FilePath = FilePath & Application.PathSeparator
        For j = 1 To 3
            Attach(j) = FilePath & Data(i, Col_FPath + j)
        Next
        Location = Data(i, Col_Location)
        Accnt = Data(i, Col_Accont)
        EBodyN = Replace(EBodyO, Txt_Invoice, InvNum, , , 1)
        EBodyN = Replace(EBodyN, Txt_Amount, Amount, , , 1)
        EBodyN = Replace(EBodyN, Txt_Accountant, Accnt, , , 1)
        Subject = InvNum & " from " & Location
        SendTo = Data(i, Col_SendTo)
        SendCc = Data(i, Col_SendCc)
        
        SendEmail Subject, EBodyN, SendTo, SendCc, Attach
        
    Next

    MsgBox "Complete"

End Sub

Sub SendEmail(Subject_Line As String, MailBody As String, SendTo As String, SendCc As String, ParamArray Attachs() As Variant)
    
    Dim olApp   As Outlook.Application
    Dim i       As Long
    
    Set olApp = CreateObject("Outlook.Application")

    Dim olMail As Outlook.MailItem
    Set olMail = olApp.CreateItem(olMailItem)
    
    olMail.To = SendTo
    olMail.CC = SendCc
    olMail.Subject = Subject_Line
    olMail.BodyFormat = olFormatHTML
    olMail.HTMLBody = MailBody
    For i = LBound(Attachs) To UBound(Attachs)
        olMail.Attachments.Add Attachs(i)
    Next
    olMail.Send
    
End Sub