vbams-accessoutlook

Access VBA code generates separate email for each recipient; need to generate single email for each client with multiple recipients


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

Solution

  • 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.