VBA to send emails with attachments to recipients on excel sheet

ABURN

New Member
Joined
Mar 16, 2021
Messages
3
Office Version
  1. 365
Platform
  1. Windows
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?

VBA Code:
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 :)
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

ranman256

Well-known Member
Joined
Jun 17, 2014
Messages
1,980
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
Code:
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

Code:
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

New Member
Joined
Mar 16, 2021
Messages
3
Office Version
  1. 365
Platform
  1. Windows
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
Code:
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

Code:
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

Active Member
Joined
Dec 16, 2011
Messages
323
Office Version
  1. 2019
  2. 2016
  3. 2010
  4. 2007
Platform
  1. Windows
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,119
Messages
5,640,218
Members
417,131
Latest member
Seanr19871

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top