ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[原创] 小闻趣话之一获得邮件的中全部附件

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-12-12 21:45 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
在某个单位办公室
上午9:50分,江少忽然被上司奉召到办公室;少刻,江少苦着面,捧住笔记本电脑从里面出来。急忙到座位边敲击键盘起来。
旁边斌哥打趣说到“江少,怎么啦。进去后变了天”,江少无奈讲“老佛爷让我将邮箱里邮件的附件全部保存下来!。在上午之前完成”,“老佛爷,是不是有点令人难做,不怕,找人帮你!”,“小闻,你过来” 小闻慢慢地过来了,"怎么啦"。“无,我们三个人分开任务,将邮箱里邮件的附件全部下载”
“斌哥,开玩笑,谁有本事将邮箱分三人共享”。小闻猫一眼笔记本电脑,自言自语地讲“幸好他用Outlook,还是完整版本,否则我无办法了”,回头对江少讲“帮你搞好,中午饭你请客”江少,斌哥讲 “肯定?”,小闻笑而不答。


  1. Sub GetAttachmentName()

  2. '//获得邮件中的附件
  3.     Dim OutApp As outlook.Application
  4.     Dim myNamespace As NameSpace
  5.     Dim myFolder As MAPIFolder

  6.     Dim Folder As MAPIFolder
  7.     Dim iMail As outlook.MailItem

  8.     Dim attFilename As String

  9.     Dim myAttachment As outlook.Attachment

  10.     Dim mytmp As String

  11.     Dim tmpa As String

  12.     On Error Resume Next
  13.     Dim ExcelApp
  14.     Set OutApp = New outlook.Application
  15.     Set myNamespace = OutApp.GetNamespace("MAPI")
  16.     'Set myFolder = MyNameSpace.PickFolder
  17.     Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)    '//获得收件箱文件夹



  18.     For i = 1 To myFolder.Folders.Count

  19.         Set Folder = myFolder.Folders(i)

  20.         For Each iMail In Folder.Items

  21.             For Each myAttachment In iMail.Attachments   '//获得邮件的附件

  22.                 attFilename = myAttachment.FileName
  23.                 If attFilename Like "*.xls?" Then  '//判断附件的类型

  24.                     tmpa = Split(attFilename, ".")(1)

  25.                     myAttachment.SaveAsFile "D:\邮件的附件" & attFilename    '//保存附件


  26.                     Debug.Print wbk.Name
  27.                     '                    YYYYMM_OUTLOOKATT_XXXX,YYYYMM是附件所保存的文件夹的名字

  28.                     '//     Debug.Print myAttachment.DisplayName

  29.                 End If

  30.             Next
  31.         Next iMail

  32.     Next



  33.     Set iMail = Nothing
  34.     Set myFolder = Nothing
  35.     Set myNamespace = Nothing
  36.     Set Application = Nothing


  37. End Sub
复制代码

10:30后 邮件的附件 已经全部下载完毕了 。江少和斌哥 傻眼 了




评分

2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-12-12 22:12 | 显示全部楼层
次日,江少又被叫到办公室,几分钟后,“小闻,入来办公室”。老佛爷从里面传出声音,小闻疑惑地走入办公室。老佛爷问“昨日下载邮件的附件。你搞的”。小闻望一眼江少,唯有回答是。老佛爷笑着讲“无事,我想今日收到邮件要下载,想用昨日方法,但是考虑到这样会不会重复下载?所以问下你”
小闻惊奇问"主任,你看懂代码",“我会EXcel VBA,不太懂这个,”小闻道“不行,有重复的,要修改代码,或者用另外方法,利用outlook事件 ”



  1. Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

  2. '//收到邮件后 附件自动保存到指定的路径
  3.     Dim varEntryIDs

  4.     Dim objItem As Object

  5.    dim imail as  Outlook.MailItem

  6.     Dim i As Integer

  7.     varEntryIDs = Split(EntryIDCollection, ",")       '//获得邮件的ID号 唯一的

  8.     For i = 0 To UBound(varEntryIDs)

  9.         Set objItem = Application.Session.GetItemFromID(varEntryIDs(i))    '//根据ID号 获得整个邮件
  10.            
  11.          if objItem.class =43 then

  12.            set  imail  = objItem

  13.              Call NewMailSaveAttachemnets(imail)    '//附件的处理
  14.   
  15.          endif         


  16.       
  17.     Next

  18.     '// MsgBox "你共收到" & UBound(varEntryIDs) & "邮件 "

  19. End Sub
复制代码
  1. Sub NewMailSaveAttachemnets(myMail As Outlook.MailItem)

  2. '// outlook 收到新邮件是  将邮件的附件 自动放到指定位置

  3.     On Error Resume Next

  4.     Dim mail As Outlook.MailItem

  5.     Dim Fso As Object
  6.    
  7.    

  8.     Dim myOlExp As Outlook.Explorer                   '//outlook

  9.     Dim myOlSel As Outlook.Selection                  '//outlook所在选择项

  10.     Dim MyFileName As String

  11.    

  12.     Set myOlExp = Application.ActiveExplorer          '//指向对象 outlook



  13.     Dim vItem As Outlook.Attachment


  14.     If myMail.Attachments.Count > 0 Then

  15.         For i = 1 To myMail.Attachments.Count

  16.          
  17.             Set vItem = myMail.Attachments(i)

  18.             MyFileName = vItem.FileName
  19.             
  20.          

  21.                     vItem.SaveAsFile Folder & "" & vItem.FileName    '//保存附件路径
  22.             


  23.         Next i


  24.     End If


  25. End Sub
复制代码



TA的精华主题

TA的得分主题

发表于 2018-12-13 11:53 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-9-3 10:52 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-10-31 22:08 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-11-15 12:12 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-12-12 17:27 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-3-1 17:12 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
大佬,我也是想实现类似的功能。学习了,我研究下

TA的精华主题

TA的得分主题

发表于 2020-3-7 20:25 | 显示全部楼层
请教一下大佬几个问题,  2楼的第一部分代码的第20行代码,if objItem.class =43 then 这一句是判定是否是新邮件的意思吗?
还有2楼的两个代码分开来的,是指两种方法吗?
还有MAPIFolder 这个网上查了下,“此接口已被弃用;请勿使用此接口。”链接:https://docs.microsoft.com/zh-cn/dotnet/api/microsoft.office.interop.outlook.mapifolder?view=outlook-pia

TA的精华主题

TA的得分主题

发表于 2021-5-28 15:53 | 显示全部楼层

现在这个附件发邮件没有任何问题了,不会报错,执行效率也很高, 可以修改表格里的内容直接使用

自动发送邮件完美版.rar

33.52 KB, 下载次数: 41

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

本版积分规则

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

GMT+8, 2024-3-29 17:08 , Processed in 0.059655 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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