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?

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.

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!