从 Excel 设置大量分发电子邮件列表答案

【问题标题】：Setting up a mass distribution email list from Excel从 Excel 设置大量分发电子邮件列表
【发布时间】：2019-05-07 15:26:29
【问题描述】：

这应该是直截了当的，但我不知何故无法正确。我正在尝试从 Excel 设置自动电子邮件爆炸。我已逐步按照此处其他帖子的说明进行操作，但没有成功。为了简单起见，这是我创建的一个虚拟示例。

我想：

向列表中的每个人发送电子邮件
有条件地替换正文中的某些关键字
用每封电子邮件的递送状态（已发送/失败）填充一列

我当前的代码仅将电子邮件发送给列表中的第一个人。我已将我的个人电子邮件地址用于测试目的。我想知道将电子邮件发送到同一地址是否可能是问题所在。如果有人可以提供一些指导，将不胜感激！

Sub SendMail()

Dim EmailSent, EmailFailed, i As Integer
Dim StatusSent, StatusFailed As String

Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")

Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)


EmailSent = 0
EmailFailed = 0
StatusFailed = "failed"
StatusSent = "sent"
i = 1

Do
DoEvents

    With olMail
        .To = Cells(i, 1).Value
        .Subject = "test"
        .CC = ""
        .BCC = ""
        .Importance = olImportanceHigh
        .BodyFormat = olFormatHTML

        .HTMLBody = Cells(i, 2).Value

        If Cells(i, 3) = 1 Then
            .HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 4))
        Else
            .HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 5))
        End If

       .send

    End With

    On Error Resume Next
    olMail.send

    If Err Then
        EmailFailed = EmailFailed + 1
        ActiveSheet.Cells(i, 6).Value = StatusFailed    'change status from pending to failed
    Else
        EmailSent = EmailSent + 1
        ActiveSheet.Cells(i, 6).Value = StatusSent  'change status from pending to sent
    End If

    i = i + 1
Loop Until i = Range(Range("A1"), Range("A1").End(xlDown)).Count

If EmailSent = 0 Then
    MsgBox Prompt:="Emails could not be sent"
Else
    MsgBox Prompt:="Sent emails: " & EmailSent & vbNewLine _
    & "Failed emails: " & EmailFailed
End If

On Error GoTo 0
Set olApp = Nothing
Set olMail = Nothing

End Sub

【问题讨论】：

为什么要重新发明轮子？将邮件合并到 Word 中的电子邮件。一切都准备就绪，可以出发了。无需代码。
这只是一个更大项目的一小部分，用于跟踪培训课程的参与者注册情况。现在所有的实现都在 Excel 中，我想在不离开程序的情况下完成它。
另外，我不知道 Word 可以根据条件发送完全不同的电子邮件模板。在现实生活中的示例中，参与者有 4 种类型的待处理状态（待处理 1、待处理 2 等）。基于此，我将发送不同类型的电子邮件。 Pending1 通知注册，pending2 通知等候名单的参与者，pending3 通知当某人的状态更改为已注册，pending4 通知当状态更改为取消。
是的，Word 可以做到这一点。合并字段可以处理条件逻辑。

标签： excel vba

【解决方案1】：

您在Do 循环中遗漏了两行关键代码：

Set olMail = olApp.CreateItem(olMailItem)

最后：

Set olMail = Nothing

试试这个：

Sub SendMail()

    Dim EmailSent, EmailFailed, i As Integer
    Dim StatusSent, StatusFailed As String

    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")

    Dim olMail As Outlook.MailItem

    EmailSent = 0
    EmailFailed = 0
    StatusFailed = "failed"
    StatusSent = "sent"
    i = 1

    Do
    DoEvents
        Set olMail = olApp.CreateItem(olMailItem)

        With olMail
            .To = Cells(i, 1).Value
            .Subject = "test"
            .CC = ""
            .BCC = ""
            .Importance = olImportanceHigh
            .BodyFormat = olFormatHTML

            .HTMLBody = Cells(i, 2).Value

            If Cells(i, 3) = 1 Then
                .HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 4))
            Else
                .HTMLBody = VBA.Replace(olMail.HTMLBody, "replace_me", Cells(i, 5))
            End If

           .send

        End With

        On Error Resume Next
        olMail.send

        If Err Then
            EmailFailed = EmailFailed + 1
            ActiveSheet.Cells(i, 6).Value = StatusFailed    'change status from pending to failed
        Else
            EmailSent = EmailSent + 1
            ActiveSheet.Cells(i, 6).Value = StatusSent  'change status from pending to sent
        End If

        Set olMail = Nothing

        i = i + 1
    Loop Until i = Range(Range("A1"), Range("A1").End(xlDown)).Count

    If EmailSent = 0 Then
        MsgBox Prompt:="Emails could not be sent"
    Else
        MsgBox Prompt:="Sent emails: " & EmailSent & vbNewLine _
        & "Failed emails: " & EmailFailed
    End If

    On Error GoTo 0
    Set olApp = Nothing

End Sub

【讨论】：