Do Until Loop 不执行电子邮件到 table 中的所有记录

Question

我正在尝试执行一个 Do Until...循环，该循环应搜索给定记录集中的所有记录，同时从特定字段中查找电子邮件地址。 table 中具有空值的单独字段将在执行循环时更新。我的问题是，除了发送电子邮件时，其他一切都正常，它只根据记录集最后一行中的信息发送电子邮件。我相信这个问题与我的 Do Until...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

发送创建电子邮件命令似乎在您的循环之外。 Sub 循环遍历整个列表，然后它创建电子邮件并在您完成循环后发送它，此时，电子邮件变量包含最后一行的值。尝试在 Do Until 循环中移动 'Set oMail' 和 'With oMail' 语句（在 rs.MoveNext 行之前）。

Do Until Loop 不执行电子邮件到 table 中的所有记录

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

ms-access

until-loop