Excel – VBA loop to send emails with attachments also includes all previous iterations’ attachments

attachmentemailexcelvba

I need to send an email with a range of cells from a workbook in the body of the email, and also a different attachent for each recipient, in Excel 2007.

I am having difficulty with the code below. Everything works as intended except for adding the attachments. When I start the loop to send the emails with their respective attachments, it includes all the previous iterations' attachments. That is to say the emails send like this:

Email 1 – Attachment 1

Email 2 – Attachment 1, Attachment 2

Email 3 – Attachment 1, Attachment 2, Attachment 3; and so on. 

Sub Send_Range()
Dim x As Integer
Dim i As Integer
x = Sheets("MarketMacro").Range("M1").Text 'A count of how many emails to send.
i = 2
  Do
   ' Select the range of cells on the active worksheet.
   Sheets("Summary").Range("A1:M77").Select
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True

   With ActiveSheet.MailEnvelope
      .Introduction = "This is a sample worksheet."
      .Item.To = Sheets("MarketMacro").Range("A" & i).Text
      .Item.Subject = "Test" 'email subject
      .Item.attachments.Add (Sheets("MarketMacro").Range("H" & i).Text) 'add attachment based on path in worksheet cell
      .Item.Send 'sends without displaying the email
   End With
   i = i + 1 
Loop Until i = x + 2
    MsgBox ("The tool sent " & i - 2 & " reports.")
End Sub

Does anyone have a solution to this problem? I have another way to send the emails programmatically with attachments that works perfectly fine, but I am unable to send a range of cells as the body the email.

Best Answer

Try this:

Sub Send_Range()
Dim x As Integer
Dim i As Integer

x = Sheets("MarketMacro").Range("M1").Text 'A count of how many emails to send.
i = 2

Do
   ' Select the range of cells on the active worksheet.
   Sheets("Summary").Range("A1:M77").Select
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True

   With ActiveSheet.MailEnvelope
      'Before we send emails, we will loop through the Attachments collection
      'and delete any that are in there already.
      'There seemed to be an issue with the For...Each construct which
      'would not delete all the attachments.  This is the only way I could
      'do it.
      Do Until .Item.attachments.Count = 0
          .Item.attachments(1).Delete
      Loop

      .Introduction = "This is a sample worksheet."
      .Item.To = Sheets("MarketMacro").Range("A" & i).Text
      .Item.Subject = "Test" 'email subject
      .Item.attachments.Add (Sheets("MarketMacro").Range("H" & i).Text) 'add attachment based on path in worksheet cell
      .Item.Send 'sends without displaying the email
   End With
   i = i + 1 
Loop Until i = x + 2
    MsgBox ("The tool sent " & i - 2 & " reports.")
End Sub

I believe the code is just reusing the same MailEnvelope object, overwriting each property each time you enter your Do...Until loop. But since Attachments is a collection and not a scalar, you are appending one additional item every time you go through the loop. I've added a small loop within that outer loop that will search through .Item.Attachments and delete each attachment while .Attachments.Count is greater than 0. That way, it should always be a blank slate when it comes time to send the mail.

EDIT: My MailEnvelope object would always throw an exception after the first mail I sent and (-2147467259: Automation error. Unspecified error ). Not sure if you are seeing this (seems not). I have not played with this object before and don't know how it's automating Outlook, so I can't really help. Hopefully you just won't see it.

Related Topic