【Access示例】批量读取OutLook里的附件并保存到指定文件夹

时　间:2018-03-25 13:13:25
作　者:缪炜   ID：24010  城市：江阴
摘　要:有时候，我们在工作中会收到许多统一内容的邮件，比如生产数据，报名表等，但一个一个的导出太麻烦了，那有什么办法来快速的导出这些邮件的附件呢？
正　文:

点击下载此附件

代   码:

Dim myFilter As String
    Dim folder As String
    Dim myOlApp As Object
    Dim myNamespace As Object    ' Outlook.NameSpace
    Dim myFolder As Object    ' Outlook.folder
    Dim mymailitem As Variant
    Dim att As Variant
    Dim Path As String
    myFilter = InputBox("请输入邮件标题的过滤关键字:", , "测试")
    folder = InputBox("请输入邮件附件的保存目录:", , "D:\新建文件夹")
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myFolder = myNamespace.GetDefaultFolder(6) 
    For Each mymailitem In myFolder.Items
        If mymailitem.UnRead Then
            If InStr(mymailitem.Subject, myFilter) Then
                mymailitem.UnRead = False
                If mymailitem.Attachments.Count > 0 Then
                    For Each att In mymailitem.Attachments
                        Path = folder & "\" & mymailitem.Subject & "-" & att.FileName
                        Debug.Print Path
                        att.SaveAsFile Path
                    Next
                Else
                    MsgBox mymailitem.SenderEmailAddress & "无附件"
                End If
            End If
        End If
    Next
    MsgBox "完工了"

演   示: