修改Access邮件发送代码：为每个客户生成单封多收件人邮件

原代码会为每个客户邮箱地址单独生成邮件，现在要改成每个客户名称对应一封邮件，把该客户名下的所有邮箱地址合并到收件人（To）字段中。

修改思路 #

1. 先从数据表中获取所有唯一的客户名称，避免重复处理同一客户
2. 针对每个客户，查询其对应的所有邮箱地址，用分号;拼接成字符串作为收件人
3. 把Outlook应用对象的创建移到循环外，减少资源消耗

修改后的完整代码 #

Function Send_Emails()
    
    Dim rsClients As DAO.Recordset
    Dim rsEmails As DAO.Recordset
    Dim EmailTo As String
    Dim EmailCc As String
    Dim EmailBcc As String
    Dim EmailSubject As String
    Dim EmailBody As String
    Dim ClientName As String
    Dim RMEmailAddress As String
    Dim SAEmailAddress As String
    Dim OtherEmailAddresses As String
    Dim AttachmentPath As String
    Dim OutApp As Outlook.Application
    
    ' 先获取所有唯一的客户名称及对应固定抄送人信息
    Set rsClients = CurrentDb.OpenRecordset("SELECT DISTINCT [Client Name], RMEmail, SAEmail FROM Email_Addresses ORDER BY [Client Name]")
    
    ' 提前创建Outlook应用，避免每次循环重复创建销毁
    Set OutApp = CreateObject("Outlook.application")
    
    With rsClients
        If Not .BOF And Not .EOF Then
            .MoveFirst
            While Not .EOF
                ClientName = .Fields("Client Name")
                RMEmailAddress = .Fields("RMEmail")
                SAEmailAddress = .Fields("SAEmail")
                OtherEmailAddresses = "name1@domain.com; name2@domain.com"
                
                ' 查询当前客户的所有邮箱地址并拼接
                EmailTo = ""
                Set rsEmails = CurrentDb.OpenRecordset("SELECT [CONTACT EMAIL ADDRESS] FROM Email_Addresses WHERE [Client Name] = '" & Replace(ClientName, "'", "''") & "'")
                With rsEmails
                    If Not .BOF And Not .EOF Then
                        .MoveFirst
                        While Not .EOF
                            If EmailTo <> "" Then EmailTo = EmailTo & "; "
                            EmailTo = EmailTo & .Fields("CONTACT EMAIL ADDRESS")
                            .MoveNext
                        Wend
                    End If
                    .Close
                End With
                Set rsEmails = Nothing
                
                ' 组装邮件其他参数
                EmailCc = RMEmailAddress & "; " & SAEmailAddress & "; " & OtherEmailAddresses
                EmailBcc = ""
                EmailSubject = "Report - " & ClientName
                EmailBody = "test"
                AttachmentPath = YrMoDayHrMin_Fldr & ClientName & " Final Docs " & Format(Now(), "yyyymmdd") & ".xlsx"
                
                ' 创建并发送邮件
                Dim OutMail As Outlook.MailItem
                Set OutMail = OutApp.CreateItem(olMailItem)
                With OutMail
                    .To = EmailTo
                    .CC = EmailCc
                    .BCC = EmailBcc
                    .Subject = EmailSubject
                    .SentOnBehalfOfName = "name3@domain.com"
                    .HTMLBody = EmailBody
                    ' 检查附件是否存在，避免报错
                    If Dir(AttachmentPath) <> "" Then
                        .Attachments.Add AttachmentPath
                    End If
                    .Send
                End With
                Set OutMail = Nothing
                
                .MoveNext
            Wend
        End If
        .Close
    End With
    
ExitFunction:
    ' 清理资源
    Set rsClients = Nothing
    Set OutApp = Nothing
    MsgBox "邮件发送完成，可以关闭Access了。"
    Exit Function
    
End Function

额外优化说明 #

• 加入了附件路径检查，避免因文件不存在导致代码报错
• 用Replace(ClientName, "'", "''")处理客户名称中的单引号，防止SQL查询语法错误
• 提前初始化Outlook对象，减少循环内的资源开销，提升运行效率

内容的提问来源于stack exchange，提问作者Megan Gilland