使用郵件合併添加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;）