VBA to send emails with attachments to recipients on excel sheet

[ABURN]

Hi there

I've managed to get the below VBA working from a very old (2010) thread. It creates emails to recipients for each row in a spreadsheet, customises the email content (with the recipients name) and also attaches a file based on a file path in column E of the sheet.

I've tweaked it slightly, and all is working perfectly, except it attaches the attachments multiple times to each email (i.e. if I have 10 rows of recipients on the spreadsheet it attaches the attachment in column E and the .htm file x10 times in each email it generates, rather than just once based on that particular row in the sheet. Any ideas on what I need to change in the code to overcome this please?

Sub Email_Docs()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range, FileCell As Range, rng As Range
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set sh = Sheets("Sheet1")
    Set OutApp = CreateObject("Outlook.Application")
    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        'Enter the file names in the E column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("E1:E1")
        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
 
            'Need to include Your_Name_Here in the body of the text to personalize
 
            strbody = GetBoiler(cell.Offset(0, 2))
            strbody = Replace(strbody, "Your_Name_Here", cell.Offset(0, -1).Value, Compare:=vbTextCompare)
 
 
            With OutMail
                .To = cell.Value
                .Subject = cell.Offset(0, 1)
                .HTMLBody = strbody
 
                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell
 
                .Display
            End With
            Set OutMail = Nothing
        End If
    Next cell
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Any help would be very much appreciated! TIA

 

[ranman256]

NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE; alt-F11, menu,tools, references: Microsoft Outlook X.X object library
have a macro run when the status box changes, then check to send email

'put this code in a button click

sub SendEmails2List()

range("A2").select     'start here
while activecell.value <> ""
   sTo = activecell.value
   sSubj = "order " & range("A123").value & " is ready to process
   sBody = "Dear client,....."
   sFile = range("A32").value

   call Email1(sTo, sSubj, sBody, sFile)

    activecell.offset(1,0).select  'next row

endif
end sub

'put this code in a module

Public Function Email1(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem

On Error GoTo ErrMail

'NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE; ctl-G, menu,tools, references, Microsoft Outlook XX Object library
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.createitem(olMailItem)

With oMail
    .To = pvTo
    .Subject = pvSubj
    If Not IsNull(pvBody) Then .Body = pvBody
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
  
    .Display True
  
    '.Save    'draft, we are NOT sending...we save as draft
    .Send   
  
End With

Email1 = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function

ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
End Function

 

[ABURN]

NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE; alt-F11, menu,tools, references: Microsoft Outlook X.X object library
have a macro run when the status box changes, then check to send email

'put this code in a button click

sub SendEmails2List()

range("A2").select     'start here
while activecell.value <> ""
   sTo = activecell.value
   sSubj = "order " & range("A123").value & " is ready to process
   sBody = "Dear client,....."
   sFile = range("A32").value

   call Email1(sTo, sSubj, sBody, sFile)

    activecell.offset(1,0).select  'next row

endif
end sub

'put this code in a module

Public Function Email1(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem

On Error GoTo ErrMail

'NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE; ctl-G, menu,tools, references, Microsoft Outlook XX Object library
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.createitem(olMailItem)

With oMail
    .To = pvTo
    .Subject = pvSubj
    If Not IsNull(pvBody) Then .Body = pvBody
    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
 
    .Display True
 
    '.Save    'draft, we are NOT sending...we save as draft
    .Send  
 
End With

Email1 = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function

ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
End Function

Thanks for coming back ranman256! Do you know if there is a small tweak I can make to the code I already have to stop it from attaching all attachments to each email? It's all working perfectly apart from that and I'm sure the code change will be quite simple, I'm just not exactly sure which bit to change.

 

[vw412]

ABURN, have you gotten this problem resolved? If not, based on what I see in your code, I think the second For/Next loop should not be there. If you only trying to attach 1 file to the email then you should not have to loop over any range. I may be wrong since I don't know what your worksheet looks like, but that would be my suggestion at this time. I could help more with a sample worksheet to look at.