Mailmerge 宏在创建 200 封电子邮件后生成空电子邮件

Question

我已经使用这个宏好几天了，当我认为它运行良好时，我发现它仅适用于前 200 封电子邮件。之后，它会创建具有正确收件人和主题的电子邮件，但没有文本和附件。在测试了不同的场景之后，似乎（某种）Outlook 内存被填满了，但我不知道是什么以及如何清除它（我添加了 oItem 和 oOutlookApp = 没有成功）。我可以让它工作的唯一方法是如果我关闭 Outlook 并使用 200 和以下电子邮件再次运行宏。 有任何想法吗？ 谢谢

编辑： 1- 我还尝试使用接受的答案overhere 在循环结束时清除剪贴板，唉，没有结果。

2- 我发现这个answer 似乎与我的问题有关。但是有两个主要区别：我的宏从 Word 运行到 Outlook（而不是 Outlook 到 Excel）并且我没有收到错误消息；超过 #200 的电子邮件只会被创建为空。所以我不知道这里是否/如何提供帮助。

3- 按照 niton 的说明，现在有一条错误消息。进步我猜...

突出显示的行是

.Attachments.Add Trim(Datarange.Text), olByValue, 1 

它会在第 200 封电子邮件中这样做。

' MailMerge Macro
'
'
Sub MergeWithAttachments()
Dim Source As Document, Maillist As Document, TempDoc As Document
Dim Datarange As Range
Dim i As Long, j As Long
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim mysubject As String, message As String, title As String
Dim mailWord As Object
Dim oData As New DataObject


    Set Source = ActiveDocument
    ' Check if Outlook is running.  If it is not, start Outlook
    On Error Resume Next
    Set oOutlookApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If Err <> 0 Then
        Set oOutlookApp = CreateObject("Outlook.Application")
        bStarted = True
    End If
' Open the catalog mailmerge document
    With Dialogs(wdDialogFileOpen)
        .Show
    End With
    Set Maillist = ActiveDocument
    ' Show an input box asking the user for the subject to be inserted into the email messages
    message = "Enter the subject to be used for each email message."    ' Set prompt.
    title = "Email Subject Input"    ' Set title.
    ' Display message, title
    mysubject = InputBox(message, title)
' Iterate through the Sections of the Source document and the rows of the catalog mailmerge document,
' extracting the information to be included in each email.
If MsgBox("Are you adding cc email recipients?", vbYesNo, "CC email") = vbYes Then
    If MsgBox("Are your cc email recipients in the second column from the left?", vbYesNo, "CC in second column") = vbYes Then
        GoTo Add_cc
        Else:
        If MsgBox("Cc email recipients need to be in the second column. Please rework your directory accordingly.", vbOKOnly, "Cancelling Mail Merge") = vbOK Then
        Exit Sub
        End If
No_cc:

For j = 1 To Source.Sections.Count - 1

    Source.Sections(j).Range.Copy
    Set oItem = oOutlookApp.CreateItem(olMailItem)
    Set mailWord = oItem.GetInspector.WordEditor

    With oItem
        .Subject = mysubject
        mailWord.Range.PasteAndFormat (wdFormatOriginalFormatting)
        Set Datarange = Maillist.Tables(1).Cell(j, 1).Range
        Datarange.End = Datarange.End - 1
        .To = Datarange
        For i = 2 To Maillist.Tables(1).Columns.Count
            Set Datarange = Maillist.Tables(1).Cell(j, i).Range
            Datarange.End = Datarange.End - 1
            .Attachments.Add Trim(Datarange.Text), olByValue, 1
        Next i
        .Send
    End With
    Set oItem = Nothing
Next j

GoTo Merge_finished

Add_cc:
For j = 1 To Source.Sections.Count - 1

    Set oItem = oOutlookApp.CreateItem(olMailItem)

    With oItem
        .Subject = mysubject
        Set Datarange = Maillist.Tables(1).Cell(j, 1).Range
        Datarange.End = Datarange.End - 1
        .To = Datarange
        'code for adding cc emails. Currenlty set to read column 2 as cc emails
        Set Datarange = Maillist.Tables(1).Cell(j, 2).Range
        Datarange.End = Datarange.End - 1
        .CC = Datarange.Text
        Source.Sections(j).Range.Copy
        Set mailWord = oItem.GetInspector.WordEditor
        mailWord.Range.PasteAndFormat (wdFormatOriginalFormatting)

        For i = 2 To Maillist.Tables(1).Columns.Count
            Set Datarange = Maillist.Tables(1).Cell(j, i).Range
            Datarange.End = Datarange.End - 1
            .Attachments.Add Trim(Datarange.Text), olByValue, 1
        Next i
        .Send
        End With
    Set oItem = Nothing

Next j

Merge_finished:
End If
Else: GoTo No_cc
End If

Maillist.Close wdDoNotSaveChanges
'  Close Outlook if it was started by this macro.
If bStarted Then
    oOutlookApp.Quit
End If
MsgBox Source.Sections.Count - 1 & " messages have been sent."
'Clean up
Set oOutlookApp = Nothing

End Sub

Answer 1

您可能会遇到这种情况。 Outlook macro runs through 250 iterations before failing with error

https://support.microsoft.com/en-us/kb/830836

“出现此问题的原因是客户端可以打开的项目数量受到限制。默认情况下，此限制设置为附件 100 和消息 250。”

您的限制可以设置为 200。如果您无法解决此问题，如果是原因，请尝试更改您的代码。标记已处理的项目或移动它们，从 200 开始向下计数循环。处理 200 个项目后关闭 Outlook。一次重新打开并处理剩余的 200 个。