通过邮件合并添加抄送和密件抄送 [英] Add CC and BCC with Mail Merge
问题描述
我正在尝试将cc函数添加到邮件合并中。换句话说,我不仅需要将电子邮件个性化到不同的电子邮件地址。我还希望每封电子邮件都包含一个抄送,以便向多个收件人显示同一封电子邮件。
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.
示例:发送给John Doe的同一封电子邮件可以自动抄送给他的经理。
Example: the same email to John Doe can be automatically cc'd to his manager.
我尝试添加和;以及将excel中的两个单元格与地址合并并得到错误。
I tried adding , and ; as well as merging two cells in excel with the addresses and got errors.
我还阅读了一篇文章,该文章显示了如何将附件发送给多个收件人,并对其进行了修改以使抄送工作正常。请参阅下面的文章。
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
我想到的代码如下所示。它允许我抄送,但是,它仅与第一行电子邮件一起处理,其余都没有。邮件的正文也不会显示。
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.
任何指针吗?
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
推荐答案
首先,我将分离出您的电子邮件代码和用于迭代电子表格的代码。
这是我对Outlook的电子邮件代码的看法(请确保设置引用-> outlook对象模型,因为我使用过早期出价)
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)
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.
在撰写本文时,我想您会看到编辑自己的主要技巧-关键是将文本拆分为CC单元格(通过您使用的分隔符)。这将创建一个地址数组,然后您可以对其进行迭代并添加到收件人CC或密件抄送中。
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.
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!
这篇关于通过邮件合并添加抄送和密件抄送的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!