无法发送多个 Outlook 邮件

Question

我可以使用 Excel VBA 发送单个 Outlook 邮件。但是，我想遍历我的行并为​​满足特定条件的每一行发送一封电子邮件。

不幸的是，当我将电子邮件代码放在 for 循环中时，只有一封电子邮件被发送或根本没有发送（取决于我如何构建代码）。

多次调用 Outlook 有什么我应该知道的吗？

Private Sub CommandButton1_Click()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim myValue As Variant
    Dim contactRange As Range
    Dim cell As Range
    Dim toAddy As String, nextAddy As String
    Dim i As Integer 
    Set contactRange = Me.Range("ContactYesNo")

    myValue = InputBox("Enter body of email message.")

    For Each cell In contactRange

        If Range(Cells(cell.Row, cell.Column).Address).Value = "Yes" Then
            nextAddy = Range(Cells(cell.Row, cell.Column).Address).Offset(0, 5).Value

            toAddy = nextAddy & ", " & toAddy

        End If

    Next cell

    If Len(toAddy) > 0 Then

        toAddy = Left(toAddy, Len(toAddy) - 2)

    End If

For i = 0 To 1 'short loop for testing purposes

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail

        .To = toAddy 
        .CC = ""
        .BCC = ""
        .Subject = "test email"
        .Body = myValue
        .Send
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

Next i


End Sub 

Answer 1

从循环中取出 CreateObject 行：

Set OutApp = CreateObject("Outlook.Application")
For i = 0 To 1 'short loop for testing purposes
    Set OutMail = OutApp.CreateItem(0)
    ...

Answer 2

我已尝试清理您的逻辑流，但由于缺少示例数据、明确的错误消息和输出，存在许多未解决的问题。

Private Sub CommandButton1_Click()
    Dim outApp As Object
    Dim outMail As Object
    Dim myValue As Variant
    Dim contactRange As Range
    Dim cell As Range
    Dim toAddy As String, nextAddy As String
    Dim i As Integer

    Set outApp = CreateObject("Outlook.Application")
    Set contactRange = Me.Range("ContactYesNo")

    myValue = InputBox("Enter body of email message.")

    With Worksheets(contactRange.Parent.Name)   '<~~ surely you know what worksheet you are on..!?!
        For Each cell In contactRange
            If cell.Value = "Yes" Then  'no need to define a range by the range's address
                nextAddy = cell.Offset(0, 5).Value  'again, no need to define a range by the range's address
                toAddy = nextAddy & ";" & toAddy    'use a semi-colon to concatenate email addresses
            End If
        Next cell
    End With

    If Len(toAddy) > 0 Then
        toAddy = Left(toAddy, Len(toAddy) - 2) 'I have no idea why you need to shorten the toAddy by 2

        'only send mail where one or more addresses exist
        For i = 0 To 1 'short loop for testing purposes
            Set outMail = outApp.CreateItem(0)
            With outMail
                .To = toAddy
                .CC = ""
                .BCC = ""
                .Subject = "test email"
                .Body = myValue
                .Send
            End With
            Set outMail = Nothing
        Next i
    End If
    Set outApp = Nothing
End Sub

Answer 3

好的，所以我根据反馈重新编写了代码。我使用循环一次发送一封电子邮件，而不是将地址连接在一起，因为我想个性化每封电子邮件。我还需要创建一个表单来处理输入，因为输入框只接受 256 个字符。

非常需要一个表格，因为我需要捕获主题行、邮件正文、称呼、附件路径等：

Private Sub CommandButton1_Click()

Dim subject As String, msg As String, path As String

subject = TextBox1.Value
msg = TextBox2.Value & vbCrLf & vbCrLf & "Sincerely," & vbCrLf & TextBox4.Value & vbCrLf & TextBox5
path = TextBox3.Value

UserForm1.Hide

Module1.sendEmail subject, msg, path

End Sub

我将电子邮件代码放在 Module1 中。请注意，请务必设置 .sentOnBehalfOfName 属性，否则如果您注册了多个帐户，Outlook 只会选择一个可能不是您想要的帐户：

Public Sub sendEmail(subject As String, msg As String, path As String)
Dim outApp As Object
Dim outMail As Object
Dim contactRange As Range, cell As Range
Dim toAddy As String, emailMsg As String
Dim count As Integer

Set outApp = CreateObject("Outlook.Application")
Set contactRange = Range("ContactYesNo")

With Worksheets("IT consulting")
    For Each cell In contactRange
        If cell.Value = "Yes" Then

            count = count + 1

            toAddy = cell.Offset(0, 6).Value
            emailMsg = "Dear " & cell.Offset(0, 2).Value & "," & vbCrLf & vbCrLf & msg

            Set outMail = outApp.CreateItem(0)
            With outMail
                .SentOnBehalfOfName = "me@someemail.com"
                .To = toAddy
                .CC = ""
                .BCC = ""
                .subject = subject
                .Body = emailMsg
                .Attachments.Add path
                '.Display
                .Send
            End With

            'log the action
            cell.Offset(0, 1).Value = Now & vbCrLf & cell.Offset(0, 1).Value

        End If
        Set outMail = Nothing

    Next cell
End With

Set outApp = Nothing

MsgBox "total emails sent: " & count

End Sub