标签: 转载 | |
应张老师的需求,修改制作了一个可以批量发送带附件的电子邮件VBA。
目的:给N多人发送电子邮件,而不是抄送模式,并带有对方的称谓。
实现:
用到Word的邮件合并功能,以及调用Outlook发送邮件。不过VBA我不太懂,只能用现有的改,有点繁琐。
<wbr></wbr>
步骤:
1. Word建立一个表,第一列为表头,下面为每个人的记录,从第四列开始为附件列,需要加几个附件,就添加几个列,可以留空,像第五列一样:
Name | Title | | Attachment |
Xiao Ma | PhD. | e:test.txt | |
Copper | Dr. | e:test2.txt | |
Marry | Miss. | e:test.txt | |
Lisa | Miss | <wbr></wbr> |
2. 保存该word文件。
3. 新建一个Word文档,我用的是word2010版本,选择邮件选项卡。
4. 选择收件人,使用现有列表,打开之前编辑的word文件
5. 使用插入合并域功能,编辑邮件正文:
<wbr><wbr><wbr>如:</wbr></wbr></wbr>
<wbr><wbr><wbr>Dear <<Title>><<Name>></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 <> 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>someone@examplemail.com")语句删除
<wbr><wbr><wbr>Set oAccount = oOutlookApp.Session.Accounts.Item("</wbr></wbr></wbr>someone@examplemail.com")
<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 "共发送了 " & lRecordCount - 1 & " 封邮件。"</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