The function below runs in Access to email attachments. It works as expected. My problem: Some ClientName values are associated with multiple ClientEmailAddress values; as expected, the code below creates a separate email for each ClientEmailAddress, while I need to generate a single email for each ClientName, with the multiple ClientEmailAddress values all included in the To line. I am a novice and not sure how to accomplish this. Any help would be greatly appreciated. Thank you!
Function Send_Emails()
Dim rsSQL As String
Dim rs As DAO.Recordset
Dim EmailTo As String
Dim EmailCc As String
Dim EmailBcc As String
Dim EmailSubject As String
Dim EmailBody As String
Dim ClientName As String
Dim ClientEmailAddress As String
Dim RMEmailAddress As String
Dim SAEmailAddress As String
Dim OtherEmailAddresses As String
Dim AttachmentPath As String
rsSQL = "SELECT * FROM Email_Addresses"
Set rs = CurrentDb.OpenRecordset(rsSQL)
With rs
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
While (Not .EOF)
'Action to take on each record
ClientName = rs.Fields("Client Name")
ClientEmailAddress = rs.Fields("CONTACT EMAIL ADDRESS")
RMEmailAddress = rs.Fields("RMEmail")
SAEmailAddress = rs.Fields("SAEmail")
OtherEmailAddresses = "name1@domain.com; name2@domain.com"
EmailTo = ClientEmailAddress
EmailCc = RMEmailAddress & "; " & SAEmailAddress & "; " & OtherEmailAddresses
EmailBcc = ""
EmailSubject = "Report - " & ClientName
EmailBody = "test"
AttachmentPath = YrMoDayHrMin_Fldr & ClientName & " Final Docs " & Format(Now(), "yyyymmdd") & ".xlsx"
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Set OutApp = CreateObject("Outlook.application")
Set OutMail = OutApp.CreateItem(olMailItem)
OutMail.Display
With OutMail
.To = EmailTo
.CC = EmailCc
.BCC = EmailBcc
.Subject = EmailSubject
.SentOnBehalfOfName = "name3@domain.com"
.HTMLBody = EmailBody
.Attachments.Add AttachmentPath
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
'End action
.MoveNext
Wend
End If
.Close
End With
ExitFunction:
Set rs = Nothing
MsgBox "The macro has finished running. You may now close Access."
Exit Function
End Function
One approach uses nested loop structure - outer loop through recordset of unique client names and inner loop through recordset of addresses for each ClientName (filter by ClientID would be better) to build multi-address line.
Declare and set a database object:
Dim db As DAO.Database
Set db = CurrentDb
Outer loop recordset:
Set rsClients = db.OpenRecordset("SELECT [Client Name] FROM Clients")
or
Set rsClients = db.OpenRecordset("SELECT DISTINCT [Client Name] FROM Email_Addresses")
Then inner loop recordset:
Set rsAddresses = db.OpenRecordset("SELECT [CONTACT EMAIL ADDRESS] " & _
"FROM Email_Addresses " & _
"WHERE [Client Name]='" & rsClients("[Client Name]") & "'")
While Not rsAddresses.EOF
ClientEmailAddress = ClientEmailAddress & rsAddresses("[CONTACT EMAIL ADDRESS]") & ";"
rsAddresses.MoveNext
Wend
rsAddresses.Close
'code to send email
...
ClientEmailAddress = ""
If Client Name can have apostrophe such as in O'Hara, need to deal with that or the SQL WHERE criteria will fail and trigger run-time error. One way is to "escape" apostrophe character by doubling so SQL will see it as just plain text, not an unpaired delimiter:
Replace(rsClients("[Client Name]"), "'", "''")
Or use doubled quote mark in place of apostrophe delimiter:
"WHERE [Client Name]=""" & rsClients("[Client Name]") & """")
Alternatively, use parameters (review How do I use parameters in VBA in the different contexts in Microsoft Access?).
Can also be done with a single recordset. Could be faster performance and eliminates issue caused by apostrophe in names.
Sub Send_Emails()
...
Set rs = CurrentDb.OpenRecordset("SELECT * FROM Email_Addresses ORDER By [Client Name]")
rs.MoveLast
rs.MoveFirst
strClient = rs("Client Name")
For x = 1 To rs.recordCount + 1
If rs("Client Name") = strClient And x <= rs.recordCount Then
ClientEmailAddress = ClientEmailAddress & rs("CONTACT EMAIL ADDRESS") & ";"
If x < rs.recordCount Then rs.MoveNext
End If
If rs("Client Address") <> strClient Or x = rs.recordCount + 1 Then
'code here to open email object and send or display
...
strClient = rs("Client Name")
ClientEmailAddress = ""
End If
Next
...
End Sub
Strongly advise not to use spaces in object naming, better would be ContactEmailAddress or Contact_Email_Address. Same for Client Name.