时间戳

首页 > 解决方案 > VBA 访问帮助 - 一个用户的多行，需要将它们分组并只向该人发送一封电子邮件，而不是每行一封电子邮件

vba - VBA 访问帮助 - 一个用户的多行，需要将它们分组并只向该人发送一封电子邮件，而不是每行一封电子邮件

问题描述

我创建了一个 VBA 脚本，通过查询那些过期的票来发送电子邮件。当我运行下面的程序时，它会为每个过期项目生成一封电子邮件。但是，如果一个人有 4 张票过期，则会为同一个人生成 4 封电子邮件。我如何修改代码，以便如果我的表为一个用户有多行，它可以将它们分组并只向该人发送一封电子邮件，而不是每行一封电子邮件：

Option Compare Database
Option Explicit

Public Sub SendSerialEmail()

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
Dim strQry As String
Dim aHead(1 To 6) As String
Dim aRow(1 To 6) As String
Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outStarted As Boolean

'Create the header row
aHead(1) = "Ticket#"
aHead(2) = "Summary"
aHead(3) = "Ticket Status"
aHead(4) = "Date Created"
aHead(5) = "# Business Days Open"
aHead(6) = "Assigned To"

lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"


On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outStarted = True
End If


Set rs = CurrentDb.OpenRecordset("SELECT DISTINCT email, full_name FROM     OverdueTerminationTickets")
Do Until rs.EOF
Set outMail = outApp.CreateItem(olMailItem)
Set rec = CurrentDb.OpenRecordset("SELECT ID, title, full_name, created,     workdaysopen " & _
     "FROM OverdueTerminationTickets WHERE email = '" & rs!email & "'")
'loop through rec to build email body, array object is not needed.
Do Until rec.EOF
    strRecs = strRecs & rec!ID & ", " & rec!Title & ", " & rec!full_name & ", " & _
        rec!CREATED & ", " & rec!workdaysopen & vbCrLf
    rec.MoveNext
Loop
'set To, CC, Subject, concatenate strRecs to header string for HTMLBody and send email
strRecs = ""
rec.Close
rs.MoveNext
Loop

If outStarted Then
outApp.Quit
End If

Set outMail = Nothing
Set outApp = Nothing

End Sub

标签： vbams-access

解决方案

由于您有两个记录集，一个记录集应该是一组唯一的用户标识符，在这种情况下是电子邮件，然后将用户标识符过滤器应用于 rs 循环内的 rec。我认为不需要在每个记录行上重复全名（如果特定于收件人，也不需要其他数据，如标题和姓名）。

Set rs = CurrentDb.OpenRecordset("SELECT DISTINCT email, fullname FROM OverdueTerminalTickets")
Do Until rs.EOF
    Set outMail = outApp.CreateItem(olMailItem)
    Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen " & _
         "FROM OverdueTerminationTickets WHERE email = '" & rs!email & "'")
    'loop through rec to build email body, array object is not needed.
    Do Until rec.EOF
        strRecs = strRecs & rec!ID & ", " & rec!title & ", " & rec!name & ", " & _
            rec!created & ", " & rec!workdaysopen & vbCrLf
        rec.MoveNext
    Loop    
    'set To, CC, Subject, concatenate strRecs to header string for HTMLBody and send email
    ...
    strRecs = ""
    rec.Close
    rs.MoveNext
Loop

如果您希望数据在列中对齐，请在 strRecs 连接中使用 HTML 标记来构建表格结构。或者像最初那样在 rec 循环中使用数组 - 我只是从未走过那条路。

关键是，有两个记录集需要一个循环内的循环。另一种结构可以仅使用一个按电子邮件排序的记录集，然后使用一个变量设置为电子邮件，并If Then在记录中的电子邮件与变量不一致时检查代码 - 发送电子邮件并重置变量并开始构建新的消息正文。这种方法只有一个循环。

推荐阅读