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

Question

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

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

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

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

"This issue occurs because of a limit on the number of items that clients can open. By default, this limit is set to 100 for attachments and 250 for messages."

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

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

Mailmerge macro produces empty email after 200 emails created

vba

ms-word

outlook-2010