如何遍历一系列 10 个电子邮件地址并将它们添加到 VBA 中的电子邮件？

Question

我有一个简单的 VBA 脚本，它将我的一系列 Excel 工作表作为附件附加到电子邮件中。

现在我需要遍历 mail-adresses 的范围（假设这是 A 列）并将它们添加为收件人。

我必须使用以下自动发送附件的代码，但我不知道如何实现将邮件地址添加到电子邮件中。

如何在下面的代码中实现这一点？

Sub Mail_Range()
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object

    Set Source = Nothing
    On Error Resume Next
    Set Source = Range("A1:K50").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)

    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If

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

    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .to = "test@test.com"
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = "Hi there"
            .Attachments.Add Dest.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

-- 编辑

我使用=TEXT.COMBINE(";";TRUE; AJ4:AJ15) 将邮件地址组合成一个字符串（在单元格 AJ16 中）。

接下来我将范围添加到OutMail.to = Range("AJ16")，但执行宏不会显示邮件中的收件人。我该如何解决？

With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .to = Range("AJ16")
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = "Hi there"
            .Attachments.Add Dest.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

Answer 1

获取范围值作为由; 分隔的文本，并在您的代码中将其设置为To 值。

---

'/Takes a vertical range and returns values as delimited text
Function GetAddressList(rng As Range)

    Dim arrEmails
    
    arrEmails = rng
    arrEmails = Application.Transpose(Application.Index(arrEmails, , 1))
    GetAddressList = Join(arrEmails, ",")
    
End Function

'/ This is how you use GetAddressList
Sub test()
    MsgBox GetAddressList(Sheet1.Range("A1:A10"))
End Sub

---

像这样OutMail.To = GetAddressList(Sheet1.Range("A1:A10"))

---

如果您有更新的 Excel 版本，那么您可以简单地在其中一个单元格中使用 TextJoin，然后直接调用该值

=TEXTJOIN(";",TRUE,A1:A10)

Answer 2

另一个例子是

Option Explicit
Public Sub Example()
' add ref - tool -> references - > Microsoft Outlook XX.X Object Library
    Dim olApp As Outlook.Application
    Set olApp = New Outlook.Application

    Dim Email As Outlook.MailItem
    Set Email = olApp.CreateItem(0)
    
    Dim Emails_Address_Sht As Excel.Worksheet
    Set Emails_Address_Sht = ThisWorkbook.Worksheets("Emails_Address")
    
    Dim Cell As Range
    Dim Emails As String
    For Each Cell In Emails_Address_Sht.Range("A1", _
                     Emails_Address_Sht.Range("A100").End(xlUp))
        Emails = Emails & Cell & ";"
    Next
    
    With Email
        .To = Emails
        .Subject = "Hello"
        .Display
    End With

End Sub

Answer 3

在电子邮件中添加收件人主要有两种方式：

• 修改由字符串表示的To、Cc、Bcc 属性。
• Recipients.Add 方法在Recipients 集合中创建一个新收件人。例如：

Sub CreateStatusReportToBoss() 

    Dim myItem As Outlook.MailItem 
    Dim myRecipient As Outlook.Recipient 

    Set myItem = Application.CreateItem(olMailItem) 
    Set myRecipient = myItem.Recipients.Add("Eugene Astafiev") 
    myItem.Subject = "Hello world" 
    myItem.Display 

End Sub

Recipient.Type 属性取决于接收者的类型，返回或设置一个整数，对应于以下常量之一的等效数字：

• JournalItem 收件人：OlJournalRecipientType 常量 olAssociatedContact。
• MailItem 收件人：以下OlMailRecipientType 常量之一：olBCC、olCC、olOriginator 或 olTo。
• MeetingItem 收件人：以下OlMeetingRecipientType 常量之一：olOptional、olOrganizer、olRequired 或 olResource。
• TaskItem 收件人：以下任一 OlTaskRecipientType 常量：olFinalStatus 或 olUpdate。

例如，向CC 字段添加新收件人：

Set myItem = Application.CreateItem(olMailItem)  
Set myRecipient = myItem.Recipients.Add ("Eugene Astafiev")  
myRecipient.Type = olCC