使用邮件合并添加CC和BCC

Question

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

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

我试过添加，并;以及将Excel中的两个单元格与地址合并并出错。

我还阅读了一篇文章，介绍了如何将附件发送给多个收件人，并对其进行修改以使cc能够正常工作。见下面的文章。

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

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

任何指针？

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对象模型，我用早招标）

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 

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

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

在写这篇文章时，我想你会看到编辑自己的主要技巧 - 但关键在于将CC文本中的文本按照您正在使用的分隔符进行分割。这将创建一组地址，然后您可以迭代并添加到收件人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

我有同样的问题，无法使用从Excel的邮件合并CC，也想使用密件抄送字段和每个电子邮件变量的主题），并没有找到一个好的工具，所以我建立了我自己的工具，并且刚刚发布它让其他人受益。让我知道如果这也解决了你的问题：http://emailmerge.cc/

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

编辑：EmailMerge.cc现在还处理附件，高/低优先级，已读回执[不幸的是有些人还是希望那些;）]

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