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

无法发送多个Outlook邮件

3 个答案: