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

Question

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

Answer 1

It appears that the send create email command is outside your loop. The Sub is looping through the entire list, and then it creates the email and sends it after you finish the loop, at which time, the email variables contain the values from the last row. Try moving the 'Set oMail' and 'With oMail' statements inside the Do Until loop (before the rs.MoveNext line).