Looping Email- Multiple Attachments but I Only Want Selected Attachment

Hello cschoyer,

The Attachments is a Collection object which is part of the Message object. I have added the line to clear all the attachments after the email is sent. The added line is in bold.

                With iMsg
                Set .Configuration = iConf
                    .To = Worksheets("INVOICES").Cells(i, 13).Text + "@xyz.com"
                    .CC = ""
                    .BCC = ""
                    .From = """cschoyer"" <[email protected]>"
                    .Subject = "Pending Approval " & Worksheets("INVOICES").Cells(i, 6).Text & " Inv " & _
                             Worksheets("INVOICES").Cells(i, 5).Text & " JSID " & _
                             Worksheets("INVOICES").Cells(i, 3).Text
                    .TextBody = TextBody
                    .AddAttachment invoice_file_name
                    .Send
                    .Attchments.DeleteAll
                End With

Hello cschoyer ,

I am not sure why you are getting that message. The code line added is part of the standard Windows CDO library of functions and should not cause Excel to crash. Perhaps it has to do with the timing of sending the attachment before it is deleted. Let's move the the delete statement to the beginning and see it that works.

                With iMsg
                .Attchments.DeleteAll
                Set .Configuration = iConf
                    .To = Worksheets("INVOICES").Cells(i, 13).Text + "@xyz.com"
                    .CC = ""
                    .BCC = ""
                    .From = """cschoyer"" <[email protected]>"
                    .Subject = "Pending Approval " & Worksheets("INVOICES").Cells(i, 6).Text & " Inv " & _
                             Worksheets("INVOICES").Cells(i, 5).Text & " JSID " & _
                             Worksheets("INVOICES").Cells(i, 3).Text
                    .TextBody = TextBody
                    .AddAttachment invoice_file_name
                    .Send
                End With

Hello cschoyer,

Are any of the emails being sent or does it crash on the first email?

Hello cschoyer ,

After looking over your macro, I found a few problems. Since this obviously only part of the code, these may not be problems but simply variables that set elsewhere.

1. Mail_Server this not set anywhere in the macro. It should be set to name of the mail server you are using, like "www.google.com".
2. Your port is set to 25 which is fine if the server does not require you to log in.
3. iConf was incorrectly assigned as CDO.Configuration when it should have been CDO.Message.Configuration.

Make the needed corrections to 1 and 2 in the code below. Once you have, try running it again.

Sub Reminder()
    
    Dim i As Integer
    Dim Sendmsg
    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant
    Dim TextBody As String
    Dim ApprovedTextBody As String
    Dim Finfo As String
    Dim FilterIndex As Integer
    Dim FileName As Variant
    Dim Title As String
           
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
    
        Finfo = "All Files (*.*),*.*"

        Set iMsg = CreateObject("CDO.Message")
        Set iConf = iMsg.Configuration

        iConf.Load -1    ' CDO Source Defaults

      ' mail server details
        With iConf.Fields
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = mail_server
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With

        i = 1
        Do While Worksheets("INVOICES").Cells(i, 3) <> ""
    
            If Worksheets("INVOICES").Cells(i, 12).Value <= Date + 7 And Worksheets("INVOICES").Cells(i, 18) = "" Then
        
                Sendmsg = MsgBox(Prompt:="Are you sure you're ready to send?", _
                        Buttons:=vbYesNo, Title:=Worksheets("INVOICES").Cells(i, 6).Text & " Inv " & _
                        Worksheets("INVOICES").Cells(i, 5).Text & " " & Worksheets("INVOICES").Cells(i, 11).Text)

                If Sendmsg = vbNo Then
                    Exit Sub
                Else
                    FileName = Application.GetOpenFilename(Finfo, FilterIndex, Title)
                    invoice_file_name = FileName
            
                    TextBody = "Hello," & vbNewLine & vbNewLine & _
                            "The attached invoice is still awaiting approval. Kindly advise if this invoice is " & _
                            "approved for payment as soon as you get a chance. " & vbNewLine & vbNewLine & _
                            Worksheets("INVOICES").Cells(i, 6).Text & " Inv " & _
                            Worksheets("INVOICES").Cells(i, 5).Text & vbNewLine & "JSID " & _
                            Worksheets("INVOICES").Cells(i, 3).Text & vbNewLine & _
                            Worksheets("INVOICES").Cells(i, 11).Text & vbNewLine & _
                            Worksheets("INVOICES").Cells(i, 7).Text & " " & Worksheets("INVOICES").Cells(i, 8).Text & _
                            vbNewLine & vbNewLine & "Thank you," & vbNewLine & "cschoyer"
    
                    With iMsg
                        Set .Configuration = iConf
                        .To = Worksheets("INVOICES").Cells(i, 13).Text + "@xyz.com"
                        .CC = ""
                        .BCC = ""
                        .From = """cschoyer"" <[email protected]>"
                        .Subject = "Pending Approval " & Worksheets("INVOICES").Cells(i, 6).Text & " Inv " & _
                                Worksheets("INVOICES").Cells(i, 5).Text & " JSID " & _
                                Worksheets("INVOICES").Cells(i, 3).Text
                        .TextBody = TextBody
                        .AddAttachment invoice_file_name
                        .Send
                    End With
                End If
                
                iMsg.Attachments.DeletAll
                invoice_file_name = ""
            End If

            i = i + 1
        Loop
    
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With

End Sub