E-Mail with a for loop-CodePudding

Script i'm using will only send one e-mail, instead of 200 odd e-mails.


    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim LastRow As Integer

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    LastRow = Worksheets("DRIVERS").Cells(Rows.Count, 1).End(xlUp).Row

    On Error GoTo cleanup
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    For r = 2 To LastRow
        With OutMail
            '.To = Worksheets("DRIVERS").Range("G" & r).Value
            If Worksheets("DRIVERS").Range("F" & r).Value = "X" Then
                .To = "[email protected]" ← Changed for obvious reasons <3
            Else
                .To = Worksheets("DRIVERS").Range("AL" & r).Value
            End If
            .Subject = "EDN Roster"
            .HTMLBody = "Dear " & Worksheets("DRIVERS").Range("D" & r).Value & "<br /><br />" & _
                    "Please find your Roster below!<br /><br /><b>This Week:</b><br />" & _
                    "<table border=1><tr><th></th><th>Monday</th><th>Tuesday</th><th>Wednesday</th><th>Thursday</th><th>Friday</th><th>Saturday</th><th>Sunday</th></tr>" & _
                    "<tr><td>Shift</td><td>" & Worksheets("DRIVERS").Range("H" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("I" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("J" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("K" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("L" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("M" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("N" & r).Value & "</td>" & _
                    "<tr><td>Sign On</td><td>" & Worksheets("DRIVERS").Range("W" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("Y" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AA" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AC" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AE" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AG" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AI" & r).Value & "</td>" & _
                    "<tr><td>Sign Off</td><td>" & Worksheets("DRIVERS").Range("X" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("Z" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AB" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AD" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AF" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AH" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AJ" & r).Value & "</td>" & _
                    "</table><br /><br />" & _
                    "<b>Next Week:</b><br />" & _
                    "<table border=1><tr><th></th><th>Monday</th><th>Tuesday</th><th>Wednesday</th><th>Thursday</th><th>Friday</th><th>Saturday</th><th>Sunday</th></tr>" & _
                    "<tr><td>Shift</td><td>" & Worksheets("DRIVERS").Range("O" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("P" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("Q" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("R" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("S" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("T" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("U" & r).Value & "</td>" & _
                    "<tr><td>Sign On</td><td>" & Worksheets("DRIVERS").Range("AN" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AP" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AR" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AT" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AV" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AX" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AZ" & r).Value & "</td>" & _
                    "<tr><td>Sign Off</td><td>" & Worksheets("DRIVERS").Range("AO" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AQ" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AS" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AU" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AW" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("AY" & r).Value & "</td><td>" & Worksheets("DRIVERS").Range("BA" & r).Value & "</td>" & _
                    "</table><br /><br />" & _
                    "This email is an automated notification, which is unable to receive replies."
            .Send  'Display
        End With
    Next
    On Error GoTo 0
    Set OutMail = Nothing

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Message works, and if I use .Display it loops through all the employee's, and changes all the necessary information.

I saw a thread from 2016 that the CreateObject had to be outside the For Loop, and that didn't change it.

CodePudding user response：

For those playing along, the Set OutMail = OutApp.CreateItem(0) had to be set inside the for loop!

CodePudding user response：

I know you've resolved your problem, but I recommend using a separate sub to send the email vs gather the information. I found one online and adapted it to my needs:

Sub SendEmail(Optional ToAddresses As String, Optional CcAddresses As String, _
Optional BccAddresses As String, Optional Subject As String, _
Optional Body As String, Optional AttachFiles As Variant = False, Optional AutoSend As Boolean = False, _
Optional SendFromAddress As String)
'Adapted from https://www.rondebruin.nl/win/s1/outlook/bmail4.htm

    Dim OutApp As Object
    Dim OutMail As Object
    
    'Current application, where applicable;
    On Error GoTo Err
    Set OutApp = GetObject(, "Outlook.Application")
NoErr:
    On Error GoTo 0
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
    
    'Basic Text properties
        .To = ToAddresses
        .CC = CcAddresses
        .Bcc = BccAddresses
        .Subject = Subject
    '---------------------
            
    'Body; HTML or plain text
        If Body Like "*<br>*" Then
            .HtmlBody = Body
        Else
            .Body = Body
        End If
     '---------------------
            
    'Attachments:
        If Not AttachFiles = False Then
            If IsArray(AttachFiles) Then
                For x = LBound(AttachFiles) To UBound(AttachFiles)
                    .Attachments.Add (AttachFiles(x))
                Next
            Else
                .Attachments.Add (AttachFiles)
            End If
        End If
    '---------------------
            
    'Sender Address
        If Len(SendFromAddress) > 0 Then
            For a = 1 To OutApp.Session.Accounts.Count
                If LCase(OutApp.Session.Accounts.Item(a)) Like LCase(SendFromAddress) Then
                    .sendusingaccount = OutApp.Session.Accounts.Item(a)
                    SendFromAddress = ""
                    Exit For
                End If
            Next
            If Len(SendFromAddress) > 0 Then .SentOnBehalfOfName = SendFromAddress
        End If
    '---------------------
            
    'Send or display:
        If AutoSend = True Then
            .Send
        Else
            .Display
        End If
    '---------------------
            
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
Exit Sub
Err:
        If Err.Number = 429 Then
            Set OutApp = CreateObject("Outlook.application")
            GoTo NoErr
        End If
        On Error GoTo 0
        Err.Raise (Err.Number)
End Sub

Then in your case, you other loop just needs to assemble the HTMLBody as a string variable, then

SendEmail ToAddresses:="[email protected]", Subject:="EDN Roster", Body:=strBody, AutoSend:=True

This makes the code easier to read and maintain, and you can re-use the email sub in different macros.