草稿4同时使用VBA的单独电子邮件

Question

我试图使用下面的代码来起草4封相同的电子邮件到我的Rlist中包含的4个不同的地址。这似乎在昨天起作用了--它分别起草了四份文件。然而，今天的电子邮件被起草，"to“部分在我的Rlist中移动，并在列表中的最后一个"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)

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

As BigBen correctly pointed out，解决方案是在循环体内移动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对象)--注意，这没有被验证！)