Access 2002 email all query records per vendor - ms-access

Question

I have a vba that can send out multiple emails to vendors, but I would like to change it so it embeds the query and only sends one email per vendor. Here is what I have so far:
Option Compare Database
Public Sub SendFollowUpEmail()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim emailTo As String
Dim emailSubject As String
Dim emailText As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outlookStarted = True
End If
Set db = CurrentDb
strSQL = "SELECT qry002UnmatchedOpenInvoices.kyUnique, qry002UnmatchedOpenInvoices.[Vendor Nbr],qry002UnmatchedOpenInvoices.[Vendor Name], " & _
" qry002UnmatchedOpenInvoices.[Purchasing Document], qry002UnmatchedOpenInvoices.Item,qry002UnmatchedOpenInvoices.[Document Date], " & _
" qry002UnmatchedOpenInvoices.Material, qry002UnmatchedOpenInvoices.[Short Text],qry002UnmatchedOpenInvoices.[Material Group], " & _
" qry002UnmatchedOpenInvoices.[Invoice Sent], qry002UnmatchedOpenInvoices.[Order Quantity],qry002UnmatchedOpenInvoices.[Order Unit], " & _
" qry002UnmatchedOpenInvoices.[Quantity in SKU], qry002UnmatchedOpenInvoices.[Stockkeeping unit],qry002UnmatchedOpenInvoices.[Net price], " & _
" qry002UnmatchedOpenInvoices.Currency, qry002UnmatchedOpenInvoices.[Price Unit],qry002UnmatchedOpenInvoices.[Release status], " & _
" qry002UnmatchedOpenInvoices.[No of Positions], tblVendors.Vendor, tblVendors.Email " & _
" FROM qry002UnmatchedOpenInvoices LEFT JOIN tblVendors ON qry002UnmatchedOpenInvoices.[Vendor Nbr] =tblVendors.[Vendor Number] " & _
" WHERE (((qry002UnmatchedOpenInvoices.Material) Is Null) AND ((qry002UnmatchedOpenInvoices.[Invoice Sent]) Is Null));"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
Do Until rs.EOF
emailTo = Trim(rs.Fields("Email").Value & "; tom.nguyen#flocorp.com;mike.huston#flocorp.com")
emailSubject = "Open Invoices"
emailText = Trim("Please send invoices of the below Purchase Orders:") & vbCrLf
emailText = emailText & _
"PO# " & rs.Fields("[Purchasing Document]").Value
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.Subject = emailSubject
outMail.Body = emailText
outMail.Send
'rs.Edit
'rs("FUP_Date_Sent") = Now()
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outlookStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Sub

Answer 1

What you need to do is to use two recordsets. The first selects the distinct vendors, and the second selects the invoices for that vendor. Something like:
Sub sSendFollowUpEMail()
On Error GoTo E_Handle
Dim db As DAO.Database
Dim rsVendor As DAO.Recordset
Dim rsInvoice As DAO.Recordset
Dim objOL As New Outlook.Application
Dim objMail As Outlook.MailItem
Dim strSQL As String
Dim emailTo As String
Dim emailText As String
Set db = CurrentDb
strSQL = "SELECT DISTINCT V.[Vendor Number], V.EMail " _
& " FROM qry002UnmatchedOpenInvoices AS I LEFT JOIN tblVendors AS V ON I.[Vendor Nbr]=V.[Vendor Number] " _
& " WHERE I.Material IS NULL " _
& " AND I.[Invoice Sent] IS NULL;"
Set rsVendor = db.OpenRecordset(strSQL)
If Not (rsVendor.BOF And rsVendor.EOF) Then
Do
strSQL = "SELECT I.[Purchasing Document] " _
& " FROM qry2002UnMatchedOpenInvoices AS I " _
& " WHERE I.Material IS NULL " _
& " AND I.[Invoice Sent] IS NULL " _
& " AND I.[Vendor Nbr]=" & rsVendor("Vendor Number") _
& " ORDER BY I.[Purchasing Document] ASC;"
Set rsInvoice = db.OpenRecordset(strSQL)
If Not (rsInvoice.BOF And rsInvoice.EOF) Then
emailText = "Please pay:"
Do
emailText = emailText & vbCrLf & rsInvoice("Purchasing Document")
rsInvoice.MoveNext
Loop Until rsInvoice.EOF
End If
emailTo = rsVendor!EMail
Set objMail = objOL.CreateItem(olMailItem)
objMail.To = emailTo
objMail.Subject = EmailSubject
objMail.Body = emailText
objMail.Send
rsVendor.MoveNext
Loop Until rsVendor.EOF
End If
sExit:
On Error Resume Next
rsVendor.Close
rsInvoice.Close
Set rsVendor = Nothing
Set rsInvoice = Nothing
Set db = Nothing
Set objMail = Nothing
objOL.Quit
Set objOL = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbcrfl & "sSendFollowUpEMail", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
A few notes.
In your original recordset you were including a whole load of fields that were not used in this procedure, which is not recommended - only get data that you need as this will enhance performance;
Secondly, it appears that you are mixing early and late binding of Outlook;
Finally, I've used aliases for the query/table names in the SQL statements - this makes the SQL more manageable, and also if you need to change one of the original tables/queries it is a lot easier to change the name just once.
Regards,