通过宏（vba）在邮件合并中添加附件

[转载]Word邮件合并批量发送带附件的邮件

(2012-11-28 14:53:22)

转载▼

标签： 转载

你好。非常有帮助。但是有一点，发出去的邮件正文的格式是丢失的。任何字体等信息都没有了。是否有办法可以保证发出的邮件正文的格式不丢失呢？

原文地址：Word邮件合并批量发送带附件的邮件作者：天乐树

应张老师的需求，修改制作了一个可以批量发送带附件的电子邮件VBA。

目的：给N多人发送电子邮件，而不是抄送模式，并带有对方的称谓。

实现：

用到Word的邮件合并功能，以及调用Outlook发送邮件。不过VBA我不太懂，只能用现有的改，有点繁琐。

<wbr></wbr>

步骤：

1. Word建立一个表，第一列为表头，下面为每个人的记录，从第四列开始为附件列，需要加几个附件，就添加几个列，可以留空，像第五列一样：

Name	Title	Email	Attachment
Xiao Ma	PhD.	[e-mail]	e:test.txt
Copper	Dr.	[e-mail]	e:test2.txt
Marry	Miss.	[e-mail]	e:test.txt
Lisa	Miss	[e-mail]	<wbr></wbr>

2. 保存该word文件。

3. 新建一个Word文档，我用的是word2010版本，选择邮件选项卡。

4. 选择收件人，使用现有列表，打开之前编辑的word文件
5. 使用插入合并域功能，编辑邮件正文：
<wbr><wbr><wbr>如：</wbr></wbr></wbr>

<wbr><wbr><wbr>Dear &lt;&lt;Title&gt;&gt;&lt;&lt;Name&gt;&gt;</wbr></wbr></wbr>

<wbr><wbr><wbr>I’m mxio. Good 2 c u at 9t.</wbr></wbr></wbr>

<wbr><wbr><wbr>Good Luck!</wbr></wbr></wbr>

<wbr><wbr><wbr>mxio<br><wbr><wbr><wbr>2012.11.13<br> 6. 点击预览结果，更新域<br> 7. 启动编辑宏功能，键盘按ALT+F11<br> 8. 工具引用添加 Microsoft Outlook 14.0 Object Library<br> 9. 新建模块添加如下代码：</wbr></wbr></wbr></wbr></wbr></wbr>

Sub eMailMergeWithAttachment<wbr>s()</wbr>

<wbr><wbr><wbr>Dim docSource As Document, docMaillist As Document</wbr></wbr></wbr>

<wbr><wbr><wbr>Dim rngDatarange As Range</wbr></wbr></wbr>

<wbr><wbr><wbr>Dim i As Long, j As Long</wbr></wbr></wbr>

<wbr><wbr><wbr>Dim lRecordCount As Long</wbr></wbr></wbr>

<wbr><wbr><wbr>Dim bStarted As Boolean</wbr></wbr></wbr>

<wbr><wbr><wbr>Dim oOutlookApp As Outlook.Application</wbr></wbr></wbr>

<wbr><wbr><wbr>Dim oItem As Outlook.MailItem</wbr></wbr></wbr>

<wbr><wbr><wbr>Dim oAccount As Outlook.Account</wbr></wbr></wbr>

<wbr><wbr><wbr>Dim sMySubject As String, sMessage As String, sTitle As String</wbr></wbr></wbr>

<wbr><wbr><wbr>'将当前文档设置为源文档（主文档）</wbr></wbr></wbr>

<wbr><wbr><wbr>Set docSource = ActiveDocument<br><wbr><wbr><wbr><br><wbr><wbr><wbr>'检查Outlook是不是打开了。如果未打开的话，就打开新的Outlook</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr>On Error Resume Next</wbr></wbr></wbr>

<wbr><wbr><wbr>Set oOutlookApp = GetObject(, "Outlook.Application")</wbr></wbr></wbr>

<wbr><wbr><wbr>If Err &lt;&gt; 0 Then</wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr>Set oOutlookApp = CreateObject("Outlook.Application")</wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr>bStarted = True</wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr>End If</wbr></wbr></wbr>

<wbr><wbr><wbr>'打开保存有客人的邮件地址和需要发送的附件的路径的word文档。</wbr></wbr></wbr>

<wbr><wbr><wbr>With Dialogs(wdDialogFileOpen)</wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr>.Show</wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr>End With</wbr></wbr></wbr>

<wbr><wbr><wbr>'将该文档设置为客户邮件（附件）列表文档</wbr></wbr></wbr>

