从查询向人员列表发送电子邮件 - 循环问题



我有一个显示联合查询结果的表单,该表单有一个带有以下代码的按钮。我希望按钮做的是分别向该查询的每个人发送他们的信息。 如果我离开"直到 - 循环",它会完美地创建电子邮件。当我包含循环时,我收到一条奇怪的消息,

运行时错误"-1834742 (ffe4010a(": 该项目已被移动或删除,集中在下面的 .bodyformat 行上。我尝试注释掉该行以查看发生了什么,错误移至 .to 行。我已经查看了我的 Do till Loop 并检查了Microsoft页面以及谷歌搜索那个荒谬的运行时错误,但我正在罢工。 有人看到我错过了什么吗?

Private Sub btnSend_Click()
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Dim strSubject As String
Dim strEmail As String
Dim strPDHSUM As String
Dim sqls As String
Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset
Set MyDb = CurrentDb
Set rsEmail = MyDb.OpenRecordset("eqREPPDHSummaryZero")
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With rsEmail
.MoveFirst
Do Until rsEmail.EOF
strEmail = .Fields(2)
strPDHSUM = .Fields(1)
With MailOutLook
.BodyFormat = olFormatRichText
.To = strEmail
'.CC = ""
'.bcc = ""
.Subject = "PDH Summary"
.HTMLBody = "Hello!" & "<br>" & "This is an automated reminder about the Professional Development Hour requirement for PFS. Each PFS staff member is required to have 4 hours of approved professional development each year. " & "<br>" & "<br>" & "So far this year you have taken " & strPDHSUM & " PD hours." & "<br>" & "<br>" & "Additional PDH classes are held each month and can be found at the " & "<a href=https://avalidaddress.com>PDH Class Schedule on OnBase</a> " & "If you feel there is an error in this information or need assistance signing up for PDH credits, please email " & "<a href=mailto:MyEmail@whereIWork.edu>Rob Loughrey</a>." & "<Br>" & "<br>" & "Thank you," & "<br>" & "PFS Education and Quality Unit"
.Send
'.Display    'Used during testing without sending (Comment out .Send if using this line)
End With
sqls = "INSERT INTO tblEmails " _
& "(TypeofEmail, SendDateTime, EmailAddress) VALUES " _
& "('PDH Summary', Now(), '" & strEmail & "');"
DoCmd.RunSQL sqls
.MoveNext
Loop
End With
Set MyDb = Nothing
Set rsEmail = Nothing
End Sub````

移动:Set MailOutLook = appOutLook.CreateItem(olMailItem)到记录集循环中

Do Until rsEmail.EOF
Set MailOutLook = appOutLook.CreateItem(olMailItem)

必须创建与电子邮件发送一样多的邮件项目。当它在 For 循环之外时,只创建了一个仅适用于发送的第一封邮件的邮件项目,当循环第二次被击中时,MailOutlook 消失了,因此代码失败。

最新更新