1

我正在尝试使用特定的电子邮件帐户（不是默认帐户）从 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
4

2 回答 2

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
于 2012-10-23T17:39:10.377 回答
0

这对我有用。我有带有字段 [电子邮件] 的 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

于 2015-01-31T22:40:24.803 回答