如何仅根据附件文件名自动保存Outlook邮件附件

一、自动触发配置（收到邮件时自动执行） #

1. 打开Outlook VBA编辑器：按Alt+F11，或通过「开发者」选项卡→「Visual Basic」进入
2. 在左侧项目窗口，双击Microsoft Outlook Objects下的ThisOutlookSession
3. 粘贴以下代码，修改顶部的常量参数为你的实际信息：

Option Explicit

' --- 请修改以下常量为你的实际配置 ---
Const TARGET_FILENAME As String = "SSIPackage" ' 固定文件名（不含扩展名）
Const TARGET_EXT As String = ".zip" ' 固定扩展名
Const SAVE_PATH As String = "\\server\SSI-Uploads\" ' 网络保存路径（确保有读写权限）
' --- 常量结束 ---

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim objNS As Outlook.NameSpace
    Dim objMail As Outlook.MailItem
    Dim objAttachment As Outlook.Attachment
    Dim fs As Object
    Dim saveFullPath As String
    Dim senderName As String
    Dim receiveDate As String
    
    Set objNS = Application.GetNamespace("MAPI")
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    ' 处理新收到的邮件（支持批量邮件ID）
    Dim arrEntryIDs As Variant
    arrEntryIDs = Split(EntryIDCollection, ",")
    
    Dim i As Integer
    For i = LBound(arrEntryIDs) To UBound(arrEntryIDs)
        On Error Resume Next
        Set objMail = objNS.GetItemFromID(arrEntryIDs(i))
        On Error GoTo 0
        
        If Not objMail Is Nothing Then
            ' 遍历邮件中的所有附件
            For Each objAttachment In objMail.Attachments
                ' 判断附件是否匹配固定文件名+扩展名（忽略大小写）
                If LCase(objAttachment.DisplayName) = LCase(TARGET_FILENAME & TARGET_EXT) Then
                    ' 处理变量：发件人名称、送达日期（替换非法字符）
                    senderName = Replace(objMail.SenderName, "/", "-")
                    receiveDate = Format(objMail.ReceivedTime, "YYYY-MM-DD_HH-MM-SS")
                    
                    ' 确保保存路径存在，不存在则创建
                    If Not fs.FolderExists(SAVE_PATH) Then
                        fs.CreateFolder SAVE_PATH
                    End If
                    
                    ' 生成带变量的保存路径（避免文件覆盖）
                    saveFullPath = SAVE_PATH & TARGET_FILENAME & "_" & senderName & "_" & receiveDate & TARGET_EXT
                    
                    ' 保存附件
                    objAttachment.SaveAsFile saveFullPath
                End If
            Next objAttachment
            
            Set objMail = Nothing
        End If
    Next i
    
    Set fs = Nothing
    Set objNS = Nothing
End Sub

4. 保存文件（默认保存为VBAProject.OTM），重启Outlook使配置生效

二、手动运行宏（批量处理历史邮件） #

如果需要手动筛选收件箱中的邮件并保存附件，添加以下独立宏：

1. 在VBA编辑器中，右键点击Project1→「插入」→「模块」
2. 粘贴以下代码（确保常量与自动触发代码一致）：

Option Explicit

' --- 请确保此处常量与ThisOutlookSession中的一致 ---
Const TARGET_FILENAME As String = "SSIPackage"
Const TARGET_EXT As String = ".zip"
Const SAVE_PATH As String = "\\server\SSI-Uploads\"
' --- 常量结束 ---

Sub SaveTargetAttachmentsManually()
    Dim objNS As Outlook.NameSpace
    Dim objInbox As Outlook.Folder
    Dim objMail As Outlook.MailItem
    Dim objAttachment As Outlook.Attachment
    Dim fs As Object
    Dim saveFullPath As String
    Dim senderName As String
    Dim receiveDate As String
    
    Set objNS = Application.GetNamespace("MAPI")
    Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    ' 确保保存路径存在
    If Not fs.FolderExists(SAVE_PATH) Then
        fs.CreateFolder SAVE_PATH
    End If
    
    ' 遍历收件箱所有邮件
    For Each objMail In objInbox.Items
        ' 仅处理邮件类型（排除会议邀请等）
        If objMail.Class = olMail Then
            For Each objAttachment In objMail.Attachments
                If LCase(objAttachment.DisplayName) = LCase(TARGET_FILENAME & TARGET_EXT) Then
                    senderName = Replace(objMail.SenderName, "/", "-")
                    receiveDate = Format(objMail.ReceivedTime, "YYYY-MM-DD_HH-MM-SS")
                    saveFullPath = SAVE_PATH & TARGET_FILENAME & "_" & senderName & "_" & receiveDate & TARGET_EXT
                    
                    objAttachment.SaveAsFile saveFullPath
                End If
            Next objAttachment
        End If
    Next objMail
    
    MsgBox "批量保存完成！", vbInformation
    
    Set fs = Nothing
    Set objInbox = Nothing
    Set objNS = Nothing
End Sub

3. 运行宏：回到Outlook，「开发者」选项卡→「宏」，选择SaveTargetAttachmentsManually→「运行」

三、关键注意事项 #

• 宏安全设置：Office 365默认禁用宏，需在「文件」→「选项」→「信任中心」→「信任中心设置」→「宏设置」中选择「启用所有宏」（或更安全的「签署宏」，需数字证书），也可将Outlook数据文件放到信任位置
• 网络路径权限：确保你的Windows账户对SAVE_PATH对应的网络文件夹有读写权限，可先在资源管理器输入路径测试访问
• 文件名匹配：代码用LCase统一转小写避免大小写遗漏；若需匹配「包含固定文件名」而非完全匹配，可将判断条件改为InStr(LCase(objAttachment.DisplayName), LCase(TARGET_FILENAME)) > 0
• 无输出排查：自动触发无效果时，先手动运行宏测试是否能找到附件；检查宏是否启用、路径是否正确、附件文件名是否完全匹配

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