ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: 天地有雪

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

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2015-6-6 16:24 | 显示全部楼层
LEASON 发表于 2015-6-3 15:24
我们的疑惑是怎么用,把代码复制到EXCEL里VBA 运行还是在OUTLOOK里操作

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

TA的精华主题

TA的得分主题

发表于 2015-6-7 14:29 | 显示全部楼层
真的是不明觉厉啊,VBA太强大了!

TA的精华主题

TA的得分主题

发表于 2015-6-12 09:17 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2015-7-12 08:39 | 显示全部楼层
本帖最后由 kong12 于 2015-7-12 10:23 编辑

2楼的代码原文见下
  1. Sub sendemail()

  2.     Dim myOlApp As Object
  3.     Dim myitem As Object
  4.     Dim i As Integer, j As Integer
  5.     Dim strg As String
  6.     Dim atts As Object
  7.     Dim mycc As Object
  8.     Dim myfile As String

  9.     Set myOlApp = CreateObject("Outlook.Application")
  10.    
  11.     With Sheets("Sheet1")
  12.         i = 2

  13.         Do While .Cells(i, 2) <> ""
  14.             Set myitem = myOlApp.CreateItem(0)
  15.            Set atts = myitem.Attachments
  16.             myitem.To = .Cells(i, 2)              '收件人E-mail
  17.             myitem.Subject = .Cells(i, 3)            '标题
  18.             myitem.Body = .Cells(i, 1) & ",你好!" & vbNewLine & vbNewLine & vbNewLine & .Cells(i, 4)   '正文
  19.             myfile = Dir(ThisWorkbook.Path & "\*" & .Cells(i, 1) & "*.*")
  20.             Do Until myfile = ""
  21.                 myitem.Attachments.Add ThisWorkbook.Path & "" & myfile, 1
  22.                 myfile = Dir
  23.             Loop
  24.             myitem.display '预览,如果想直接发送,把.display改为.send

  25.             i = i + 1
  26.             strg = ""
  27.         Loop
  28.     End With
  29.     Set myitem = Nothing
  30. End Sub
复制代码
注意:该代码如果对有名字包含的人,比如一个李华一个李华盛这种人名,就会把邮件的附件发重复,李华收到李华和李华盛两个附件。
要把  myfile = Dir(ThisWorkbook.Path & "\*" & .Cells(i, 1) & "*.*")    改成下面的这样才行,
myfile = Dir(ThisWorkbook.Path & "\" & .Cells(i, 2) & ".*")

并且再添加附件时也要加限制, 否则如果没有对应的附件就会出错。
要加一个 Do 循环 或者 一个 If 条件 语句,
修改后的代码见下
  1.     Sub 全自动发送邮件()

  2.     Dim myOlApp As Object
  3.     Dim myitem As Object
  4.     Dim i As Integer, j As Integer
  5.     Dim strg As String
  6.     Dim atts As Object
  7.     Dim mycc As Object
  8.     Dim myfile As String

  9.     Set myOlApp = CreateObject("Outlook.Application")
  10.    
  11.     '设置对Sheet1工作表进行操作,可自行修改
  12.     With Sheets("Sheet1")
  13.         i = 2

  14.         Do While .Cells(i, 2) <> ""
  15.                    '设置调用Outlook来发送邮件
  16.            Set myitem = myOlApp.CreateItem(0)
  17.            Set atts = myitem.Attachments
  18.            '收件人邮箱地址调用了第3列邮箱的数据
  19.             myitem.To = .Cells(i, 3)
  20.            '邮件标题调用了第2列姓名、第4列标题的数据
  21.             myitem.Subject = .Cells(i, 2) & "老师," & .Cells(i, 4)
  22.            '邮件正文,调用第2列即B列的姓名和第4列即D列的邮件标题。
  23.             myitem.Body = .Cells(i, 2) & "老师,你好!" & vbNewLine & vbNewLine & vbNewLine & .Cells(i, 4) & ",具体请看附件。" & vbNewLine & vbNewLine & vbNewLine & "祝暑假愉快!"
  24.            
  25.                    '在本工作薄的根目录下找出附件,且附件的文件名是收件人的名字
  26.             myfile = Dir(ThisWorkbook.Path & "" & .Cells(i, 2) & ".*")
  27.                         
  28.                         '下面是个添加一个到多个附件的循环。如果没找到对应人名的附件,则发无附件邮件。
  29.             Do Until myfile = ""
  30.                 myitem.Attachments.Add ThisWorkbook.Path & "" & myfile, 1
  31.                 myfile = Dir
  32.             Loop
  33.                         
  34.                         '下面一句适用于只添加一个附件用的,可以替换上面的循环。如果要用请取消掉前面的注释符 '
  35.             'If myfile  <> "" Then myitem.Attachments.Add ThisWorkbook.Path & "" & myfile, 1
  36.             
  37.                         '预览,如果想直接发送,把.display改为.send
  38.             myitem.send

  39.             i = i + 1
  40.             strg = ""
  41.         Loop
  42.     End With
  43.    
  44.     Set myitem = Nothing
  45.    
  46.     End Sub
复制代码

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

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

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2015-8-5 10:51 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
好东西,太感谢了

TA的精华主题

TA的得分主题

发表于 2015-10-21 16:17 | 显示全部楼层
太神奇的代码!找了很久了,非常感谢楼主无私的奉献!!太好了!!

TA的精华主题

TA的得分主题

发表于 2015-12-10 15:24 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2016-4-20 17:48 | 显示全部楼层
我在家里64位的excel 2013用可以,在公司的32位EXCEL 2013 就不可以,提示自动化错误,换一台excel 2010的也不可以,提示是找不到指定路径,哪位高手可以帮忙解决下,急!

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-4-21 11:57 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
lagn215 发表于 2016-4-20 17:48
我在家里64位的excel 2013用可以,在公司的32位EXCEL 2013 就不可以,提示自动化错误,换一台excel 2010的 ...

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

TA的精华主题

TA的得分主题

发表于 2016-4-29 22:19 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 22:24 , Processed in 0.055527 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表