Do Until Loop not executing email to all records in a recordset

brookse

I am attempting to perform a Do Until...loop which should search all records in a given recordset while looking for an email address from a particular field. A separate field in a table that has a null value will update when the loop is executed. My problem is that everything else is working except for when the email is sent, it only sends an email based on the information in the last row of the recordset. I believe the issue has something to do with my Do Until...loop. Can anyone offer fresh eyes on my code to see if I'm missing something from the loop?

Expand|Select|Wrap|Line Numbers

 Sub SecondEmailAttempt()
 
Dim db As dao.Database

Dim rs As dao.Recordset

Dim fld As dao.Field
 
Dim emailTo As String

Dim emailSubject As String

Dim emailText As String

Dim UPDATE As String

Dim Edit As String

Dim strCompleted As String

Dim strMessage As String
 
Dim oApp As New Outlook.Application

Dim oMail As Outlook.MailItem

Dim oStarted As Boolean

Dim EditMessage As Object
 
Dim qdf As QueryDef
 
On Error Resume Next

Set oApp = GetObject(, "Outlook.Application")

On Error GoTo 0

If oApp Is Nothing Then

    Set oApp = CreateObject("Outlook.Application")

    oStarted = True

End If
 
Set db = CurrentDb

On Error GoTo EricHandlingError

Set rs = db.OpenRecordset("SELECT * FROM ProductRequestForm_Eric WHERE SecondEmailDate Is Null AND FirstEmailDate <= Date()-7")
 
If Not (rs.BOF And rs.EOF) Then
 
rs.MoveLast

rs.MoveFirst

Do Until rs.EOF = True
 
    emailTo = (rs.Fields("SubmitterEmail").Value)

    'emailTo = Trim(rs.Fields("SubmitterEmail").Value) & " <"
 
    emailSubject = "Second Email Attempt"
 
    emailText = Trim("Hello " & rs.Fields("SubmitterFirstName").Value) & "," & vbCrLf
 
        emailText = emailText & "You have recently used an item that is undergoing evaluation. " & _

               "Please Click the link below to tell us about your experience with the" & rs.Fields("ProductDescription").Value & "." & _

                "You should receive an email each time you use an item under evaluation until the " & _

                "evaluation is complete. Lack of compliance could impact the decisions made on items under evaluation." & vbCrLf

        If (IsNull(rs.Fields("SecondEmailDate").Value)) Then

        rs.Edit

        rs.Fields("SecondEmailDate").Value = Date

        rs.UPDATE
 
    End If
 
    rs.MoveNext

Loop
 
        'rs.MoveFirst

    Set oMail = oApp.CreateItem(0)
 
    With oMail

        .To = emailTo

        .Subject = emailSubject

        .Body = emailText

        '.Send

        DoCmd.SendObject acSendForm, "ProductRequestForm", acFormatXLS, emailTo, , , emailSubject, emailText, False

        DoCmd.SetWarnings (False)
 
     End With
 
Exit Sub
 
    rs.Close
 
Set rs = Nothing

Set db = Nothing
 
If oStarted Then

    oApp.Quit

End If
 
Set oMail = Nothing

Set oApp = Nothing

EricHandlingError: MsgBox "There is no record to process in second date", vbOKOnly Exit Sub End If
 
End Sub

NeoPa

Hi. Welcome to Bytes.com.

I've updated your post to show the code properly, but have you even tried to compile it? That should be your first step.

Something is wrong with the code you posted in as much as it doesn't conform to the basic standards of VBA code. This may be because you made a mistake copying it from your project, or maybe because it's just got serious problems. Either way, you should always use Copy & Paste to transfer code across and always compile it first.

The compilation will pick up the obvious problems, like your last line, and Copy & Paste will ensure nobody wastes their time debugging what are simply transfer competence issues.

Code indenting is also very important - but must be done consistently and with logic. Without that the information that it's there to impart is actually misleading and causes more trouble than otherwise.

Perhaps another try showing more care and attention so that our experts only have to focus on the code's actual problems is called for here. You can also edit the OP (Original Post) if that's easier. We can pick up when we have a reliable copy of what you're working with.

twinnyfo

OK - I've got some time............

First, review this article: Sending e-mail via Outlook, and set up a module to do so.

Second, as NeoPa said, your code is a disaster (he didn't say, that, but I won't mince words). Here is how I would approach your code--then at least you will be able to troubleshoot things a bit better.

Expand|Select|Wrap|Line Numbers

 Public Sub SecondEmailAttempt()

On Error GoTo EH:

    Dim db              As DAO.Database

    Dim rst             As DAO.Recordset

    Dim strSQL          As String

    Dim strSendTo       As String

    Dim strSubject      As String

    Dim strEMailBody    As String
 
    strSQL = _

        "SELECT * " & _

        "FROM ProductRequestForm_Eric " & _

        "WHERE SecondEmailDate Is Null " & _

            "AND FirstEmailDate <= #" & Date - 7 & "#;"

    Set db = CurrentDb()

    Set rst = db.OpenRecordset(strSQL)

    With rst

        If Not (.BOF And .EOF) Then

            Call .MoveFirst

            Do While Not .EOF

                strSendTo = !SubmitterEmail

                strSubject = "Second Email Attempt"

                strEMailBody = _

                    "Hello " & !SubmitterFirstName & "," & vbCrLf & _

                    "You have recently used an item that is undergoing " & _

                    "evaluation. Please Click the link below to tell us " & _

                    "about your experience with the" & _

                    !ProductDescription & ". You should receive an email " & _

                    "each time you use an item under evaluation until the " & _

                    "evaluation is complete. Lack of compliance could " & _

                    "impact the decisions made on items under evaluation."

                Call .Edit

                !SecondEmailDate = Date

                Call .UPDATE
 
                'Generate and Display the E-Mail

                Call SendAnEMail(olSendTo:=strSendTo, _

                                 olSubject:=strSubject, _

                                 olEMailBody:=strEMailBody, _

                                 olDisplay:=True)

                Call .MoveNext

            Loop

        End If

    End With
 
ExitSub:
 
    rst.Close

    db.Close

    Set rst = Nothing

    Set db = Nothing
 
EH:

    MsgBox _

        "There was an error sending the e-mail!" & _

        vbCrLf & vbCrLf & _

        Err.Number & vbCrLf & _

        Err.Description, vbOKOnly

    GoTo ExitSub

End Sub

If you receive any errors now, let us know and then we will be able to address more succinctly.

Hope this hepps!

Do Until Loop not executing email to all records in a recordset

Post your reply

Similar topics