ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 限时送,魔方网表将Excel变在线系统 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 ExcelHome出品 - VBA代码宝免费下载 13门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
楼主: 天地有雪

[求助] 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鲜花 +2 收起 理由
天地有雪 + 2 值得肯定

查看全部评分

TA的精华主题

TA的得分主题

发表于 2015-8-5 10:51 | 显示全部楼层

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 | 显示全部楼层
lagn215 发表于 2016-4-20 17:48
我在家里64位的excel 2013用可以,在公司的32位EXCEL 2013 就不可以,提示自动化错误,换一台excel 2010的 ...

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

TA的精华主题

TA的得分主题

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

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,高效办公专列,每天发车

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

GMT+8, 2019-1-24 15:00 , Processed in 0.109785 second(s), 14 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

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

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

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