循环，从DAO记录集发送Outlook邮件，而不是在整个表中循环

Question

我正在尝试使用特定的电子邮件帐户（默认情况下）从Outlook 2010发送电子邮件。

电子邮件基于静态模板，该模板从表格（senders_table）中为To，Subject和电子邮件正文中的一些变量字段提取数据。

代码不会循环遍历表中的所有记录。电子邮件通过指定的帐户退出，并从表中提取适当的数据，但在第一个记录后停止。

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 with Fields [email]; [地址]; [名称]。

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

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