进行带附件的邮件合并

发送带附件的邮件,这是日常工作;使用word进行邮件合并面向不同的收件人发送不同的邮件,这是office高效应用的典型案例;如果你经常使用邮件合并,那么肯定也和我一样苦恼过如何面向不同的收件人发送不同的邮件并携带不同的附件。

好在已经有人为同样的问题钻研过了:在邮件合并中添加附件; 在邮件合并中添加附件,并通过html格式发送邮件

下面是一个简单的演示

  • 1按邮件合并的流程准备需要引用的列表,一般用excel格式分行键入所需信息,这里用表格做简单的示意
姓名 工号 邮箱 文件地址1 文件地址2
张三 11232 test@test.com c:\详单.csv c:\张三注意事项.doc

这里还有个小tips,excel是有字符串合并函数的,这意味着“文件地址2”不用手动输入,只要使用CONCATENATE()函数构造即可

  • 2准备待发送列表

新建一个word文档,使用邮件合并功能构造待发送列表,插入一个一行N列的表格,N由你需要发送的文件个数决定,邮件合并选择刚刚我们编辑的excel列表,检查无误后生成待发送列表文件并保存地址.docx,注意不要发送。示意如下

test@test.com c:\详单.csv c:\张三注意事项.doc
test1@test.com c:\详单.csv c:\李四注意事项.doc
  • 3准备待发送的邮件正文

新建一个word文档,使用邮件合并功能构造待发送的正文,当然要在适当的位置插入合并域,编辑时可以使用格式或图片等。检查无误后生成合并后的邮件正文,注意不要发送,是生成文档。

  • 4准备VBA实现带附件的邮件合并

这时我们已经有合并好的正文+合并好的地址两个文件,合并好的正文应该是每篇正文一节的一个word文档,合并好的地址应该是N行M列的表格,第一列是收件人地址,第二…第N列是待发送附件的地址。

在待发送正文页面按Alt+F11打开VBA管理器

点击工具-引用-找到Microsoft Outlook 15.0 Object Library的字样,勾选点确认,要注意你的office不一定是15,也可能是14、12、11、10等。

点击插入-模块;并在模块内粘贴如下代码


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Sub eMailMergeWithAttachments()
Dim docSource As Document, docMaillist As Document, docTempDoc As Document
Dim rngDatarange As Range
Dim i As Long, j As Long
Dim lSectionsCount 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 As String
'将当前文档设置为源文档(主文档)
Set docSource = 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 docMaillist = ActiveDocument
'设置发送邮件的账户(账户必须已经在Outlook中设置好了)
'注意:如果你的Outlook版本低于2007,使用设置发送邮件的账户可能会导致错误,
'建议将下面的Set oAccount = oOutlookApp.Session.Accounts.Item("someone@examplemail.com")语句删除
Set oAccount = oOutlookApp.Session.Accounts.Item("ab046491moumingdong@ab-insurance.com")
'显示一个输入框,询问并让用户输入邮件主题
sMessage = "请为要发送的邮件输入邮件主题。"
sTitle = "默认群发邮件title"
sMySubject = InputBox(sMessage, sTitle)
'循环查找源文档中所有的节(每一节为一封邮件内容),以及循环查找邮件列表文档中所有的客户信息,
'以便用于插入到生成的邮件中
lSectionsCount = docSource.Sections.Count - 1
'当源文档中的节数仅有1时,lSectionsCount=0,将导致程序无法正常运行。
'为了保证当源文档只有1节时程序能正常运行,必须使lSectionsCount至少等于1
If lSectionsCount = 0 Then lSectionsCount = 1
For j = 1 To lSectionsCount
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
'注意:如果你的Outlook版本低于2007,使用设置发送邮件的账户可能会导致错误,
'建议将下面的.SendUsingAccount = oAccount语句删除
.SendUsingAccount = oAccount
.Subject = sMySubject
docSource.Sections(j).Range.Copy
.Display
Set docTempDoc = oOutlookApp.ActiveInspector.WordEditor
docTempDoc.Range.Paste
Set rngDatarange = docMaillist.Tables(1).Cell(j, 1).Range
rngDatarange.End = rngDatarange.End - 1
.To = rngDatarange
For i = 2 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
.Display
End With
Set oItem = Nothing
Next j
docMaillist.Close wdDoNotSaveChanges
'如果Outlook是由该宏打开的,则关闭Outlook
If bStarted Then
oOutlookApp.Quit
End If
MsgBox "共发送了 " & lSectionsCount & " 封邮件。"
'清空Outlook实例
Set oOutlookApp = Nothing
End Sub

检查无误后戳F5运行,输入标题点击确定后程序会自动进行邮件的发送工作

Tips:

代码中的.Display改成.Send可以直接发送,但建议先测试好再批量发

刚开始测试的时候地址不要太多,先发几条试试

Enjoy~

感谢siliconxu贡献的代码

 

本文遵守署名-非营利性使用-相同方式共享协议,转载请保留本段:冰丝带雨 » 进行带附件的邮件合并

赞 (0)