Outlook VBA按指定发件人及日期筛选保存收件箱邮件附件

我的Outlook收件箱中共有超过3500封邮件，需要实现的功能为：

• 基于Outlook VBA，批量保存特定发件人在指定日期发送的邮件内的全部附件。

原代码的逻辑缺陷 #

你提供的初始代码存在以下问题，无法正常满足需求：

• 未加入日期维度的筛选逻辑，无法定位指定日期范围的邮件
• 附件保存逻辑放在邮件遍历循环外部，仅会保存最后一封匹配发件人邮件的附件
• 未校验本地保存路径是否存在，路径不存在时会直接触发运行时报错
• 全量遍历所有收件箱邮件，3500+邮件量级下运行效率低
• 未对收件箱内的非邮件类条目（会议邀请、系统通知等）做类型判断，遍历过程中容易报错
• 未处理同名附件覆盖问题，不同邮件下的同名附件会被覆盖丢失

修正后可直接运行的VBA代码 #

Sub Save_Specified_Sender_Date_Attachments()
    Dim App As Outlook.Application
    Dim NS As Outlook.Namespace
    Dim MyFolder As Outlook.MAPIFolder
    Dim Items As Outlook.Items
    Dim Msg As Object
    Dim Attachments As Outlook.Attachments
    Dim i As Long
    Dim iCount As Long
    Dim FilePath As String
    Dim FolderPath As String
    
    ' -------------------------- 以下参数请按需修改 --------------------------
    Const TARGET_SENDER As String = "someone@somewhere.com"  ' 目标发件人邮箱地址
    Const DATE_START As Date = #2024/1/1#  ' 筛选邮件的起始日期
    Const DATE_END As Date = #2024/6/30#   ' 筛选邮件的结束日期
    FolderPath = "C:\Outlook Saved Attachments\" ' 附件本地保存路径
    ' -----------------------------------------------------------------------
    
    ' 初始化Outlook相关对象
    Set App = New Outlook.Application
    Set NS = App.GetNamespace("MAPI")
    Set MyFolder = NS.GetDefaultFolder(olFolderInbox)
    Set Items = MyFolder.Items
    
    ' 按收件时间排序，提升遍历匹配效率
    Items.Sort Property:="[ReceivedTime]", Descending:=False
    
    ' 自动创建附件保存文件夹，路径不存在时自动新建
    If Dir(FolderPath, vbDirectory) = "" Then
        MkDir FolderPath
    End If
    
    ' 遍历邮件匹配规则
    For Each Msg In Items
        ' 跳过会议邀请、系统回执等非邮件类型条目
        If TypeName(Msg) = "MailItem" Then
            ' 同时匹配发件人、收件时间范围
            If Msg.SenderEmailAddress = TARGET_SENDER _
                And Msg.ReceivedTime >= DATE_START _
                And Msg.ReceivedTime <= DATE_END + #11:59:59 PM# Then
                
                Set Attachments = Msg.Attachments
                ' 逐份保存当前匹配邮件的附件
                If Attachments.Count > 0 Then
                    For i = Attachments.Count To 1 Step -1
                        ' 可选：过滤掉邮件签名里的小图片、内嵌资源，不需要可删除下方If判断
                        If Attachments.Item(i).Size > 1024 Then
                            FilePath = FolderPath & Attachments.Item(i).FileName
                            ' 同名文件自动加序号，避免覆盖
                            Do While Dir(FilePath) <> ""
                                iCount = iCount + 1
                                FilePath = FolderPath & "(" & iCount & ")" & Attachments.Item(i).FileName
                            Loop
                            Attachments.Item(i).SaveAsFile FilePath
                            iCount = 0
                        End If
                    Next i
                End If
            End If
        End If
    Next Msg
    
    ' 释放占用的对象
    Set Attachments = Nothing
    Set Msg = Nothing
    Set Items = Nothing
    Set MyFolder = Nothing
    Set NS = Nothing
    Set App = Nothing
    
    MsgBox "符合条件的邮件附件已全部保存完成", vbInformation
End Sub

使用注意事项 #

• 打开Outlook后按快捷键Alt+F11即可调出VBA编辑器，将代码粘贴到插入的标准模块中即可
• 运行前先修改代码开头配置区的三个参数：目标发件人邮箱、筛选起止日期、附件保存路径
• 代码默认过滤了1KB以下的内嵌签名小图，如果需要保存所有类型附件，删除对应大小判断的代码行即可
• 如果需要遍历收件箱下的子文件夹，可以额外补充递归遍历子文件夹的逻辑
• 首次运行需要开启宏权限，建议将宏安全设置为“对所有宏进行通知”即可正常运行

内容的提问来源于stack exchange，提问作者Pritam Singh