遍历记录集中的电子邮件地址列表以发送定制的电子邮件答案

【问题标题】：Loop through list of email addresses in recordset to send tailored emails遍历记录集中的电子邮件地址列表以发送定制的电子邮件
【发布时间】：2021-05-31 03:37:14
【问题描述】：

我想遍历一个表格并向每个用户发送一封单独定制的电子邮件，其中包含他们的前缀和姓氏。

似乎只给名单上的第一个人发送电子邮件。

设计模式

带有虚拟数据的表单模式

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) 时会收到以下错误：

该项目已被移动或删除。

【问题讨论】：

您可能想尝试在循环中调用CreateItem，而不是一遍又一遍地使用相同的元素。另外，当您在调试器中单步执行代码时会发生什么？
我要补充一点，On Error Resume Next 可能隐藏了实际错误。
好的，我摆脱了 On Error Resume Next 并得到一个运行时错误：“该项目已被移动或删除。”
它在以下位置显示错误：.To = rs!Email
由于您没有在迭代之间更改记录集中的任何内容，因此听起来邮件项目对象一旦发送就无法重复使用 (.Send)。因此，正如我在第一条评论中指出的那样，您可能想尝试在 Do ... While 循环内移动邮件项目创建 (Set oEmailItem = oOutlook.CreateItem(olMailItem))——它当前在循环开始之前——所以你将创建每条记录都有一个新的邮件项目。另外，我强烈建议您使用调试器逐步完成代码；它会让这更清楚。

标签： vba loops ms-access outlook recordset

【解决方案1】：

因为 cmets 表明您只有一堆错误。假设您添加了对 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

【讨论】：