转发电子邮件的代码很慢
我发送电子邮件到一个联系人的大名单。 我不想丢失原始邮件的格式。
我正在使用这个代码：
Dim emailad, firstname, pretit, midtit, prebod, bod, postbod As String Dim n As Integer n = 1 pretit = Sheets(CurrSh).Range("pretit").Value midtit = Sheets(CurrSh).Range("midtit").Value prebod = Sheets(CurrSh).Range("prebod").Value bod = Sheets(CurrSh).Range("bod").Value postbod = Sheets(CurrSh).Range("postbod").Value Dim objMail(1 To 500) As Object Set objitem = GetCurrentItem() '********** Send e-mail for each e-mail in the list *********** Set objMail(n) = CreateObject("Outlook.Application") While (Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value <> "") emailad = Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value firstname = Sheets(CurrSh).Range("firstname_ini").Offset(n, 0).Value Set objMail(n) = objitem.Forward objMail(n).To = emailad objMail(n).Subject = pretit & " " & firstname & midtit & " FWD: " & objitem.Subject objMail(n).HtmlBody = "<HTML><BODY><FONT FACE='Arial'><FONT SIZE='2'>" & prebod & " " & firstname & "," & "<br>" & bod & "<br>" & postbod & objMail(n).HtmlBody & "</FONT></FONT></BODY></HTML>" objMail(n).Display Set objMail(n) = Nothing n = n + 1 Wend Theend: End Sub 问题是这个代码太慢了。
在这个循环中性能较差的最强烈的嫌疑犯是为循环的每次迭代创build一个新的Outlook.Application对象。 这不应该是必要的。 将Set ObjApp = CreateObject("Outlook.Application")调用移到WHILE循环之前，并简单地重新使用其中的相同引用。
根据进一步的评论修改为OP：
我将简化这个代码，以匹配我认为你想要完成的事情。 我发现没有必要使用大量的邮件对象，因为您在显示后将它们设置为Nothing。 看来你想要做的就是把目前的项目，并发送给您的列表中的每个成员，定制与他们自己的名称为主题。 在这方面，我会试试这个：
Dim emailad, firstname, pretit, midtit, prebod, bod, postbod As String Dim mailApp Dim newItem Dim n As Integer n = 1 pretit = Sheets(CurrSh).Range("pretit").Value midtit = Sheets(CurrSh).Range("midtit").Value prebod = Sheets(CurrSh).Range("prebod").Value bod = Sheets(CurrSh).Range("bod").Value postbod = Sheets(CurrSh).Range("postbod").Value Set objitem = GetCurrentItem() Set mailApp = CreateObject("Outlook.Application") '********** Send e-mail for each e-mail in the list *********** While (Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value <> "") emailad = Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value firstname = Sheets(CurrSh).Range("firstname_ini").Offset(n, 0).Value Set newItem = mailApp.CreateItem(0) ' Create a new Mailitem; olMailItem = 0 newItem.To = emailad newItem.Subject = pretit & " " & firstname & midtit & " FWD: " & objitem.Subject newItem.HtmlBody = "<HTML><BODY><FONT FACE='Arial'><FONT SIZE='2'>" & prebod & " " & firstname & "," & "<br>" & bod & "<br>" & postbod & objItem.HtmlBody & "</FONT></FONT></BODY></HTML>" newItem.Send n = n + 1 Wend
除此之外，什么部分（特别是）慢？ 发送这封邮件的60份不应该那么长。 你确定你的循环在你期望的时候（只有60个名字）是终止的，还是你的表中的数据可能会阻止你的终止发生，导致它无限期地运行？