ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 用Outlook群发带不等量附件的邮件

[复制链接]

TA的精华主题

TA的得分主题

发表于 2014-5-13 11:01 | 显示全部楼层 |阅读模式
各位大神,附件中工作簿“111”中的宏做出来的效果只能是一个邮件带一个附加,如果我想要第三个收件人“liweifang”的邮件附带“TS2”,“TS3”两个附件,代码和表“发送”需要怎么修改吗?
昨天苦想无果后,特向各位请教,谢谢!
原代码如下:
  1. Sub displayemail()

  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. With Sheets("发送名单")
  11. i = 2

  12. Do While .Cells(i, 2) <> ""
  13. Set myitem = myOlApp.CreateItem(0)
  14. Set atts = myitem.Attachments
  15. myitem.To = .Cells(i, 3)                                                                                      '收件人E-mail
  16. myitem.cc = .Cells(i, 4)                                                                                      'Cc
  17. myitem.Subject = .Cells(i, 5)                                                                              '标题
  18. myitem.Body = "Dear:" & vbNewLine & "#REF!单元格数据为空!"                 '正文
  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.send                                                                                                      '预览,如果想直接发送,把.display改为.send

  25. i = i + 1
  26. strg = ""
  27. Loop
  28. End With
  29. Set myitem = Nothing
  30. End Sub
复制代码


新建文件夹.zip

149.77 KB, 下载次数: 114

TA的精华主题

TA的得分主题

发表于 2014-5-13 13:08 | 显示全部楼层
我给个例子
这个例子我修改过的
邮件批量发送.zip (24.1 KB, 下载次数: 280)



评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-5-13 16:02 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 天地有雪 于 2014-5-13 16:06 编辑
闻启学 发表于 2014-5-13 13:08
我给个例子
这个例子我修改过的


你的代码好高深啊,基本我都不懂!我取了其中我需要的!现在已经可以了!谢谢你拉!
另外,想问问,attachments.Add 。。的下一句代码为什么要加myfile=dir呢?有什么作用吗?我不太懂!谢谢诶!

  1. Sub displayemail()
  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("发送名单")
  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, 3)                                                    '收件人E-mail
  17.             myitem.cc = .Cells(i, 4)                                                    'Cc
  18.             myitem.Subject = .Cells(i, 5)                                               '标题
  19.             myitem.Body = "Dear:" & vbNewLine & "#REF!单元格数据为空!"                '正文
  20.             myfile = Dir(ThisWorkbook.Path & "\*" & .Cells(i, 1) & "*.*")
  21.             Do Until myfile = ""
  22.                 myitem.attachments.Add ThisWorkbook.Path & "" & myfile, 1              '上传附件
  23.                 myfile = Dir
  24.                 If .Cells(i, 7) <> "" Then
  25.                     myitem.attachments.Add ThisWorkbook.Path & "" & Dir(ThisWorkbook.Path & "\*" & .Cells(i, 7) & "*.*"), 1
  26.                     myfile = Dir
  27.                 Else
  28.                 End If
  29.             Loop
  30.             myitem.send                                                                 '预览,如果想直接发送,把.display改为.send
  31.             i = i + 1
  32.             strg = ""
  33.         Loop
  34.     End With
  35.     Set myitem = Nothing
  36. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2014-5-13 16:04 | 显示全部楼层
天地有雪 发表于 2014-5-13 16:02
你的代码好高深啊,基本我都不懂!我取了其中我需要的!现在已经可以了!谢谢你拉!
另外,想问问,我 ...

哪里有红色 ??

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-5-13 16:07 | 显示全部楼层
闻启学 发表于 2014-5-13 16:04
哪里有红色 ??

我改了!麻烦你了!

TA的精华主题

TA的得分主题

发表于 2014-5-13 16:13 | 显示全部楼层
这个问题
另外,想问问,attachments.Add 。。的下一句代码为什么要加myfile=dir呢?有什么作用吗?我不太懂!谢谢诶!

这个是dir 作用

myfile =dir(路径 & ”“)

do
myfile =dir  第二次作用就是查找下一个文件 ,无这个语句的话  用永远都在第一个文件上 变成死循环
loop  until len(myfile )=0

TA的精华主题

TA的得分主题

发表于 2014-7-19 16:26 | 显示全部楼层
闻启学 发表于 2014-5-13 13:08
我给个例子
这个例子我修改过的

你好,我使用了你提供的模板,但是发送的邮件没有正文,我使用的是office2013。不知道是什么问题,谢谢

TA的精华主题

TA的得分主题

发表于 2014-7-19 19:14 | 显示全部楼层
又又云 发表于 2014-7-19 16:26
你好,我使用了你提供的模板,但是发送的邮件没有正文,我使用的是office2013。不知道是什么问题,谢谢

无 可能的  啊 楼上

TA的精华主题

TA的得分主题

发表于 2015-10-16 16:22 | 显示全部楼层
闻启学 发表于 2014-5-13 13:08
我给个例子
这个例子我修改过的

这个例子对我帮助很大,太神奇了。多谢多谢!

TA的精华主题

TA的得分主题

发表于 2015-10-16 17:30 | 显示全部楼层
天地有雪 发表于 2014-5-13 16:02
你的代码好高深啊,基本我都不懂!我取了其中我需要的!现在已经可以了!谢谢你拉!
另外,想问问,at ...

若第三个收件人“liweifang”(老总?)需收到所有附件,则如下:
  1. Sub displayemail()
  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("发送名单")
  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, 3)                                                    '收件人E-mail
  17.             myitem.cc = .Cells(i, 4)                                                    'Cc
  18.             myitem.Subject = .Cells(i, 5)                                               '标题
  19.             myitem.Body = "Dear:" & vbNewLine & "#REF!单元格数据为空!"                '正文
  20.             myfile = Dir(ThisWorkbook.Path & "\*" & .Cells(i, 1) & "*.*")
  21.             If .Cells(i, 7) <> "" Then
  22.                 For Each Cel In .Range("a2:a" & .UsedRange.Rows.Count)
  23.                     myitem.attachments.Add ThisWorkbook.Path & "" & Dir(ThisWorkbook.Path & "\*" & Cel.Value & "*.*"), 1
  24.                     myfile = Dir
  25.                 Next
  26.             Else
  27.                 myitem.attachments.Add ThisWorkbook.Path & "" & myfile, 1              '上传附件
  28.                 myfile = Dir
  29.             End If
  30.             myitem.display                                                                 '预览,如果想直接发送,把.display改为.send
  31.             i = i + 1
  32.             strg = ""
  33.         Loop
  34.     End With
  35.     Set myitem = Nothing
  36. End Sub
复制代码

评分

1

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 02:03 , Processed in 0.055209 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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