☰

向多个收件人发送带有不同附件的同一封电子邮件

tag-icon • tag-icon vba microsoft-outlook-2013
向多个收件人发送带有不同附件的同一封电子邮件

我认为可能有一种方法可以使用 VBA 来做到这一点，但我找不到有关如何通过 VBA 添加附件的任何文档。

以下是我发现的一些示例代码：

Sub SendMultipleEmails()
Dim objMail As Outlook.MailItem
Dim intX As Integer


For intX = 1 To 10 'Or get the value of intX from a file count
Set objMail = Application.CreateItem(olMailItem)
objMail.Subject = "My subject line"
objMail.Body = "My message body"
objMail.To = "
objMail.Attachments.Add "C:\temp\myfile.doc"
objMail.Send
Set objMail = Nothing
Next
End Sub

我现在唯一的挑战是创建一个循环，允许我向每个收件人发送不同的附件。收件人将按字母顺序排列，文件也是如此，因此只需在循环中使用文件的索引号即可。

答案1

这非常简单，允许用户向多个收件人发送电子邮件，每个收件人都带有不同的附件。在我的电子表格中，我将电子邮件和文件路径放在单元格中，For 循环每次运行时都会挑选出每个单独的收件人和文件。

Sub SendMultipleEmails()

Dim Mail_Object, OutApp As Variant


 With ActiveSheet
    lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

For i = 2 To lastrow

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

    With OutApp
    .Subject = "Your subject here"
    .Body = "Your message here"
    .To = Cells(i, 2).Value
    .Attachments.Add Cells(i, 4).Value
    .send
    End With

Next i

debugs:
If Err.Description <> "" Then MsgBox Err.Description

End Sub

答案2

感谢您提供这个有用的代码片段。我已将其扩展为允许多个附件，并希望与您分享：

Sub SendMultipleEmails()

    Dim Mail_Object, OutApp As Object
    Dim lastRow, i, j As Integer

     With ActiveSheet
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        End With

    For i = 2 To lastRow
        Set Mail_Object = CreateObject("Outlook.Application")
        Set OutApp = Mail_Object.CreateItem(0)
        OutApp.display
        Call AddAttachments(OutApp, Cells(i, 4).Value)
        With OutApp
        .Subject = Cells(8, "N").Value
        .Body = Cells(10, "N").Value
        .To = Cells(i, 2).Value
        .send
        End With

    Next i

    debugs:
    If Err.Description <> "" Then MsgBox Err.Description

End Sub

Sub AddAttachments(ByRef OutApp As Object, ByVal FilePathToAdd As String)
    Dim Attachments() As String
    Dim j As Integer

    If FilePathToAdd <> "" Then
        Attachments = Split(FilePathToAdd, ";")
        For j = LBound(Attachments) To UBound(Attachments)
            If Attachments(j) <> "" Then
                OutApp.Attachments.Add Trim(Attachments(j))
            End If
        Next j
    End If
End Sub

相关内容