vba 使用邮件合并添加抄送和密送

Add CC and BCC with Mail Merge

提问by Maria Fernanda Espinosa

I am trying to add the cc function to a mail merge. In other words, I not only need to personalize the emails to different email addresses. I would also like each email to be include a CC that shows the same email to multiple recipients.

我正在尝试将 cc 函数添加到邮件合并中。换句话说，我不仅需要将电子邮件个性化到不同的电子邮件地址。我还希望每封电子邮件都包含一个抄送，向多个收件人显示相同的电子邮件。

Example: the same email to John Doe can be automatically cc'd to his manager.

示例：发送给 John Doe 的同一封电子邮件可以自动抄送给他的经理。

I tried adding , and ; as well as merging two cells in excel with the addresses and got errors.

我尝试添加 , 和 ; 以及将excel中的两个单元格与地址合并并出错。

I also read an article that shows how to send attachments to multiple recipients and modified it to make the cc work. See article below.

我还阅读了一篇文章，该文章展示了如何将附件发送给多个收件人并对其进行了修改以使抄送工作。请参阅下面的文章。

http://word.mvps.org/FAQs/MailMerge/MergeWithAttachments.htm

http://word.mvps.org/FAQs/MailMerge/MergeWithAttachments.htm

The code I came up with is shown below. It allowed me to cc, however, it only goes through with the first row of emails and none of the rest. Also the body of the message does not show up.

我想出的代码如下所示。它允许我抄送，但是，它只通过第一行电子邮件而没有其他电子邮件。消息的正文也不显示。

Any pointers?

任何指针？

Sub emailmergewithattachments()

'Global Config Variables
    Dim saveSent As Boolean, displayMsg As Boolean, attachBCC As Boolean
    saveSent = True 'Saves a copy of the messages into the senders "sent" box
    displayMsg = False 'Pulls up a copy of all messages to be sent - WARNING, do not use on long lists!
    attachBCC = False 'Adds third column data into the BCC field. Will throw error if this column does not exist.

    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 oOutlookApp As Application
    Dim oItem As Outlook.MailItem
'Dim oItem As MailMessage
    Dim mysubject As String, message As String, title As String
    Set Source = ActiveDocument
' Check if Outlook is running.  If it is not, start Outlook
    On Error Resume Next
    Set oOutlookApp = GetObject(, "Outlook.Application")
    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.
    For j = 0 To Source.Sections.Count - 1
        Set oItem = oOutlookApp.CreateItem(olMailItem)

' modification begins here

        With oItem
            .Subject = mysubject
.body = ActiveDocument.Content
            .Body = Source.Sections(j).Range.Text

            Set Datarange = Maillist.Tables(1).Cell(j, 1).Range
            Datarange.End = Datarange.End - 1
            .To = Datarange

            Set Datarange = Maillist.Tables(1).Cell(j, 2).Range
            Datarange.End = Datarange.End - 1
            .CC = Datarange

            If attachBCC Then
                Set Datarange = Maillist.Tables(1).Cell(j, 3).Range
                Datarange.End = Datarange.End - 1
                .CC = Datarange
            End If

            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

                If displayMsg Then
                    .Display
                End If
                If saveSent Then
                    .SaveSentMessageFolder = mpf
                End If

                .Send
            End With
            Set oItem = Nothing
            Next j
            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

回答by RowanC

