访问VBA从DAO记录集发送outlook.mailitem与循环不循环通过整个表
问题描述：
我希望有人可以帮助我与下面的代码。尝试使用特定的电子邮件帐户（不是默认设置）从Outlook 2010发送电子邮件，该电子邮件基于静态模板，该模板从表格（发件人_表格）中为电子邮件正文中的（TO：主题和一些可变字段）提取数据。到目前为止，下面的代码的工作原理除了它不循环我的表中的所有记录。电子邮件通过指定的帐户发出，并从电子邮件中的表格中提取适当的数据，但在第一条记录后停止。访问VBA从DAO记录集发送outlook.mailitem与循环不循环通过整个表
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
答
您需要在循环中移动您的发送电子邮件代码，以便为每条记录发送一封电子邮件。像这样：
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
答
这对我有用。我有查询2与字段[电子邮件]; [地址]; [名称]。
我知道这是一个旧的线程，但我一直没能找到任何不会使安全消息弹出的代码。希望这有助于某人。
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