ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 限时送,魔方网表将Excel变在线系统 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 264|回复: 2

[求助] EXCEL通过VBA添加多个多个OUTLOOK附件

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-12-21 23:40 | 显示全部楼层 |阅读模式
各位大神,有一个EXCEL模板,可以通过此模板批量发送OUTLOOK邮件,并可以实现不同邮件不同附件,但是有一个问题,不能添加多个附件,希望大神帮助修改代码,谢谢!
模板中:
A列是邮件标题;
B列是收件人名称;
C列是收件人收件箱;
D-J列是邮件附件的名称;(现在发送只能放入D列的附件,其他列的VBA放不进去)
K列是邮件正文。

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
        myitem.To = .Cells(i, 3)    '收件人邮箱地址调用了第3列邮箱的数据
        myitem.Subject = .Cells(i, 1)             '标题调用了第1列的数据
        myitem.Body = .Cells(i, 11)
        myfile = Dir(ThisWorkbook.Path & "\" & .Cells(i, 4))  '在本工作薄的根目录下找出附件,且附件的文件名是第四列数据
        If myfile <> "" Then myitem.Attachments.Add ThisWorkbook.Path & "\" & myfile, 1
         '预览,如果想直接发送,把.display改为.send
           'myitem.send
            myitem.display
            i = i + 1
            strg = ""
        Loop
    End With
    Set myitem = Nothing
    End Sub

自动邮件.rar

92.62 KB, 下载次数: 4

TA的精华主题

TA的得分主题

发表于 2019-2-1 10:57 | 显示全部楼层
本帖最后由 tyxvba7529 于 2019-2-1 11:02 编辑

请参考代码
  1. '        添加附件开始
  2.             myfile = Dir(ThisWorkbook.Path & "" & Cells(i, 4) & "*")
  3.             Do
  4.                 myitem.Attachments.Add ThisWorkbook.Path & "" & myfile, 1
  5.                 myfile = Dir
  6.               Loop Until myfile = ""
  7. '              添加附件结束
复制代码



TA的精华主题

TA的得分主题

发表于 2019-2-1 11:02 | 显示全部楼层
'        添加附件开始
            myfile = Dir(ThisWorkbook.Path & "\" & Cells(i, 4) & "*")
            Do
                myitem.Attachments.Add ThisWorkbook.Path & "\" & myfile, 1
                myfile = Dir
              Loop Until myfile = ""
'              添加附件结束
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

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

GMT+8, 2019-3-21 15:35 , Processed in 0.070237 second(s), 13 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

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

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

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