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
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).