使用VBA一次起草4封单独的电子邮件

Question

我正试图使用下面的代码起草4封相同的电子邮件，发送到我的Rlist中包含的4个不同地址。这在昨天似乎奏效了——它分别起草了这四份文件。然而，今天电子邮件被起草；至"；部分在我的Rlist中混洗并且在最后一个"R"结束；R〃；在列表中，只留下一封电子邮件而不是4封。如果你看到这个问题，请告诉我！

Sub EmailAll()
Dim OApp As Object, OMail As Object, signature As String
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)

Dim Rlist As Range
Set Rlist = Range("P" & Selection.Row & ":S" & Selection.Row)
Dim R As Range

For Each R In Rlist

With OMail
.Display
End With
signature = OMail.HTMLbody
With OMail
.To = R
.cc = Sheets("Emails").Range("g2")
.Subject = ActiveCell & " & " & ActiveCell.Offset(0, 1)
.HTMLbody = "email contents"

End With
Next R

Set OMail = Nothing
Set OApp = Nothing
End Sub

Answer 1

创建电子邮件对象的是此处进行的Outlook.Application.CreateItem成员调用：

Set OMail = OApp.CreateItem(0)

由于只发生过一次调用，因此只创建了一个电子邮件对象，循环的每次迭代都会连续覆盖上一次迭代，直到循环结束，使电子邮件草稿处于上次迭代设置的状态。

正如BigBen正确指出的那样，解决方案是将OApp.CreateItem(0)指令移动到循环体内部，这样每次迭代都会创建一封新的电子邮件。

但真正的问题是，你的方法做的事情太多了。将其拆分为更小、更专业的范围：

Public Sub EmailAll()
On Error GoTo CleanFail
Dim OutlookApp As Object
Set OutlookApp = CreateObject("Outlook.Application")

Dim SourceRow As Long
SourceRow = Selection.Row
Dim EmailSubject As String
'NOTE: Range member calls are implicitly late-bound here
EmailSubject = ActiveCell.Value & " " & ActiveCell.Offset(0, 1).Value 'possible failure and possible unintended read here
Dim Recipients As Variant 'a variant array of cell values
Recipients = ActiveSheet.Range("P" & SourceRow & ":S" & SourceRow).Value
Dim CopyRecipient As String
CopyRecipient = ActiveWorkbook.Worksheets("Emails").Range("G2").Value 'possible failure here
Dim Recipient As Variant 'the value held by a cell
For Each Recipient In Recipients 'iterating values, not cells
If Not IsError(Recipient) Then 'cell value may not be a valid string!
CreateDraftEmail OutlookApp, EmailSubject, Recipient, CopyRecipient
End If
Next
CleanExit:
'Set OutlookApp = Nothing '<~ ONLY do this if NOT doing it causes problems
Exit Sub
CleanFail:
Debug.Print Err.Description
'Stop   '<~ uncomment to always break here for debugging
'Resume '<~ uncomment to debug/jump to the error-causing statement
Resume CleanExit
End Sub

注意几个可能的故障点；处理运行时错误使您有机会正常失败，而不是弹出一些调试器提示。

通过将实际的电子邮件创建转移到自己的过程范围中，职责可以更好地分离，并且您已经获得了一块执行非常特定的事情的代码，并将其转移到以该非常特定的东西命名的过程范围：

Private Sub CreateDraftEmail(ByVal OutlookApp As Object, ByVal EmailSubject As String, ByVal Recipient As String, ByVal CopyRecipient As String)
With OutlookApplication.CreateItem(0)
.Subject = EmailSubject
.To = Recipient
.Cc = CopyRecipient
.HtmlBody = "email contents"
.Display
End With
End Sub

理想情况下，从工作表中收集数据的所有准备工作也将转移到其自己的专用范围中，这样收集的值就可以在使用之前进行验证(并妥善处理任何错误(。

请注意，ActiveCell和Selection意味着宏依赖于用户的选择来完成它的任务-如果数据总是在同一个位置，那么最好从那里提取数据，并处理Worksheet和Range对象，而不是处理当前的Selection(可能是也可能不是Range对象-请注意，这没有经过验证！(。