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 VBA经典代码实践指南
查看: 511|回复: 2

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-12-12 21:45 | 显示全部楼层 |阅读模式
在某个单位办公室
上午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后 邮件的附件 已经全部下载完毕了 。江少和斌哥 傻眼 了




评分

参与人数 1鲜花 +2 收起 理由
gamezhu0705love + 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 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

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

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

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

GMT+8, 2019-6-17 21:55 , Processed in 0.092972 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

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

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

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