尝试使用 VBA Code for Access 搜索表中的所有行

如何解决尝试使用 VBA Code for Access 搜索表中的所有行

我正在尝试调用几个模块，这些模块被设置为使用函数向表中列出的指定用户发送电子邮件。电子邮件遵循的逻辑应该设置为在 7 天后向每个用户发送电子邮件，这取决于他们之前通过电子邮件发送的日期（FirstemailDate、SecondEmailDate、ThirdEmailDate 和 FinalEmailDate）。我很难使用这种逻辑，搜索整个表的每一行，并能够自动为每个电子邮件日期的字段添加日期和时间戳。对此编码的任何帮助将不胜感激。谢谢

以下仅以一个模块为例：

Option Compare Database
Option Explicit

Sub EmailFinalAttempt()
   
Dim db As DAO.Database
Dim rs As DAO.Recordset

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
Set rs = db.OpenRecordset("SELECT * FROM ProductRequestForm")
        
rs.MoveFirst
do while Not rs.EOF
    
    emailTo = 'email address'
    
    emailSubject = "Final Email Attempt"
    
    emailText = Trim("Hello " & rs.Fields("SubmitterFirstName").Value) & "," & vbCrLf
    
    If (rs.Fields("ThirdEmailDate").Value >= 7 Or (IsNull(rs.Fields("FinalEmailDate").Value))) And (rs.Fields("ThirdEmailDate").Value) Then
        emailText = emailText & "message body" & _ vbCrLf
    
    ' If today is greater than third attempt date and third attempt is + Null then send email
        
    End If
        rs.MoveNext
    Loop
    
        rs.MoveFirst
        do while Not rs.EOF
        If rs.Fields("Completed?").Value = "Active" Then
        rs.Edit
        rs.Fields("Completed?").Value = "Inactive"
        rs.UPDATE
    
    End If
    
       rs.MoveNext
     Loop
        
        rs.MoveNext
        do while Not rs.EOF
        If rs.Fields("FinalEmailDate").Value Then
        rs.Edit
        rs.Fields("FinalEmailDate").Value = Date
        rs.UPDATE
        
    End If
        
        rs.MoveLast
        
    Set oMail = oApp.CreateItem(0)
    
    With oMail
        .To = emailTo
        .Subject = emailSubject
        .Body = emailText
        '.Save
        DoCmd.Sendobject acSendForm,"ProductRequestForm",acFormatXLS,emailTo,emailSubject,emailText,False
        DoCmd.SetWarnings (False)
        
     End With
      
    rs.MoveNext
Loop

    rs.Close

Set rs = nothing
Set db = nothing

If oStarted Then
    oApp.Quit
End If

Set oMail = nothing
Set oApp = nothing

结束子

解决方法

无论最后一封电子邮件的日期如何，都应该能够通过一个程序完成此操作。

仅提取符合 7 天标准的记录。计算一个字段，该字段标识要更新的周期和字段。假设在创建记录时填充了 FirstEmailDate。

Set rs = db.OpenRecordset("SELECT *," & _
           " Switch(IsNull(SecondEmailDate),"Second",IsNull(ThirdEmailDate),"Third",True,"Final") AS Fld " & _
           " FROM ProductRequestForm WHERE FinalEmailDate Is Null " & _
           " AND Nz(ThirdEmailDate,Nz(SecondEmailDate,FirstEmailDate)) <= Date()-7")

使用记录集中的 Fld 值更新相应的字段。
rs(rs!Fld & "EmailDate") = Date()