使用邮件合并添加CC和BCC

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

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

我尝试添加，并; 以及在excel中合并两个单元格的地址，并得到错误。

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

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

我想到的代码如下所示。 它允许我cc，但是，它只能通过第一行的电子邮件，其余的都没有。 消息的正文也没有显示出来。

任何指针？

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 

Answer 1

首先，我将分离出您的电子邮件代码，以及迭代电子表格的代码。 这里是我对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 

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

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

在写这篇文章的时候，我想你会看到编辑你自己的主要技巧 – 关键在于将CC文本中的文本分割成你正在使用的分隔符。 这将创build一个地址数组，然后您可以迭代并添加到收件人CC或BCC。

 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 

这已经变成比我预期的更长的职位。 祝你好运！

Answer 2

我有同样的问题不能CC使用从Excel的邮件合并，也想使用密件抄送字段和主题是可变的每封电子邮件），并没有find一个好的工具，所以我build立了我的自己的工具，并刚刚释放它为他人受益。 让我知道，如果这也解决了你的问题： http : //emailmerge.cc/

它不处理附件，但我打算很快添加。

编辑：EmailMerge.cc现在还处理附件，高/低优先级，阅读收据[不幸有人仍然希望那些;]]

我希望这对你有用，我的意图是不要垃圾邮件所以;）