我会邀请你测试下面的代码，我已经测试了这段代码。
这个想法是检查一个电子邮件地址是否已被使用，以便为每个用户发送一封电子邮件。
将所有工单发送给所有用户，每个用户只有 1 封电子邮件
Public Function IsEmailInArray(strEmail As String, arr() As String, lUbound As Long) As Boolean
Dim i
For i = 1 To lUbound
If arr(i) = strEmail Then
IsEmailInArray = True
Exit Function
End If
Next
IsEmailInArray = False
End Function
Public Sub so66016960SendSerialEmail()
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
Dim strTable As String
'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) = "<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 db = CurrentDb
Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
' Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
'
' get listing table of all overdue tickets:
'
Do Until rs.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rs("ID")
aRow(2) = rs("title")
aRow(3) = rs("name")
aRow(4) = rs("created")
aRow(5) = rs("workdaysopen")
aRow(6) = rs("full_name")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rs.MoveNext
Loop
aBody(lCnt) = aBody(lCnt) & "</table>"
'
strTable = Join(aBody, vbNewLine)
'
'If outStarted Then
' outApp.Quit
'End If
'
'
' rewind:
'
rs.MoveFirst
'
' now we reuse aBody() array as temporay array to used email addresses:
'
lCnt = 0
'
Do Until rs.EOF
emailTo = rs.Fields("email").Value
'
' if email is not yet used:
'
If (Not IsEmailInArray(emailTo, aBody, lCnt)) Then
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.CC = "myemail@gmail.com"
outMail.Subject = emailSubject
outMail.HTMLBody = "<html><body style=font-size:11pt;font-family:Segoe UI>" & _
"Hi " & nameemployee & "," & _
"<br>" & "<br>" & _
"<b><span style=""font-size:14pt;font-family:Segoe UI;color:#B22222"">Overdue Termination Tickets</b>" & _
strTable & _
"<br>" & _
"<b><i><span style=""font-size:11pt;font-family:Segoe UI;color:#000000"">**Please note that tickets are overdue.</i></b>" & _
"</body></html>"
outMail.Display
'
' memory the email address just sent:
'
lCnt = lCnt + 1
aBody(lCnt) = emailTo
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Sub
要发送仅包含她/他自己信息的电子邮件，我们通过电子邮件订购，如下所示：
Public Function send1Mail(ByVal outApp, ByVal strEmail2Use, ByVal nameemployee, ByVal emailSubject, ByVal emailText, ByVal strTable)
Dim outMail As Outlook.MailItem
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = strEmail2Use
outMail.CC = "myemail@gmail.com"
outMail.Subject = emailSubject
outMail.HTMLBody = "<html><body style=font-size:11pt;font-family:Segoe UI>" & _
"Hi " & nameemployee & "," & _
"<br>" & "<br>" & _
"<b><span style=""font-size:14pt;font-family:Segoe UI;color:#B22222"">Overdue Termination Tickets</b>" & _
strTable & _
"<br>" & _
"<b><i><span style=""font-size:11pt;font-family:Segoe UI;color:#000000"">**Please note that tickets are overdue.</i></b>" & _
"</body></html>"
outMail.Display
Set outMail = Nothing
send1Mail = 1
End Function
Public Sub SendSerialEmail2Each()
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
'
' nRows: number of rows in the table
' strTable: html table
' strTableHeader: html table header
' strEmail2Use: email address to send message
'
Dim nRows As Long
Dim strTable As String, strTableHeader As String, strEmail2Use As String
'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)
' strTableHeader = "<table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'
strTableHeader = "<table border='2'>" & _
"<tr>" & _
"<th>Ticket#</th>" & _
"<th>Title</th>" & _
"<th>Name</th>" & _
"<th>Date Create</th>" & _
"<th># Business Days Open</th>" & _
"<th>Assigned To</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 db = CurrentDb
'
' ORDRER BY email is important here:
'
Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets ORDER BY email;")
' Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
nRows = rs.RecordCount
'
' initialize:
'
lCnt = 0
strEmail2Use = ""
strTable = ""
'
Do Until rs.EOF
lCnt = lCnt + 1
'
' get email of the current record:
'
emailTo = rs.Fields("email").Value
'
' if first record: save email address and name.
'
If (lCnt = 1) Then
strEmail2Use = emailTo
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
'
' send the email if address changes:
'
ElseIf (strEmail2Use <> emailTo) Then
'
' close the html table:
'
strTable = strTableHeader & strTable & "</table>"
'
' send 1 single mail:
'
send1Mail outApp, strEmail2Use, nameemployee, emailSubject, emailText, strTable
strEmail2Use = emailTo
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
strTable = ""
End If
'
' aggregate all records per user for tr's:
'
strTable = strTable & _
"<tr>" & _
"<td>" & rs("ID") & "</td>" & _
"<td>" & rs("title") & "</td>" & _
"<td>" & rs("name") & "</td>" & _
"<td>" & rs("created") & "</td>" & _
"<td>" & rs("workdaysopen") & "</td>" & _
"<td>" & rs("full_name") & "</td>" & _
"</tr>"
'
' also send email at the last row of recordset:
'
If (lCnt = nRows) Then
'
' close the html table:
'
strTable = strTableHeader & strTable & "</table>"
'
' send 1 single mail:
'
send1Mail outApp, strEmail2Use, nameemployee, emailSubject, emailText, strTable
'
End If
'
' move next:
'
rs.MoveNext
Loop
'
' do this to save RAM:
'
rs.Close
Set rs = Nothing
Set db = Nothing
If outStarted Then
outApp.Quit
End If
Set outApp = Nothing
End Sub
测试数据截图：
生成以下 Outlook 电子邮件 Windows 以单击并发送。