MS Access - 使用 RS 循环浏览电子邮件地址列表并发送定制的电子邮件 - 仅发送到列表中的第一个

问题描述

我想遍历一个表并运行一个循环，向每个用户发送一封单独​​定制的电子邮件，其中包含他们的前缀和姓氏。我以为我有这个权利，但它似乎只给列表中的第一个人发电子邮件。知道出了什么问题吗？

为了更好地了解上下文，我提供了设计和表单模式下的屏幕截图。

我的问题是什么，我将如何解决？

Private Sub SendEmail_Click()

    Dim oOutlook As outlook.application
    Dim oEmailItem As MailItem
    Dim rs As DAO.Recordset
    
    On Error Resume Next
    Err.Clear
    Set oOutlook = Getobject(,"outlook.application")
    
    If Err.Number <> 0 Then
        Set oOutlook = New outlook.application
    End If
    
    Set oEmailItem = oOutlook.CreateItem(olMailItem)
    Set rs = CurrentDb.OpenRecordset("SELECT * FROM list_of_emails")
    
    If Not (rs.BOF And rs.EOF) Then
        rs.MoveFirst
        Do Until rs.EOF = True
    
            With oEmailItem
                .To = rs!Email
                .Subject = "NKS: Test"
                .Body = "Hi " & [Prefix] & " " & [lname] & ":" & vbCrLf & vbCrLf & "This is a test."
                .Send
            End With
            rs.MoveNext
        Loop
    End If
    rs.Close
    
    Set oEmailItem = nothing
    Set oOutlook = nothing
    Set rs = nothing

End Sub

如果删除 On Error Resume Next，分配收件人地址 (.To = rs!Email) 时会出现以下错误：

该项目已被移动或删除。

解决方法

正如评论表明你只是有一堆错误。假设您添加了对 Outlook 16 对象库的引用，并且 Prefix 和 lname 是 list_of_emails 表中的列，则：

Private Sub SendEmail_Click()

    Dim oOutlook As Outlook.Application
    Dim oEmailItem As MailItem
    Dim rs As DAO.Recordset
    
    'On Error Resume Next
    'Err.Clear
    'Set oOutlook = GetObject(,"Outlook.Application")
    
    'If Err.Number <> 0 Then
       ' Set oOutlook = New Outlook.Application
    'End If
    
    Set oOutlook = New Outlook.Application 'open outlook before start the loop
    Set rs = CurrentDb.OpenRecordset("SELECT * FROM list_of_emails")
    
    If Not (rs.BOF And rs.EOF) Then
        rs.MoveFirst
        Do Until rs.EOF = True
        Set oEmailItem = oOutlook.CreateItem(olMailItem) 'create new email for each email address
    
            With oEmailItem
                .To = rs!Email
                .Subject = "NKS: Test"
                .Body = "Hi " & rs!Prefix & " " & rs!lname & ":" & vbCrLf & vbCrLf & "This is a test."
                .Send
            End With
            rs.MoveNext
        Loop
    End If
    rs.Close
    
    Set oEmailItem = Nothing
    Set oOutlook = Nothing
    Set rs = Nothing

End Sub