通过Excel宏批量生成Outlook邮件时程序崩溃问题求助

我用社区协助编写的VBA宏从Excel提取数据生成Outlook邮件，因为需要检查内容后再发送，所以用了.Display而不是.Send。但处理超过100条记录时，Outlook会打开大量邮件窗口，随后崩溃关闭。

原代码 #

邮件生成与HTML转换模块 #

Option Explicit

Sub Mail_Workbook(ToString As String, SubjectString As String, BodyString As String, _
  Optional CCString As String, Optional BCCString As String, Optional AttachmentName As String)
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    ' Change the mail address and subject in the macro before you run it.
    With OutMail
        .SentOnBehalfOfName = "kontakt@xxx.pl"
        .To = ToString
        If CCString <> "" Then
            .CC = CCString
        End If
        If BCCString <> "" Then
            .BCC = BCCString
        End If
        .Subject = SubjectString
        .HTMLBody = BodyString
        If AttachmentName <> "" Then
            .Attachments.Add (AttachmentName)
        End If
        'Choose either Send or Display
        '.Send
        .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = ThisWorkbook.Path & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
    SourceType:=xlSourceRange, _
    Filename:=TempFile, _
    Sheet:=TempWB.Sheets(1).Name, _
    Source:=TempWB.Sheets(1).UsedRange.Address, _
    HtmlType:=xlHtmlStatic)
    .Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

主执行宏 #

Option Explicit

Sub SendNewMails()

    Dim clE As Range
    Dim shtA As Worksheet

    Set shtA = Sheets("MAKRO")
    Dim SubjectString As String
    SubjectString = Range("Mail_Subject")
   
    For Each clE In Range("Table1[mail]")
        Dim ToString As String
        ToString = clE.Value
        Dim BodyString As String
        BodyString = shtA.Cells(clE.Row, "J")
        Mail_Workbook ToString, SubjectString, BodyString
    Next
End Sub

解决方案 #

方案1：复用Outlook应用实例 #

原代码每次生成邮件都新建Outlook实例，会大幅占用系统资源。修改为全局复用一个实例：

修改后的邮件生成函数

Option Explicit

Sub Mail_Workbook(OutApp As Object, ToString As String, SubjectString As String, BodyString As String, _
  Optional CCString As String, Optional BCCString As String, Optional AttachmentName As String)
    Dim OutMail As Object
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .SentOnBehalfOfName = "kontakt@xxx.pl"
        .To = ToString
        If CCString <> "" Then
            .CC = CCString
        End If
        If BCCString <> "" Then
            .BCC = BCCString
        End If
        .Subject = SubjectString
        .HTMLBody = BodyString
        If AttachmentName <> "" Then
            .Attachments.Add (AttachmentName)
        End If
        .Display
    End With
    On Error GoTo 0
    Set OutMail = Nothing
End Sub

' RangetoHTML函数保持不变
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = ThisWorkbook.Path & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

With TempWB.PublishObjects.Add( _
    SourceType:=xlSourceRange, _
    Filename:=TempFile, _
    Sheet:=TempWB.Sheets(1).Name, _
    Source:=TempWB.Sheets(1).UsedRange.Address, _
    HtmlType:=xlHtmlStatic)
    .Publish (True)
End With

Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")

TempWB.Close savechanges:=False
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

修改后的主执行宏

Option Explicit

Sub SendNewMails()
    Dim clE As Range
    Dim shtA As Worksheet
    Dim OutApp As Object
    Dim SubjectString As String

    Set shtA = Sheets("MAKRO")
    SubjectString = Range("Mail_Subject")
    
    ' 仅创建一次Outlook实例
    Set OutApp = CreateObject("Outlook.Application")
    
    For Each clE In Range("Table1[mail]")
        Dim ToString As String
        ToString = clE.Value
        Dim BodyString As String
        BodyString = shtA.Cells(clE.Row, "J")
        Mail_Workbook OutApp, ToString, SubjectString, BodyString
    Next
    
    Set OutApp = Nothing
End Sub

方案2：分批生成邮件 #

设置每生成固定数量的邮件后暂停，等待用户处理现有窗口再继续：

Option Explicit

Sub SendNewMails()
    Dim clE As Range
    Dim shtA As Worksheet
    Dim OutApp As Object
    Dim SubjectString As String
    Dim counter As Integer
    Dim batchSize As Integer
    
    batchSize = 20 ' 每批生成20封邮件
    counter = 0
    
    Set shtA = Sheets("MAKRO")
    SubjectString = Range("Mail_Subject")
    Set OutApp = CreateObject("Outlook.Application")
    
    For Each clE In Range("Table1[mail]")
        counter = counter + 1
        Dim ToString As String
        ToString = clE.Value
        Dim BodyString As String
        BodyString = shtA.Cells(clE.Row, "J")
        Mail_Workbook OutApp, ToString, SubjectString, BodyString
        
        ' 达到批次数量时提示用户处理
        If counter Mod batchSize = 0 Then
            MsgBox "已生成" & counter & "封邮件，请处理后点击确定继续", vbInformation
        End If
    Next
    
    MsgBox "邮件生成完成，共生成" & counter & "封邮件", vbInformation
    Set OutApp = Nothing
End Sub

方案3：先存草稿再统一检查 #

如果不需要即时打开窗口，可将邮件保存到草稿箱，之后在Outlook中批量检查：
修改Mail_Workbook中的.Display为.Save即可：

' 替换原代码中的.Display
.Save

内容的提问来源于stack exchange，提问作者cosiek