outlook群发带不同附件的邮件

西西果 · 发表于 2015-6-6 16:24

LEASON 发表于 2015-6-3 15:24
我们的疑惑是怎么用，把代码复制到EXCEL里VBA 运行还是在OUTLOOK里操作

哈哈我刚开始也是纠结这个问题问了半天才发现是在excel里然后运行程序就调用outlook了哈哈

爱学习的螺丝 · 发表于 2015-6-7 14:29

真的是不明觉厉啊，VBA太强大了！

LEASON · 发表于 2015-6-12 09:17

闻启学发表于 2015-6-4 22:32
可以啊给我看看先

已搞定，谢谢~~~~~~~~

kong12 · 发表于 2015-7-12 08:39

本帖最后由 kong12 于 2015-7-12 10:23 编辑

wdx223 发表于 2013-8-20 12:41

2楼的代码原文见下

Sub sendemail()
Dim myOlApp As Object
Dim myitem As Object
Dim i As Integer, j As Integer
Dim strg As String
Dim atts As Object
Dim mycc As Object
Dim myfile As String
Set myOlApp = CreateObject("Outlook.Application")
With Sheets("Sheet1")
i = 2
Do While .Cells(i, 2) <> ""
Set myitem = myOlApp.CreateItem(0)
Set atts = myitem.Attachments
myitem.To = .Cells(i, 2) '收件人E-mail
myitem.Subject = .Cells(i, 3) '标题
myitem.Body = .Cells(i, 1) & "，你好！" & vbNewLine & vbNewLine & vbNewLine & .Cells(i, 4) '正文
myfile = Dir(ThisWorkbook.Path & "\*" & .Cells(i, 1) & "*.*")
Do Until myfile = ""
myitem.Attachments.Add ThisWorkbook.Path & "" & myfile, 1
myfile = Dir
Loop
myitem.display '预览，如果想直接发送，把.display改为.send
i = i + 1
strg = ""
Loop
End With
Set myitem = Nothing
End Sub

复制代码

注意：该代码如果对有名字包含的人，比如一个李华一个李华盛这种人名，就会把邮件的附件发重复，李华收到李华和李华盛两个附件。
要把 myfile = Dir(ThisWorkbook.Path & "\*" & .Cells(i, 1) & "*.*") 改成下面的这样才行，
myfile = Dir(ThisWorkbook.Path & "\" & .Cells(i, 2) & ".*")

并且再添加附件时也要加限制，否则如果没有对应的附件就会出错。
要加一个 Do 循环或者一个 If 条件语句，
修改后的代码见下

Sub 全自动发送邮件()
Dim myOlApp As Object
Dim myitem As Object
Dim i As Integer, j As Integer
Dim strg As String
Dim atts As Object
Dim mycc As Object
Dim myfile As String
Set myOlApp = CreateObject("Outlook.Application")
'设置对Sheet1工作表进行操作，可自行修改
With Sheets("Sheet1")
i = 2
Do While .Cells(i, 2) <> ""
'设置调用Outlook来发送邮件
Set myitem = myOlApp.CreateItem(0)
Set atts = myitem.Attachments
'收件人邮箱地址调用了第3列邮箱的数据
myitem.To = .Cells(i, 3)
'邮件标题调用了第2列姓名、第4列标题的数据
myitem.Subject = .Cells(i, 2) & "老师，" & .Cells(i, 4)
'邮件正文，调用第2列即B列的姓名和第4列即D列的邮件标题。
myitem.Body = .Cells(i, 2) & "老师，你好！" & vbNewLine & vbNewLine & vbNewLine & .Cells(i, 4) & "，具体请看附件。" & vbNewLine & vbNewLine & vbNewLine & "祝暑假愉快！"
'在本工作薄的根目录下找出附件，且附件的文件名是收件人的名字
myfile = Dir(ThisWorkbook.Path & "" & .Cells(i, 2) & ".*")
'下面是个添加一个到多个附件的循环。如果没找到对应人名的附件，则发无附件邮件。
Do Until myfile = ""
myitem.Attachments.Add ThisWorkbook.Path & "" & myfile, 1
myfile = Dir
Loop
'下面一句适用于只添加一个附件用的，可以替换上面的循环。如果要用请取消掉前面的注释符 '
'If myfile <> "" Then myitem.Attachments.Add ThisWorkbook.Path & "" & myfile, 1
'预览，如果想直接发送，把.display改为.send
myitem.send
i = i + 1
strg = ""
Loop
End With
Set myitem = Nothing
End Sub

复制代码

以上代码在Excel 2013中执行通过，并且对“通讯录”Excel 和“全自动发送邮件”宏代码稍作修改就可以完成任何形式的大量邮件的个性化带附件群发。

我的联系方式见下。
QQ：：851890581
]网站：http://www.eqmap.us/bbs/ （去电脑软件板块发帖找kong12即可）

hmu04141028 · 发表于 2015-8-5 10:51

好东西，太感谢了

anattaanimitta · 发表于 2015-10-21 16:17

太神奇的代码！找了很久了，非常感谢楼主无私的奉献！！太好了！！

yongyuan198 · 发表于 2015-12-10 15:24

很不错我也正在急切的寻找这个功能呢

lagn215 · 发表于 2016-4-20 17:48

我在家里64位的excel 2013用可以，在公司的32位EXCEL 2013 就不可以，提示自动化错误，换一台excel 2010的也不可以，提示是找不到指定路径，哪位高手可以帮忙解决下，急！

天地有雪 · 发表于 2016-4-21 11:57

lagn215 发表于 2016-4-20 17:48
我在家里64位的excel 2013用可以，在公司的32位EXCEL 2013 就不可以，提示自动化错误，换一台excel 2010的 ...

没遇到过着问题哦~哪一行的代码提示错误？要是有例子就更好了！

没有悲伤 · 发表于 2016-4-29 22:19

学习一下，谢谢分享

		自动登录	找回密码
密码			免费注册

[求助] outlook群发带不同附件的邮件

评分