excel - 发送带附件的电子邮件的 VBA 循环还包括所有以前迭代的附件

Question

我需要在 Excel 2007 中发送一封电子邮件，邮件正文中包含工作簿中的一系列单元格，并且每个收件人都有不同的附件。

我在使用下面的代码时遇到困难。除了添加附件外，一切都按预期工作。当我开始循环发送带有各自附件的电子邮件时，它包括所有先前迭代的附件。也就是说邮件是这样发送的:

电子邮件 1 - 附件 1

电子邮件 2 - 附件 1、附件 2

电子邮件 3 - 附件 1、附件 2、附件 3；等等。

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

有没有人能解决这个问题？我有另一种方法以编程方式发送带有附件的电子邮件，效果非常好，但我无法发送一系列单元格作为电子邮件的正文。

Answer 1

试试这个:

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

我相信代码只是重复使用相同的 MailEnvelope 对象，每次进入 Do...Until 循环时都会覆盖每个属性。但是由于 Attachments 是一个集合而不是一个标量，所以您每次执行循环时都会附加一个额外的项目。我在那个外循环中添加了一个小循环，它将搜索 .Item.Attachments 并在 .Attachments.Count 大于 0 时删除每个附件。这样，在发送邮件。

编辑: 我的 MailEnvelope 对象总是会在我发送第一封邮件后抛出异常(-2147467259:自动化错误。未指定的错误)。不确定您是否看到了这个(似乎没有)。我以前没有玩过这个对象，也不知道它是如何自动化 Outlook 的，所以我真的帮不上忙。希望你不会看到它。