请求实现特定发件人邮件附件自动保存、标记已读并归档（代码无效果）

原代码存在的核心问题 #

• 参数冗余且逻辑矛盾：过程参数定义为strID As Outlook.MailItem，却又通过olNS.GetItemFromID(strID.EntryID)重新获取邮件对象，完全没必要，反而可能引发对象引用错误。
• 缺失关键自定义函数：代码调用了Isembedded但未提供该函数的定义，运行时会直接终止且无提示。
• 未实现特定发件人过滤：仅获取发件人地址但未做判断，不符合“只处理特定人员邮件”的需求。
• 归档文件夹定位不可靠：依赖MyMail.Parent.Folders("test")定位归档文件夹，一旦文件夹不存在或路径层级不对，会触发错误。
• 无错误捕获机制：运行中出现权限不足、文件被占用等问题时，程序静默失败，无法排查原因。

修复后的完整代码 #

' 判断附件是否为内嵌对象（如正文中的图片）
Function Isembedded(objMail As Outlook.MailItem, attIndex As Integer) As String
    Dim att As Outlook.Attachment
    Set att = objMail.Attachments(attIndex)
    
    ' 检查附件是否为内嵌类型
    If att.Type = olEmbeddeditem Or att.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001F") <> "" Then
        Isembedded = "Embedded"
    Else
        Isembedded = ""
    End If
End Function

' 主处理过程：保存特定发件人邮件的附件、标记已读并归档
Sub ProcessSpecificSenderMail(objMail As Outlook.MailItem)
    ' --------------------------
    ' 配置区域：修改为你的目标信息
    Const TARGET_SENDER As String = "xxx@example.com" ' 特定发件人的邮箱地址
    Const SAVE_FOLDER As String = "C:\TEST\" ' 附件保存路径
    Const ARCHIVE_FOLDER_NAME As String = "test" ' 归档文件夹名称（需提前在Outlook中创建）
    ' --------------------------
    
    Dim olNS As Outlook.Namespace
    Dim savePath As String
    Dim myDestFolder As Outlook.MAPIFolder
    Dim PJ As Outlook.Attachment
    
    ' 错误捕获
    On Error GoTo ErrorHandler
    
    ' 过滤特定发件人
    If objMail.SenderEmailAddress <> TARGET_SENDER Then
        Exit Sub
    End If
    
    ' 确保附件保存文件夹存在
    savePath = SAVE_FOLDER
    If Dir(savePath, vbDirectory) = "" Then
        MkDir savePath
    End If
    
    ' 处理附件
    If objMail.Attachments.Count > 0 Then
        For Each PJ In objMail.Attachments
            ' 跳过内嵌附件
            If Isembedded(objMail, PJ.Index) = "" Then
                Dim fullFilePath As String
                fullFilePath = savePath & PJ.FileName
                
                ' 如果文件已存在，先备份到old子文件夹
                If Dir(fullFilePath, vbNormal) <> "" Then
                    Dim oldFolder As String
                    oldFolder = savePath & "old\"
                    If Dir(oldFolder, vbDirectory) = "" Then
                        MkDir oldFolder
                    End If
                    FileCopy fullFilePath, oldFolder & PJ.FileName
                End If
                
                ' 保存附件
                PJ.SaveAsFile fullFilePath
            End If
        Next PJ
    End If
    
    ' 标记为已读并保存
    objMail.UnRead = False
    objMail.Save
    
    ' 归档邮件：先定位归档文件夹
    Set olNS = Application.GetNamespace("MAPI")
    ' 这里假设归档文件夹在收件箱下，若不在可修改路径（如olNS.Folders("你的邮箱账户").Folders(ARCHIVE_FOLDER_NAME)）
    Set myDestFolder = olNS.GetDefaultFolder(olFolderInbox).Folders(ARCHIVE_FOLDER_NAME)
    If Not myDestFolder Is Nothing Then
        objMail.Move myDestFolder
    End If
    
Cleanup:
    ' 释放对象
    Set PJ = Nothing
    Set myDestFolder = Nothing
    Set olNS = Nothing
    Exit Sub
    
ErrorHandler:
    MsgBox "执行出错：" & Err.Description, vbCritical
    Resume Cleanup
End Sub

配置步骤 #

1. 打开Outlook，按Alt+F11打开VBA编辑器。
2. 在左侧“Project”窗口中，右键点击Microsoft Outlook Objects，选择“插入”→“模块”，将上述代码粘贴到模块中。
3. 修改代码配置区域的参数：替换目标发件人邮箱、附件保存路径、归档文件夹名称。
4. 在Outlook中创建规则：
   • 规则类型选“由空白规则开始”→“对我接收的邮件应用规则”。
   • 添加条件：“发件人为特定人员”，选择你要过滤的联系人。
   • 添加操作：“运行脚本”，选择ProcessSpecificSenderMail。
   • 完成规则配置并启用。

内容的提问来源于stack exchange，提问作者assistant.gestion