循环，从DAO RecordSet发送Outlook Mail，而不是在整个桌子上骑自行车

Question

我正在尝试使用特定的电子邮件帐户从Outlook 2010发送电子邮件。

电子邮件基于一个静态模板，该模板从表，主题和几个可变字段中从表（Senders_table）中获取数据。

代码没有循环在我的表中的所有记录中。电子邮件通过指定的帐户和正确的数据从表中删除，但在第一个记录后停止。

Private Sub test_Click()
'You must add a reference to the Microsoft Outlook Library
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strbody As String
Dim stremail As String
Dim strsubject As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("Senders_Table")
With rs
    If .EOF And .BOF Then
        MsgBox "No emails will be sent becuase there are no records assigned from the list", vbInformation
    Else
        Do Until .EOF
            stremail = ![email]
            strsubject = ![address]
            strbody = "Dear " & ![name] & "," & _
              Chr(10) & Chr(10) & "Some kind of greeting" & ![address] & "!" & _
              "  email message body goes here"
            .Edit
            .Update
            .MoveNext
        Loop
    End If
End With
On Error Resume Next
With OutMail
    .To = stremail
    .CC = ""
    .BCC = ""
    .Subject = strsubject
    .Body = strbody
    .SendUsingAccount = OutApp.Session.Accounts.Item(2)
    .Send
End With
On Error GoTo 0
If Not rs Is Nothing Then
    rs.Close
    Set rs = Nothing
End If
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Answer 1

您需要将发送电子邮件代码移入循环中，以便为每个记录发送电子邮件。这样的东西：

Set OutApp = CreateObject("Outlook.Application")
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("Senders_Table")
With rs
    If .EOF And .BOF Then
        MsgBox "No emails will be sent becuase there are no records assigned from the list", vbInformation
    Else
        Do Until .EOF
            stremail = ![email]
            strsubject = ![address]
            strbody = "Dear " & ![name] & "," & _
                      Chr(10) & Chr(10) & "Some kind of greeting" & ![address] & "!" & _
                      "  email message body goes here"
            '.Edit
            '.Update
            Set OutMail = OutApp.CreateItem(olMailItem)
            With OutMail
                .To = stremail
                .CC = ""
                .BCC = ""
                .Subject = strsubject
                .Body = strbody
                .SendUsingAccount = OutApp.Session.Accounts.Item(2)
                .Send
            End With            
            .MoveNext
        Loop
    End If
End With

Answer 2

这对我有用。我有带有字段的Query2 [电子邮件]；[地址];[姓名]。

我知道这是一个旧线程，但是我找不到任何不会使安全消息弹出的代码。希望这对某人有帮助。

Sub SendEmailFromQuery()
'You must add a reference to the Microsoft Outlook Library
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim strbody As String
Dim stremail As String
Dim strsubject As String
Set OutApp = CreateObject("Outlook.Application")
Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("Query2") ''add your query here
With rs
If .EOF And .BOF Then
MsgBox "No emails will be sent becuase there are no records assigned from the list", vbInformation
Else
Do Until .EOF
    stremail = ![email] ''Query2 Fields [email];  [Address];  [Name]
    strsubject = ![Address]
    strbody = "Dear " & ![Name] & "," & _
              Chr(10) & Chr(10) & "Some kind of greeting" & ![Address] & "!" & _
              "  email message body goes here"
On Error Resume Next
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
    .To = stremail
    .CC = ""
    .BCC = ""
    .Subject = strsubject
    .Body = strbody
    .SendUsingAccount = OutApp.Session.Accounts.Item(2)
    .Send
        End With
            .MoveNext
Loop
'On Error GoTo 0
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
Set OutMail = Nothing
Set OutApp = Nothing
End If
End With
End Sub