Firstly, I'd separate out your email code, and the code for iterating your spreadsheet. Here's my take on the email code for outlook (be sure to setup references->outlook object model, as I've used early biding)

首先，我会将您的电子邮件代码和用于迭代电子表格的代码分开。这是我对 Outlook 电子邮件代码的看法（请务必设置引用-> Outlook 对象模型，因为我使用了早期投标）

Sub SendMessage(recipients As Variant, subject As String, body As String, Optional ccRecips As Variant, Optional bccRecips As Variant, Optional DisplayMsg As Boolean, Optional AttachmentPath As Variant)
          Dim objOutlook As Outlook.Application
          Dim objOutlookMsg As Outlook.MailItem
          Dim objOutlookRecip As Outlook.Recipient
          Dim objOutlookAttach As Outlook.Attachment
          Dim item As Variant
          ' Create the Outlook session.
          On Error Resume Next
             Set objOutlook = GetObject(, "Outlook.Application")
             If Err <> 0 Then
                 Set objOutlook = CreateObject("Outlook.Application")
             End If
          On error goto 0

          ' Create the message.
          Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

          With objOutlookMsg
              ' Add the To recipient(s) to the message.
              For Each item In recipients
                Set objOutlookRecip = .recipients.Add(item)
                objOutlookRecip.Type = olTo
              Next
              ' Add the CC recipient(s) to the message.
              If Not IsMissing(ccRecips) Then
                For Each item In ccRecips
                  Set objOutlookRecip = .recipients.Add(item)
                  objOutlookRecip.Type = olTo
                Next
              End If
             ' Add the BCC recipient(s) to the message.
              If Not IsMissing(bccRecips) Then
                For Each item In bccRecips
                  Set objOutlookRecip = .recipients.Add(item)
                  objOutlookRecip.Type = olBCC
                Next
              End If
             ' Set the Subject, Body, and Importance of the message.
             .subject = subject
             .body = body 'this can also be HTML, which is great if you want to improve the look of your email, but you must change the format to match

             ' Add attachments to the message.
             If Not IsMissing(AttachmentPath) Then
                 Set objOutlookAttach = .Attachments.Add(AttachmentPath)
             End If

             ' Resolve each Recipient's name -this may not be necessary if you have fully qualified addresses.
             For Each objOutlookRecip In .recipients
                 objOutlookRecip.Resolve
             Next

             ' Should we display the message before sending?
             If DisplayMsg Then
                 .Display
             Else
                 .Save
                 .Send
             End If
          End With
          Set objOutlook = Nothing
 End Sub

A note: Recipients, CC's and BCC's are expecting arrays of values, which may also only be a single value. This means we can probably send it a raw range, or we can load that range into an array, and send it that.

注意：收件人、抄送和密件抄送需要值的数组，这些值也可能只是一个值。这意味着我们可以向它发送一个原始范围，或者我们可以将该范围加载到一个数组中，然后发送它。

Now that we've built a nice generic way of sending emails (which is handily re-usable) we can think about the logic of the thing we've got sending emails. I've built the below email, but I havn't spent a lot of time on it (or tested it, as it's quite specific to your tables). I believe it should be very close though.

现在我们已经建立了一个很好的通用发送电子邮件的方式（它可以方便地重复使用），我们可以考虑我们发送电子邮件的逻辑。我已经建立了下面的电子邮件，但我没有花很多时间在上面（或测试它，因为它非常特定于您的表）。我相信它应该非常接近。

On writing this, I think you'll see the main trick for editing your own however - the key was splitting the text in the CC cell, by the delimiter you are using. This creates an array of addresses, which you can then iterate over and add to the recipient, CC or BCC.

在写这篇文章时，我想你会看到编辑自己的主要技巧 - 关键是通过你正在使用的分隔符拆分 CC 单元格中的文本。这将创建一个地址数组，然后您可以遍历这些地址并将其添加到收件人、抄送或密件抄送。

Sub DocumentSuperMailSenderMagicHopefully()
Dim Source As Document, Maillist As Document, TempDoc As Document
Dim mysubject As String, message As String, title As String
Dim datarange As Range 'word range I'm guessing...
Dim body As String
Dim recips As Variant
Dim ccs As Variant
Dim bccs As Variant
Dim j As Integer
Dim attachs As Variant
Set Source = ActiveDocument
With Dialogs(wdDialogFileOpen)  'Hey, I'm not sure what this does, but I'm leaving it there.
    .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.

'IMPORTANT: This assumes your email addresses in the table are separated with commas!
For j = 0 To Source.Sections.Count - 1
    body = Source.Sections(j).Range.Text
    'get to recipients from tables col 1 (I'd prefer this in excel, it's tables are much better!)
    Set datarange = Maillist.tables(1).Cell(j, 1).Range
    datarange.End = datarange.End - 1
    recips = Split(datarange.Text)
    'CC's
    Set datarange = Maillist.tables(1).Cell(j, 2).Range
    datarange.End = datarange.End - 1
    ccs = Split(datarange.Text)
    'BCC's
    Set datarange = Maillist.tables(1).Cell(j, 3).Range
    datarange.End = datarange.End - 1
    bccs = Split(datarange.Text)

    'Attachments array, should be paths, handled by the mail app, in an array
    ReDim attachs(Maillist.tables(1).Columns.Count - 3) 'minus 2 because you start i at 2 and minus one more for option base 0
    For i = 2 To Maillist.tables(1).Columns.Count
        Set datarange = Maillist.tables(1).Cell(j, i).Range
        datarange.End = datarange.End - 1
        attachs(i) = Trim(datarange.Text)
    Next i

   'call the mail sender
   SendMessage recips, subject, body, ccs, bccs, False, attachs
   Next j
Maillist.Close wdDoNotSaveChanges
MsgBox Source.Sections.Count - 1 & " messages have been sent."
End Sub

This has turned into a longer post than I was expecting. Good luck with the project!

这变成了比我预期更长的帖子。祝项目顺利！

回答by Emilien

I had the same issue not being able to CC using the mail merge from Excel, and also wanted to use the BCC field and have subjects that are variable for each email), and didn't find a good tool either, so I built my own tool and have just released it for others to benefit from. Let me know if that solves your issue too: http://emailmerge.cc/

我遇到了同样的问题，无法使用 Excel 中的邮件合并进行抄送，并且还想使用 BCC 字段，并且每个电子邮件的主题都是可变的），并且也没有找到一个好的工具，所以我构建了我的自己的工具，并刚刚发布它供其他人受益。让我知道这是否也解决了您的问题：http: //emailmerge.cc/

It doesn't handle attachments yet, but I've planned to add that soon.

它尚未处理附件，但我计划尽快添加。

EDIT: EmailMerge.cc now also handles attachments, high/low priority, read receipts [unfortunately some people still want those ;) ]

编辑：EmailMerge.cc 现在还处理附件、高/低优先级、已读回执 [不幸的是，有些人仍然想要那些 ;)]

I hope this is useful to you, my intent is not to to spam SO ;)

我希望这对您有用，我的目的不是发送垃圾邮件；)