基于查询结果发通知邮件：Access代码仅处理首条记录求助

Let's break down why your current code only handles the first record, and fix it step by step:

The Root Cause #

You're creating a single Outlook email object (oEmail) outside your recordset loop. Every iteration of the loop just overwrites the content of that one email, instead of generating a new email for each record. The SendKeys hack also isn't reliable for triggering sends across multiple emails—this approach can fail if Outlook's focus shifts unexpectedly.

Corrected Code #

Here's an updated version that properly loops through all matching records, sends individual emails, and adds your required "DueDate = Today" filter directly to the query:

Public Sub FollowUpEmail()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim oApp As Object
    Dim oEmail As Object
    Dim strSQL As String
    
    ' Initialize Outlook (handle case where Outlook isn't running)
    On Error Resume Next
    Set oApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set oApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    If oApp Is Nothing Then
        MsgBox "Could not initialize Outlook. Please check if it's installed.", vbCritical
        Exit Sub
    End If
    
    ' Connect to database and fetch ONLY records with today's DueDate
    Set db = CurrentDb
    strSQL = "SELECT FirstName, SurName, DueDate " & _
             "FROM TestQuery " & _
             "WHERE DueDate = Date()" ' Add date filter to avoid unnecessary loop checks
    
    Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
    
    ' Loop through all matching records
    While Not rs.EOF
        ' Create a NEW email for each record
        Set oEmail = oApp.CreateItem(0)
        
        With oEmail
            .To = "xxx@yourdomain.com" ' Replace with your target generic email
            ' Handle empty FirstName/SurName to avoid broken subject lines
            .Subject = Nz(rs.Fields("FirstName").Value, "Unknown User") & " - Deadline Today"
            .Body = "Reminder:" & vbCrLf & vbCrLf & _
                    "The task for " & Nz(rs.Fields("FirstName").Value, "a user") & " " & Nz(rs.Fields("SurName").Value, "") & _
                    " is due today (" & Format(rs.Fields("DueDate").Value, "mm/dd/yyyy") & ")." & vbCrLf & vbCrLf & _
                    "Please follow up promptly."
            
            ' Choose one option below:
            .Send ' Automatically send the email (no user input needed)
            ' .Display ' Show the email for manual review before sending
        End With
        
        ' Clean up the email object for this record
        Set oEmail = Nothing
        rs.MoveNext
    Wend
    
    ' Final cleanup
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set oApp = Nothing
    
    MsgBox "Follow-up emails processed successfully!", vbInformation
End Sub

Key Improvements Explained #

• Per-record email objects: We move Set oEmail = oApp.CreateItem(0) inside the loop, ensuring each record gets its own unique email instead of overwriting a single one.
• Built-in date filtering: The SQL query only pulls records where DueDate equals today, so we don't waste time looping through irrelevant entries.
• Reliable sending: Replaced the unstable SendKeys with .Send (or .Display if you need to preview emails before sending).
• Null value handling: Used Nz() to prevent errors if FirstName or SurName is empty, ensuring the email subject/body stays readable.
• Outlook error handling: Checks if Outlook is running, starts it if needed, and shows a user-friendly message if initialization fails.

内容的提问来源于stack exchange，提问作者mesakon