如何修改Outlook VBA代码遍历指定文件夹自动下载附件

下面是修改后的完整代码，把原来处理选中邮件的逻辑替换成遍历FindInFolders找到的指定文件夹内的所有邮件，同时优化了类型判断避免出错：

Public Sub SaveAttachmentsAlex()
    Dim objOL As Outlook.Application
    Dim objMsg As Object ' 改为Object兼容所有文件夹项
    Dim objAttachments As Outlook.Attachments
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolderpath As String
    Dim strDeletedFiles As String
    Dim N As Long
    Dim FoundFolder As Folder

    ' 定位目标文件夹，替换成你的文件夹名称
    Set FoundFolder = FindInFolders(Application.Session.Folders, "Folder to check")
    
    ' 附件保存路径，替换成你的目标路径
    strFolderpath = "L:\"
    On Error Resume Next

    ' 实例化Outlook应用对象
    Set objOL = CreateObject("Outlook.Application")

    ' 初始化计数变量
    N = 1
    ' 遍历目标文件夹中的所有项
    For Each objMsg In FoundFolder.Items
        ' 只处理邮件类型的项
        If objMsg.Class = olMail Then
            ' 获取邮件的附件集合
            Set objAttachments = objMsg.Attachments
            lngCount = objAttachments.Count
            strDeletedFiles = ""

            If lngCount > 0 Then
                ' 倒序遍历附件，避免删除时索引混乱
                For i = lngCount To 1 Step -1
                    ' 生成带计数的文件名
                    strFile = objAttachments.Item(i).FileName
                    strFile = N & " - " & strFile
                    ' 拼接完整保存路径
                    strFile = strFolderpath & strFile

                    ' 保存附件到指定路径
                    objAttachments.Item(i).SaveAsFile strFile
                    ' 删除邮件中的附件
                    objAttachments.Item(i).Delete

                    ' 构建附件保存路径的提示文本
                    If objMsg.BodyFormat <> olFormatHTML Then
                        strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
                    Else
                        strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
                        strFile & "'>" & strFile & "</a>"
                    End If
                Next i
                N = N + 1
                ' 将保存路径添加到邮件正文并保存
                If objMsg.BodyFormat <> olFormatHTML Then
                    objMsg.Body = vbCrLf & "文件已保存至：" & strDeletedFiles & vbCrLf & objMsg.Body
                Else
                    objMsg.HTMLBody = "<p>文件已保存至：" & strDeletedFiles & "</p>" & objMsg.HTMLBody
                End If
                objMsg.Save
            End If
        End If
    Next

ExitSub:
    ' 释放对象资源
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set FoundFolder = Nothing
    Set objOL = Nothing
End Sub

Function FindInFolders(TheFolders As Outlook.Folders, Name As String) As Outlook.Folder
    Dim SubFolder As Outlook.MAPIFolder
    
    On Error Resume Next
    
    Set FindInFolders = Nothing
    
    For Each SubFolder In TheFolders
        If LCase(SubFolder.Name) Like LCase(Name) Then
            Set FindInFolders = SubFolder
            Exit For
        Else
            Set FindInFolders = FindInFolders(SubFolder.Folders, Name)
            If Not FindInFolders Is Nothing Then Exit For
        End If
        Debug.Print SubFolder.Name
    Next
End Function

关键修改说明 #

• 替换遍历逻辑：删除了原来获取选中邮件的objSelection相关代码，直接遍历FoundFolder.Items，实现对指定文件夹所有邮件的处理
• 增加类型判断：添加If objMsg.Class = olMail Then，确保只处理邮件项，避免文件夹中其他类型项目（如日历、任务）导致代码报错
• 清理无用变量：移除了不再使用的objSelection变量，优化代码结构
• 优化提示文本：将英文提示改为中文，更符合使用习惯

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