<wbr><wbr><wbr>Set docMaillist = ActiveDocument</wbr></wbr></wbr>

<wbr><wbr><wbr>'设置发送邮件的账户（账户必须已经在Outlook中设置好了）</wbr></wbr></wbr>

<wbr><wbr><wbr>'注意：如果你的Outlook版本低于2007，使用设置发送邮件的账户可能会导致错误，</wbr></wbr></wbr>

<wbr><wbr><wbr>'建议将下面的Set oAccount = oOutlookApp.Session.Accounts.Item("</wbr></wbr></wbr>[e-mail]")语句删除

<wbr><wbr><wbr>Set oAccount = oOutlookApp.Session.Accounts.Item("</wbr></wbr></wbr>[e-mail]")

<wbr><wbr><wbr>'显示一个输入框，询问并让用户输入邮件主题</wbr></wbr></wbr>

<wbr><wbr><wbr>sMessage = "请为要发送的邮件输入邮件主题。"</wbr></wbr></wbr>

<wbr><wbr><wbr>sTitle = "输入邮件主题"</wbr></wbr></wbr>

<wbr><wbr><wbr>sMySubject = InputBox(sMessage, sTitle)</wbr></wbr></wbr>

<wbr><wbr><wbr>'循环查找源文档中所有的节（每一节为一封邮件内容），以及循环查找邮件列表文档中所有的客户信息，</wbr></wbr></wbr>

<wbr><wbr><wbr>'以便用于插入到生成的邮件中</wbr></wbr></wbr>

<wbr><wbr><wbr>'获取需要发送的邮件数，并将当前节置为第一条记录<br><wbr><wbr><wbr><br><wbr><wbr><wbr>lRecordCount = docMaillist.Tables(1).Rows.Count<br><wbr><wbr><wbr><br><wbr><wbr><wbr>docSource.MailMerge.DataSource.ActiveRecord = wdFirstRecord</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr>'第一列为表头，需跳过<br><wbr><wbr><wbr><br><wbr><wbr><wbr>For j = 2 To lRecordCount<br><wbr><wbr><br><wbr><wbr><wbr><wbr><wbr><wbr><wbr>Set oItem = oOutlookApp.CreateItem(olMailItem)</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr>With oItem</wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>'注意：如果你的Outlook版本低于2007，使用设置发送邮件的账户可能会导致错误，</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>'建议将下面的.SendUsingAccount = oAccount语句删除</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>.SendUsingAccount = oAccount</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>.Subject = sMySubject<br><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><br><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>'正文内容，节号1的文字</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>.Body = docSource.Sections(1).Range.Text</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>Set rngDatarange = docMaillist.Tables(1).Cell(j, 3).Range</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>rngDatarange.End = rngDatarange.End - 1</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>.To = rngDatarange</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>For i = 4 To docMaillist.Tables(1).Columns.Count</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>Set rngDatarange = docMaillist.Tables(1).Cell(j, i).Range</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>rngDatarange.End = rngDatarange.End - 1</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>.Attachments.Add Trim(rngDatarange.Text), olByValue, 1</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>Next i</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>.Send</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr>End With</wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr>Set oItem = Nothing<br><wbr><wbr><wbr><br><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr>'Word邮件文档下一节<br><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><wbr><br><wbr><wbr><wbr><wbr><wbr><wbr><wbr>docSource.MailMerge.DataSource.ActiveRecord = wdNextRecord</wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr>Next j</wbr></wbr></wbr>

<wbr><wbr><wbr>docMaillist.Close wdDoNotSaveChanges</wbr></wbr></wbr>

<wbr><wbr><wbr>'如果Outlook是由该宏打开的，则关闭Outlook</wbr></wbr></wbr>

<wbr><wbr><wbr>If bStarted Then</wbr></wbr></wbr>

<wbr><wbr><wbr><wbr><wbr><wbr><wbr>oOutlookApp.Quit</wbr></wbr></wbr></wbr></wbr></wbr></wbr>

<wbr><wbr><wbr>End If</wbr></wbr></wbr>

<wbr><wbr><wbr>MsgBox "共发送了 " &amp; lRecordCount - 1 &amp; " 封邮件。"</wbr></wbr></wbr>

<wbr><wbr><wbr>'清空Outlook实例</wbr></wbr></wbr>

<wbr><wbr><wbr>Set oOutlookApp = Nothing</wbr></wbr></wbr>

End Sub

10. 执行该代码。

mxio
2012.11.13

http://blog.sina.com.cn/s/blog_66e99fd201017zy5.html