Question

我发送电子邮件给大量联系人。我不想丢失原始电子邮件的格式。

我正在使用此代码：

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

问题是这段代码太慢了。

Answer 1

此循环中性能不佳的最强嫌疑人是为循环的每次迭代创建一个新的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个名称）终止，或者您的工作表中的数据是否可能阻止您的终止发生在您预期的时间，导致它无限期地运行？

转发电子邮件的代码很慢

1 个答案: