Word邮件合并批量发送带附件的邮件 批量下载qq邮件附件

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

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

实现:

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

步骤:

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

Name

Title

Email

Attachment

Xiao Ma

PhD.

someone@some.com

e:test.txt

Copper

Dr.

someone@some.com

e:test2.txt

Marry

Miss.

someone@some.com

e:test.txt

Lisa

Miss

someone@some.com

2. 保存该word文件。

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

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

Dear<<Title>><<Name>>

I’m mxio.Good 2 c u at 9t.

GoodLuck!

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

Sub eMailMergeWithAttachments()

Dim docSource As Document, docMaillist As Document

Dim rngDatarange As Range

Dim i As Long, j As Long

Dim lRecordCount As Long

Dim bStarted As Boolean

Dim oOutlookApp As Outlook.Application

Dim oItem As Outlook.MailItem

Dim oAccount As Outlook.Account

Dim sMySubject As String, sMessage As String, sTitle AsString

'将当前文档设置为源文档(主文档)

Set docSource = ActiveDocument

Word邮件合并批量发送带附件的邮件 批量下载qq邮件附件
'检查Outlook是不是打开了。如果未打开的话,就打开新的Outlook

OnError Resume Next

Set oOutlookApp = GetObject(, "Outlook.Application")

IfErr <> 0 Then

Set oOutlookApp = CreateObject("Outlook.Application")

bStarted = True

End If

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

With Dialogs(wdDialogFileOpen)

.Show

End With

'将该文档设置为客户邮件(附件)列表文档

Set docMaillist = ActiveDocument

'设置发送邮件的账户(账户必须已经在Outlook中设置好了)

'注意:如果你的Outlook版本低于2007,使用设置发送邮件的账户可能会导致错误,

'建议将下面的Set oAccount =oOutlookApp.Session.Accounts.Item("someone@examplemail.com")语句删除

Set oAccount = oOutlookApp.Session.Accounts.Item("someone@examplemail.com")

'显示一个输入框,询问并让用户输入邮件主题

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

sTitle = "输入邮件主题"

sMySubject = InputBox(sMessage, sTitle)

'循环查找源文档中所有的节(每一节为一封邮件内容),以及循环查找邮件列表文档中所有的客户信息,

'以便用于插入到生成的邮件中

'获取需要发送的邮件数,并将当前节置为第一条记录

lRecordCount= docMaillist.Tables(1).Rows.Count

docSource.MailMerge.DataSource.ActiveRecord =wdFirstRecord

'第一列为表头,需跳过

For j = 2 TolRecordCount

Set oItem = oOutlookApp.CreateItem(olMailItem)

With oItem

'注意:如果你的Outlook版本低于2007,使用设置发送邮件的账户可能会导致错误,

'建议将下面的.SendUsingAccount = oAccount语句删除

.SendUsingAccount = oAccount

.Subject = sMySubject

'正文内容,节号1的文字

.Body = docSource.Sections(1).Range.Text

Set rngDatarange = docMaillist.Tables(1).Cell(j,3).Range

rngDatarange.End = rngDatarange.End - 1

.To = rngDatarange

For i = 4 To docMaillist.Tables(1).Columns.Count

Set rngDatarange = docMaillist.Tables(1).Cell(j,i).Range

rngDatarange.End = rngDatarange.End - 1

.Attachments.Add Trim(rngDatarange.Text), olByValue, 1

Next i

.Send

End With

Set oItem = Nothing

'Word邮件文档下一节

docSource.MailMerge.DataSource.ActiveRecord =wdNextRecord

Next j

docMaillist.Close wdDoNotSaveChanges

'如果Outlook是由该宏打开的,则关闭Outlook

IfbStarted Then

oOutlookApp.Quit

End If

MsgBox "共发送了 " & lRecordCount - 1 &" 封邮件。"

'清空Outlook实例

Set oOutlookApp = Nothing

End Sub

10. 执行该代码。


mxio
2012.11.13

________________________________2012.12.6_______________________________

实践证明还是excel的好些,改了改:

Sub sendmail()

Dim xlAppAs New Excel.Application

DimoOutlookApp As Outlook.Application

DimdocSource As Document

Dim colCountAs Long, rowCount As Long

DimlRecordCount As Long, endColNo As Long

Dim bStartedAs Boolean

Dim oItemAs Outlook.MailItem

Dim oAccountAs Outlook.Account

DimsMySubject As String, sMessage As String, sTitle As String,sMailList As String

'将当前文档设置为源文档(主文档)

SetdocSource = ActiveDocument

'获取当前excel工作簿路径

sMailList =docSource.MailMerge.DataSource.Name

'检查Outlook是不是打开了。如果未打开的话,就打开新的Outlook

On ErrorResume Next

SetoOutlookApp = GetObject(, "Outlook.Application")

If Err<> 0 Then

Set oOutlookApp = CreateObject("Outlook.Application")

bStarted = True

End If

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

Dim wb AsExcel.Workbook

Set wb =xlApp.Workbooks.Open(sMailList)

