Access 2013：按分组收件人发送报表分组区段邮件

针对你需要按报表分组（GROUPED BY "UW"）发送对应区段数据的需求，我整理了两种实用方案，都基于VBA+SQL调用Outlook来实现邮件发送：

最优方案：单按钮批量发送所有分组邮件 #

这个方案只需要在窗体上添加一个按钮，点击后自动遍历所有唯一的"UW"，为每个UW生成仅包含其对应行数据的邮件并发送，效率最高。

实现步骤： #

1. 在Access中创建一个窗体，添加一个命令按钮（命名为cmdSendAllUWReports）
2. 编写按钮的点击事件VBA代码，逻辑如下：
   • 获取所有不重复的"UW"值列表
   • 循环遍历每个"UW"，筛选出对应的数据
   • 将筛选后的数据格式化为邮件内容（可以用HTML表格或Access报表快照）
   • 调用Outlook创建并发送邮件

VBA代码示例： #

Private Sub cmdSendAllUWReports_Click()
    Dim db As DAO.Database
    Dim rsUW As DAO.Recordset
    Dim rsData As DAO.Recordset
    Dim olApp As Object
    Dim olMail As Object
    Dim strSQL As String
    Dim strBody As String
    Dim strUW As String
    Dim strEmail As String
    
    ' 初始化数据库对象
    Set db = CurrentDb()
    
    ' 获取所有唯一的UW及其邮箱地址（假设你的表包含UW和Email字段）
    strSQL = "SELECT DISTINCT UW, Email FROM YourTableName;"
    Set rsUW = db.OpenRecordset(strSQL)
    
    ' 初始化Outlook对象
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    ' 遍历每个UW
    Do While Not rsUW.EOF
        strUW = rsUW!UW
        strEmail = rsUW!Email
        
        ' 筛选当前UW对应的数据
        strSQL = "SELECT * FROM YourTableName WHERE UW = '" & Replace(strUW, "'", "''") & "';"
        Set rsData = db.OpenRecordset(strSQL)
        
        ' 构建HTML格式的邮件内容
        strBody = "<html><body>"
        strBody = strBody & "<h3>你的专属数据报表 - UW: " & strUW & "</h3>"
        strBody = strBody & "<table border='1'><tr>"
        ' 添加表头
        For Each fld In rsData.Fields
            strBody = strBody & "<th>" & fld.Name & "</th>"
        Next fld
        strBody = strBody & "</tr>"
        ' 添加数据行
        Do While Not rsData.EOF
            strBody = strBody & "<tr>"
            For Each fld In rsData.Fields
                strBody = strBody & "<td>" & Nz(fld.Value, "") & "</td>"
            Next fld
            strBody = strBody & "</tr>"
            rsData.MoveNext
        Loop
        strBody = strBody & "</table></body></html>"
        
        ' 创建并发送邮件
        Set olMail = olApp.CreateItem(0)
        With olMail
            .To = strEmail
            .Subject = "UW报表 - " & strUW
            .HTMLBody = strBody
            .Send ' 使用.Display可以先预览再发送
        End With
        
        rsData.Close
        rsUW.MoveNext
    Loop
    
    ' 清理对象
    rsUW.Close
    Set rsUW = Nothing
    Set rsData = Nothing
    Set db = Nothing
    Set olMail = Nothing
    Set olApp = Nothing
    
    MsgBox "所有UW报表邮件已发送完成！", vbInformation
End Sub

次优方案：分组区段单独按钮发送 #

如果不需要批量发送，也可以在报表的分组页眉或页脚添加按钮，点击按钮时仅发送当前分组区段的邮件给对应UW。

实现步骤： #

1. 打开你的报表设计视图，找到分组区段（比如"UW"分组页眉）
2. 添加一个命令按钮（命名为cmdSendCurrentUW）
3. 编写按钮的点击事件VBA代码，获取当前分组的UW值并发送对应数据

VBA代码示例： #

Private Sub cmdSendCurrentUW_Click()
    Dim db As DAO.Database
    Dim rsData As DAO.Recordset
    Dim olApp As Object
    Dim olMail As Object
    Dim strSQL As String
    Dim strBody As String
    Dim strUW As String
    Dim strEmail As String
    
    ' 获取当前分组的UW值
    strUW = Me.UW.Value
    
    ' 获取当前UW的邮箱地址
    Set db = CurrentDb()
    strSQL = "SELECT Email FROM YourTableName WHERE UW = '" & Replace(strUW, "'", "''") & "' LIMIT 1;"
    Set rsData = db.OpenRecordset(strSQL)
    If Not rsData.EOF Then
        strEmail = rsData!Email
    Else
        MsgBox "未找到UW " & strUW & " 的邮箱地址！", vbExclamation
        Exit Sub
    End If
    rsData.Close
    
    ' 筛选当前UW对应的数据
    strSQL = "SELECT * FROM YourTableName WHERE UW = '" & Replace(strUW, "'", "''") & "';"
    Set rsData = db.OpenRecordset(strSQL)
    
    ' 构建HTML邮件内容（逻辑同最优方案）
    strBody = "<html><body>"
    strBody = strBody & "<h3>你的专属数据报表 - UW: " & strUW & "</h3>"
    strBody = strBody & "<table border='1'><tr>"
    For Each fld In rsData.Fields
        strBody = strBody & "<th>" & fld.Name & "</th>"
    Next fld
    strBody = strBody & "</tr>"
    Do While Not rsData.EOF
        strBody = strBody & "<tr>"
        For Each fld In rsData.Fields
            strBody = strBody & "<td>" & Nz(fld.Value, "") & "</td>"
        Next fld
        strBody = strBody & "</tr>"
        rsData.MoveNext
    Loop
    strBody = strBody & "</table></body></html>"
    
    ' 初始化Outlook并发送邮件
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    Set olMail = olApp.CreateItem(0)
    With olMail
        .To = strEmail
        .Subject = "UW报表 - " & strUW
        .HTMLBody = strBody
        .Send ' 替换为.Display可预览
    End With
    
    ' 清理对象
    rsData.Close
    Set rsData = Nothing
    Set db = Nothing
    Set olMail = Nothing
    Set olApp = Nothing
    
    MsgBox "当前UW报表邮件已发送！", vbInformation
End Sub

注意事项： #

• 请将代码中的YourTableName替换为你的实际数据表名称
• 确保你的数据表包含UW和Email字段（如果字段名不同，请对应修改代码）
• 发送邮件前需要确保Outlook已正常登录，并且Access有调用Outlook的权限
• 可以将.Send改为.Display来先预览邮件内容，确认无误后再手动发送

内容的提问来源于stack exchange，提问作者Vesper Annstas