I created a VBA script to send emails from a query of those tickets that are overdue. When I run the program below, it generates an email per overdue item. However, if a person has 4 tickets overdue it generated 4 emails for the same person. How could I modify the code so that if my table has multiple lines for one user, it could group them and send only one email to the person as opposed to an email per line:
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 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") Do Until rec.EOF lCnt = lCnt + 1 ReDim Preserve aBody(1 To lCnt) aRow(1) = rec("ID") aRow(2) = rec("title") aRow(3) = rec("name") aRow(4) = rec("created") aRow(5) = rec("workdaysopen") aRow(6) = rec("full_name") aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>" rec.MoveNext Loop aBody(lCnt) = aBody(lCnt) & "</table></body></html>" If outStarted Then outApp.Quit End If Do Until rs.EOF emailTo = rs.Fields("email").Value 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 = "christina@gmail.com" outMail.Subject = emailSubject outMail.HTMLBody = "<BODY style=font-size:11pt;font-family:Segoe UI>" & "Hi " & nameemployee & "," & _ "<br>" & "<br>" & _ "<BODY style=font-size:14pt;font-family:Segoe UI>" & "<b><span style=""color:#B22222"">Overdue Termination Tickets</b>" & _ Join(aBody, vbNewLine) & _ "<br>" & _ "<BODY style=font-size:11pt;font-family:Segoe UI>" & "<b><i><span style=""color:#000000"">**Please note that according to procedures, etc.</i></b>" outMail.Display 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 
没有评论:
发表评论