Email individual attachments

[Metin81]

Hi, I am new on the form and not very familiar with Macro's.
I found the following macro on the web.

Sub SendEmailfromOutlook()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Path As String
Path = Application.ActiveWorkbook.Path
Set OutApp = CreateObject("Outlook.Application")

For Each cell In Range("C3:C10")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cell.Value
.Subject = Cells(cell.Row, "D").Value
.Body = "Dear " & Cells(cell.Row, "B").Value & "," _
& vbNewLine & vbNewLine & _
"Please find attached a list of overdue invoices. Thank you!"
.Attachments.Add (Path & "" & Cells(cell.Row, "D").Value)
.Attachments.Add (Path & "" & Cells(cell.Row, "E").Value)
.Attachments.Add (Path & "" & Cells(cell.Row, "F").Value)
'.Send

.Save
End With
Next cell
End Sub

With this macro I want to send overdue invoices to customers, some customers have more then one overdue invoice which I want to attach in the same email. My question is how I can make sure I got no error with this code when a customer has only one invoice, which means cell E and F is blank.
So if client A has 3 overdue invoice the macro workd fine, but if the macro continue to client B which has only one overdue invoice it stop working and it won't work on client C D E ...

Hope it's clear.

 

[igold]

How about this...

Sub SendEmailfromOutlook()


    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim Path As String
    
    Path = Application.ActiveWorkbook.Path
    Set OutApp = CreateObject("Outlook.Application")


    For Each cell In Range("C3:C10")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = cell.Value
            .Subject = Cells(cell.Row, "D").Value
            .Body = "Dear " & Cells(cell.Row, "B").Value & "," _
            & vbNewLine & vbNewLine & _
            "Please find attached a list of overdue invoices. Thank you!"
            .Attachments.Add (Path & "" & Cells(cell.Row, "D").Value)
            If Not Cells(cell.Row, "E").Value = "" Then .Attachments.Add _
            (Path & "" & Cells(cell.Row, "E").Value)
            If Not Cells(cell.Row, "F").Value = "" Then .Attachments.Add _
            (Path & "" & Cells(cell.Row, "F").Value)
'.Send
            .Save
        End With
    Next cell
    
End Sub

 

[Metin81]

Thank you igold, what happens is that the macro runs the code on row 3 and give an error, it won't row 4. Attached a screenshot of my excel sheet, I don't know how to add the spreadsheet itself.

Thanks!!

[TABLE="width: 651"]
<colgroup><col><col><col><col span="2"><col></colgroup><tbody>[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Oustanding balance[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Name Client[/TD]
[TD]Email Client[/TD]
[TD]Attachment name[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]John[/TD]
[TD]John@hotmail.com[/TD]
[TD]Inv 1.pdf[/TD]
[TD]Inv 2.pdf[/TD]
[TD]Inv 3.pdf[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Eva[/TD]
[TD]Eva@hotmail.com[/TD]
[TD]Inv 4.pdf[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Adam[/TD]
[TD]Adam@hotmail.com[/TD]
[TD]Inv 5.pdf[/TD]
[TD]Inv 6.pdf[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[igold]

One thing I noticed is that you are missing a backslash. I did not know if you had it attached in the cell. for example in line 3 the attachment name would be this: \Inv 1.pdf

The better way would be in the code itself like this: I tested this code with your information from post #3 and it works fine for me but breaks at the last line where there is no more data. However the emails were created and saved in my drafts. If you don't have information from C3:C10 the code will break at the first blank line.

Sub SendEmailfromOutlook()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim Path As String
    
    Path = Application.ActiveWorkbook.Path
    Set OutApp = CreateObject("Outlook.Application")


    For Each cell In Range("C3:C10")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = cell.Value
            .Subject = Cells(cell.Row, "D").Value
            .Body = "Dear " & Cells(cell.Row, "B").Value & "," _
            & vbNewLine & vbNewLine & _
            "Please find attached a list of overdue invoices. Thank you!"
            .Attachments.Add (Path & "[COLOR=#ff0000]\[/COLOR]" & Cells(cell.Row, "D").Value)
            If Not Cells(cell.Row, "E").Value = "" Then .Attachments.Add _
            (Path & "[COLOR=#ff0000]\[/COLOR]" & Cells(cell.Row, "E").Value)
            If Not Cells(cell.Row, "F").Value = "" Then .Attachments.Add _
            (Path & "[COLOR=#ff0000]\[/COLOR]" & Cells(cell.Row, "F").Value)
'.Send
            .Save
        End With
    Next cell
    
End Sub

 

[igold]

This would be prevent the breaks caused by the blank rows...

Sub SendEmailfromOutlook()


    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim Path As String
    Dim lRow As Long
    
    lRow = Range("C3").End(xlDown).Row
    Path = Application.ActiveWorkbook.Path
    Set OutApp = CreateObject("Outlook.Application")


    For Each cell In Range("C3:C" & lRow)
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = cell.Value
            .Subject = Cells(cell.Row, "D").Value
            .Body = "Dear " & Cells(cell.Row, "B").Value & "," _
            & vbNewLine & vbNewLine & _
            "Please find attached a list of overdue invoices. Thank you!"
            .Attachments.Add (Path & "\" & Cells(cell.Row, "D").Value)
            If Not Cells(cell.Row, "E").Value = "" Then .Attachments.Add _
            (Path & "\" & Cells(cell.Row, "E").Value)
            If Not Cells(cell.Row, "F").Value = "" Then .Attachments.Add _
            (Path & "\" & Cells(cell.Row, "F").Value)
'.Send
            .Save
        End With
    Next cell
    
End Sub