xlApp.Visible = Flase

'设置发送邮件的账户(账户必须已经在Outlook中设置好了)

'注意:如果你的Outlook版本低于2007,使用设置发送邮件的账户可能会导致错误,

'建议将下面的Set oAccount = oOutlookApp.Session.Accounts.Item("someone@examplemail.com")语句删除

SetoAccount = oOutlookApp.Session.Accounts.Item("someone@examplemail.com")

'显示一个输入框,询问并让用户输入邮件主题

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

sTitle ="输入邮件主题"

'sMySubject = InputBox(sMessage, sTitle)

'免打扰模式设置邮件主题

sMySubject ="test"

'循环查找源文档中所有的节(每一节为一封邮件内容),以及循环查找邮件列表文档中所有的客户信息,

'以便用于插入到生成的邮件中

'获取需要发送的邮件数,列数,并将当前节置为第一条记录

lRecordCount= wb.Sheets("Sheet1").Cells(1, 1).CurrentRegion.Rows.Count

endColNo =wb.Sheets("Sheet1").Cells(1, 1).CurrentRegion.Columns.Count

docSource.MailMerge.DataSource.ActiveRecord = wdFirstRecord


'第一列为表头,需跳过

For rowCount= 2 To lRecordCount

Set oItem = oOutlookApp.CreateItem(olMailItem)

With oItem

'注意:如果你的Outlook版本低于2007,使用设置发送邮件的账户可能会导致错误,

'建议将下面的.SendUsingAccount = oAccount语句删除

.SendUsingAccount = oAccount

.Subject = sMySubject

'使用纯文本格式,正文内容,节号1的文字

'.Body = docSource.Sections(1).Range.Text

'正文使用HTML代码格式,可保留排版格式,用论坛上的文本编辑器可轻松获取HTML代码

.HTMLBody = docSource.Sections(1).Range.Text

'如果excel数据结构发生改变,那么请修改此次email地址所在列数,默认为4

.To = wb.Sheets("Sheet1").Cells(rowCount, 4)

'如果excel数据结构发生改变,那么请修改此次附件地址所在列数,默认为5

For colCount = 5 To endColNo

.Attachments.Add Trim(wb.Sheets("Sheet1").Cells(rowCount,colCount))

Next colCount

'发送 or 仅显示 or 保存草稿箱,重要邮件,推荐使用 .Display模式,确认后点击发送即可

.Send

'.Display

'.Save

End With

Set oItem = Nothing

'Word邮件文档下一节

docSource.MailMerge.DataSource.ActiveRecord = wdNextRecord

NextrowCount


xlApp.Quit

'如果Outlook是由该宏打开的,则关闭Outlook

IfbStarted Then

' oOutlookApp.Quit

End If

MsgBox "共发送了" & lRecordCount - 1 & "封邮件。"

'清空Outlook实例

SetoOutlookApp = Nothing

Set xlApp =Nothing

End Sub

  

爱华网本文地址 » http://www.413yy.cn/a/25101010/42718.html

更多阅读

Word 2003文件损坏而无法打开的修复方法 修复损坏的word文档

相信经常用word的朋友都遇到过这种情况:打开之前辛辛苦苦制作的word文档的时候,提示文件损坏无法打开。郁闷的要跳楼。今天就介绍一个方法来修复损坏的word文档,下面是具体的步骤。Word 2003文件损坏而无法打开的修复方法——步骤/方法

Word数学符号和音标符号乱码的解决办法 网站乱码解决办法

Word数学符号和音标符号乱码的解决办法——简介在Word中有时会遇到数学符号或者音标符号无法正常显示的情况,造成这种情况的原因之一是电脑中缺少某种字体,那么我们就可以采取以下方法来解决这个问题。Word数学符号和音标符号乱码的

word转pdf office自带插件完美教程 office2007转pdf插件

word转pdf office自带插件完美教程——简介我们在工作中,很多时候需要遇到把word转换成pdf的格式,当然,对于很多办公室老手都很轻松了,也有很多的转换软件可以帮忙。今天笔者就分享一下,word2007

手工画?怎样用彩色铅笔画一幅带翅膀的心 儿童彩色铅笔画

心形代表爱情,今天小DU教你怎么样用手头的彩色铅笔画一幅飞翔的心。你可以画在贺卡上,特别是情人节贺卡上,即便画的不是很专业,但是你仍然会赢得爱人的喜欢的。看看效果图。手工画?怎样用彩色铅笔画一幅带翅膀的心——工具/原料彩色铅

“word无法启动转换器mswrd632 wpc”的解决方法 word mswrd632.wpc

打开WORD文档时提示“word无法启动转换器mswrd632 wpc”的解决方法因为之前安装的是精简版的office 2003,导致系统找不到这个文件,出现标题上的问题“Word无法启动转换器mswrd632 wpc”,点击确定后虽然可以关闭,但每次打开word 都会再

声明:《Word邮件合并批量发送带附件的邮件 批量下载qq邮件附件》为网友迷人三句诗分享!如侵犯到您的合法权益请联系我们删除