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

Question

我有一个简单的 VBA 脚本，可以将我的 excel sheet 范围作为电子邮件的附件。

现在我需要遍历 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 属性取决于收件人的类型 returns 或设置一个整数对应于以下常量之一的数字等价物：

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

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

How do I loop through a range of 10 e-mail addresses and add them to email in VBA?

excel

outlook

vba