Trying to send to more than one recipient when emailing via CDO

[Keith Sparkes]

I am trying to send emails using CDO to different email recipients based on fields in a simple table called tblEmailRecipients.

There are currently 2 records in the table.

When I run my code, 2 emails are sent but the subject and text body are the same as the first record in my table. What I need to be able to do is to send to the number of records in the table with different subject. I have tried everything that I can think of and going round in circles with this.

My code is currently as follows:

Public Sub Email()
 
Dim db As DAO.Database
Dim rs As DAO.Recordset
  
Set db = CurrentDb
Set rs = db.OpenRecordset("tblEmailRecipients")
Set objMessage = CreateObject("CDO.Message")

Overdue = DLookup("Overdue", "tblEmailRecipients", "")
Forename = DLookup("Forename", "tblEmailRecipients", "")
Surname = DLookup("Surname", "tblEmailRecipients", "")
  
     Do Until rs.EOF
                    
            strEmail = rs!EmailAddress
            strSubject = "** Alert **" & "-" & Overdue & "-" & Surname & "," & Forename         
            strTextBody = "Please Check your records as some are overdue."      
            objMessage.To = strEmail
            objMessage.From = "emailaddress"
            objMessage.Subject = strSubject
            objMessage.TextBody = strTextBody
                     
            objMessage.Configuration.Fields.Item _
            ("<MS CDO SCHEMA>") = 2
            
            'Name or IP of Remote SMTP Server
            objMessage.Configuration.Fields.Item _
            ("<MS CDO SCHEMA>") = "SMTPSERVER"
            
            'Server port (typically 25)
            objMessage.Configuration.Fields.Item _
            ("<MS CDO SCHEMA>") = 25
            
            objMessage.Configuration.Fields.Update
         
            objMessage.Send
      
    rs.MoveNext
    
    Loop
       
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing
    
End Sub

(APOLOGIES FOR REMOVING THE CDO SCHEMAS AS MY POST DOESNT SEEM TO LIKE THESE SO HAVE REPLACED THE HTTP LINKS)

Please can anyone help me?

Many thanks for taking the time to read my post and any possible solutions are greatly appreicated.

 

[Peter Reid]

The subject isn't changing as the variables in the calculation are not changing as they are set outside of the loop.

Even if they were inside the loop, they would calculate the same value as they're basically calculating 'find the first value of the field in the table' - you have no condition at all. You don't really need to use dlookup here either as you have the table open in the recordset so could reference those fields in the same way you've calculated strEmail

I haven't got time to double check but I think the Set objMessage = CreateObject("CDO.Message") line should be within the loop - you are only creating one message but are sending it twice (?)

 

[Keith Sparkes]

Many thanks for this.

Being a fairly novice at this, do you think that you/someone will be able to help me code this. E.g where should objMessage = CreateObject("CDO.Message") go in the loop as well as where the subject should go to?

Once again, many thanks for all your help, it is much appreciated.

 

[Peter Reid]

As I said before, I'm not sure if the objMessage line needs to be moved. If I had time to research it for you, I would but I'm afraid I don't. As you were sending 2 emails before, it looks like it's working.

To get the subject changing, your code would have to change to

Public Sub Email()
 
Dim db As DAO.Database
Dim rs As DAO.Recordset
  
Set db = CurrentDb
Set rs = db.OpenRecordset("tblEmailRecipients")
Set objMessage = CreateObject("CDO.Message")
 
     Do Until rs.EOF
                    
            strEmail = rs!EmailAddress
            Overdue = rs!Overdue
            Forename = rs!Forename
            Surname = rs!Surname
            strSubject = "** Alert **" & "-" & Overdue & "-" & Surname & "," & Forename         
            strTextBody = "Please Check your records as some are overdue."      
            objMessage.To = strEmail
            objMessage.From = "emailaddress"
            objMessage.Subject = strSubject
            objMessage.TextBody = strTextBody
                     
            objMessage.Configuration.Fields.Item _
            ("<MS CDO SCHEMA>") = 2
            
            'Name or IP of Remote SMTP Server
            objMessage.Configuration.Fields.Item _
            ("<MS CDO SCHEMA>") = "SMTPSERVER"
            
            'Server port (typically 25)
            objMessage.Configuration.Fields.Item _
            ("<MS CDO SCHEMA>") = 25
            
            objMessage.Configuration.Fields.Update
         
            objMessage.Send
      
    rs.MoveNext
    
    Loop
       
    rs.Close
    db.Close
    Set rs = Nothing
    Set db = Nothing
    
End Sub

 

[Keith Sparkes]

Many thanks for this, you have been a great help!

I will have a play to see if I can get it to work and should be able to now after your great help.