合并带附件的电子邮件

公司有时候需要给客户发批量送带有附件的电子邮件，这些电子邮件有时候是相同的文件，有时候是根据每个客户的具体情况而发送并不相同的邮件附件。在Outlook中邮件合并功能只适用于不加带附件的电子邮件，而要向合并中的邮件中加入附件使用默认的邮件合并功能显然是不能完成的任务。我在网上查了许多资料后，通过编写VBA宏程序得到了一个的解决方案。 这个宏程序将使用97以上版本的Outlook合并带有附件的电子邮件。同时Outlook并不要求作为系统默认的电子邮件程序，但是必须随Office软件一起安装系统中。程序可以将多个不同的或者相同的附件加入你发给所有收件人的每个电子邮件。 准备工作： 运行这个宏程序需要引用Microsoft Office Outlook Object Library。你可以在Visual Basic编辑器（通过Alt+F11调出）中在“工具”菜单中选择“引用”，在随后弹出的对话框中选择Microsoft Office Outlook ##.0 Object Library（其中##代表Outlook的版本）。 除此之外，运行这个宏程序合并每一封电子邮件时都会弹出如下图的警告对话框：

你可以使用“Express ClickYes”来自动处理这个对话框。你可以从如下网址下载到这个软件： http://www.contextmagic.com/express-clickyes/ Express ClickYes是一款运行在任务栏上的小程序，它在Outlook弹出上面的对话框时可以给运行中的程序发送单击按钮的命令。 制作邮件列表： 你首先建立一个包含下列格式表格的Word文档：

<<电子邮件地址>>

<<附件1>>

<<附件2>>

其中电子邮件地址可以是Outlook联系人里显示联系人姓名，附件数目还是可以增加的，并不限制为二个。附件格式为：“驱动器名称:\路径名\文件名” 如果要发相同的附件只需把<<附件1>>中设置为相同内容即可，例如：

<<电子邮件地址>>

D:\Documents\JulyReport.doc

你也可以在此基础上根据每个收件人的不同加入不同的附件，例如：

<<电子邮件地址>>

D:\Documents\JulyReport.doc

<<附件2>>

你也可以根据需要给每个收件人并不相同的附件，例如：

bill.smith@nowhere.com	D:\mugshots\billsmith.jpg	D:\resumes\billsmith.doc
joe.blow@nowhere.com	D:\mugshots\jowblow.jpg	D:\resumes\joeblow.doc

或者给每个收件人所发送的附件都是相同的，格式如下：

bill.smith@nowhere.com	D:\Documents\JulyReport.doc
joe.blow@nowhere.com	D:\Documents\JulyReport.doc

核对无误后保存此邮件列表文件。 建立包含宏程序的主文档： 再新建立一个Word文档，把所需要发送的邮件正文写进入，然后同时按下Alt＋F11调出宏编辑器。然后把下面的代码复制粘贴到里面保存。依次打开“工具”＝》“宏”＝》“宏”，在打开的宏对话框选择“EmailMergeWithAttachments”单击运行。运行时程序会首先打开一人“打开”对话框让你打开上面保存的包含有收件人和附件的Word文件，然后会让你输入邮件主题，最后开始自动合并电子邮件了。

提示：运行前需要把“工具”＝》“宏”＝》“安全性”中的安全性设置为“中”或者“低”要不然出于安全性考虑程序会阻止宏运行。 代码如下： Sub EmailMergeWithAttachments () Dim Source As Document, Maillist As Document Dim Datarange As Range Dim Counter As Integer, i As Integer Dim bStarted As Boolean Dim oOutlookApp As Outlook.Application Dim oItem As Outlook.MailItem Dim mysubject As String, message As String, title As String Set Source = ActiveDocument '检测Outlook是否正在运行。如果没有运行则打开Outlook On Error Resume Next Set oOutlookApp = GetObject(, "Outlook.Application") If Err <> 0 Then Set oOutlookApp = CreateObject("Outlook.Application") bStarted = True End If '开打需要合并的邮件列表Word文档。 With Dialogs(wdDialogFileOpen) .Show End With Set Maillist = ActiveDocument ' 显示输入对话框，输入需要加入到邮件中的邮件主题。 message = "为要合并发送的邮件输入一个邮件主题。" ' 设置提示符。 title = " 输入邮件主题" ' 设置标题栏。 '显示提示符和标题栏 mysubject = InputBox(message, title) ' 根据邮件列表Word文档处理需要插入到邮件中的附件。 Counter = 1 While Counter <= Maillist.Tables(1).Rows.Count Source.Sections.First.Range.Cut Documents.Add Selection.Paste Set oItem = oOutlookApp.CreateItem(olMailItem) With oItem .Subject = mysubject .Body = ActiveDocument.Content Set Datarange = Maillist.Tables(1).Cell(Counter, 1).Range Datarange.End = Datarange.End - 1 .To = Datarange For i = 2 To Maillist.Tables(1).Columns.Count Set Datarange = Maillist.Tables(1).Cell(Counter, i).Range Datarange.End = Datarange.End - 1 .Attachments.Add Trim(Datarange.Text), olByValue, 1 Next i .Send End With Set oItem = Nothing ActiveDocument.Close wdDoNotSaveChanges Counter = Counter + 1 Wend ' Outlook如果其是由宏操作打开的，则关闭Outlook。 If bStarted Then oOutlookApp.Quit End If '释放系统资源。 Set oOutlookApp = Nothing Source.Close wdDoNotSaveChanges Maillist.Close wdDoNotSaveChanges End Sub