excel - 从 Excel 设置批量分发电子邮件列表

Question

这应该是直截了当的，但我不知何故无法做到正确。我正在尝试从 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

Answer 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