Need Help with code

[jsterling0231]

Hi All,

I am trying to email a group of records in a table and with the code I have written, it just loops to the first record in the recordset and will not move down to the next record. Can someone please help me with this problem. Below is my code.

Private Sub TestOutlook()

Dim db As Database
Dim rstMail As Recordset
Dim appOutlook As Outlook.Application
Dim MailOutlook As Outlook.MailItem

Set db = CurrentDb
Set rstMail = db.OpenRecordset("tblEmail", dbOpenDynaset)

Do Until rstMail.EOF

Set appOutlook = CreateObject("outlook.application")
Set MailOutlook = appOutlook.CreateItem(olMailItem)


    With MailOutlook
        .BodyFormat = olFormatRichText
        .To = DLookup("Email", "tblEmail")
        .Subject = DLookup("Subject", "tblEmail")
        .Send
    End With
    
    Set MailOutlook = Nothing
    Set appOutlook = Nothing
    
    rstMail.MoveNext
Loop

End Sub

Thanks for all your help :banghead:

 

[CJ_London]

Not sure why you are using Dlookup since you alreayd have the recordset open. Try

.To = rstMail.Fields("Email")
.Subject = rstMail.Fields("Subject")

Have you tried debugging to see what is actually happening? I presume there is more than one record in tblEmail?

 

[billmeye]

After setting the recordset, try adding:

Set rstMail = db.OpenRecordset("tblEmail", dbOpenDynaset)
rstMail.MoveLast
rstMail.MoveFirst

Also, if you are using the tblEmail as your recordset why are using Dlookup and not referencing the fields directly from the recordset?

    With MailOutlook
        .BodyFormat = olFormatRichText
        .To = rstMail!Email
        .Subject = rstMail!Subject
        .Send
    End With

 

[TJPoorman]

Also, I don't know if you have your settings in Outlook changed to allow programmatic access, but if you don't a faster way to automate this may be to use SMTP instead of outlook.

 

[jsterling0231]

Thanks CJ London for your help with this matter. I am new to coding and that is why I was using the Dlookup. Thanks for letting me know with the recordset open, I do not have to do this. The recordset does contain more than one email address. My ideal code would be to send one email message to many different email addresses at one time, but I have no idea how to even begin to code that one. If you have any suggestions, that would be wonderful!
Thank you again for your help.

 

[CJ_London]

My ideal code would be to send one email message to many different email addresses

At the moment your code will send an individual email message to all of the emails in tblEmail.

If you want to send one email to multiple addresses, you need to loop through the rstmail recordset to build the string and once this is done, send the email. e.g.

ToList=""
Do Until rstMail.EOF
    ToList=ToList & rstmail.Email & ";"
    rstMail.MoveNext
Loop
 
    Set appOutlook = CreateObject("outlook.application")
    Set MailOutlook = appOutlook.CreateItem(olMailItem)

    With MailOutlook
        .BodyFormat = olFormatRichText
        .To = ToList
        .Subject = rstMail.Fields("Subject")
        .Send
    End With
    
    Set MailOutlook = Nothing
    Set appOutlook = Nothing

Note that this is an example of what you can do - there may be limitations as to how many email addresses can be included in Outlook and it also makes the assumption that all the records in tblEmails have the same subject.

 

[TJPoorman]

Also here is some code to send via SMTP just in case you decide to go that route:

Public Function SimpleSendMail(strSubject As String, strSendto As String, strCC As String, strBCC As String, strMessage As String, strAttachmentPath As String)
Dim iCfg As Object
Dim iMsg As Object
 
Set iCfg = CreateObject("CDO.Configuration")
Set iMsg = CreateObject("CDO.Message")
 
With iCfg.Fields
    .Item("[URL]http://schemas.microsoft.com/cdo/configuration/sendusing[/URL]") = 2
    .Item("[URL]http://schemas.microsoft.com/cdo/configuration/smtpserver[/URL]") = "YourSMTPServer"
    .Item("[URL]http://schemas.microsoft.com/cdo/configuration/sendemailaddress[/URL]") = [EMAIL="sendemail@name.com"]sendemail@name.com[/EMAIL]
    .Item("[URL]http://schemas.microsoft.com/cdo/configuration/senduserreplyemailaddress[/URL]") = [EMAIL="replyemail@name.com"]replyemail@name.com[/EMAIL]
    .Update
End With
 
With iMsg
    .Configuration = iCfg
    .Subject = strSubject
    .To = strSendto
    .CC = strCC
    .BCC = strBCC
    .TextBody = strMessage
    .AddAttachment strAttachmentPath
    .Send
End With
 
Set iMsg = Nothing
Set iCfg = Nothing
End Function