Outlook保存PDF附件宏遗漏部分文档，请求排查问题

问题描述 #

编写了以下Outlook宏用于保存指定文件夹内邮件的PDF附件，但运行后部分附件被遗漏：

Sub SavePdfAttachments()
    Dim olApp           As Object
    Dim olNS            As Object
    Dim olFolder        As Object
    Dim olItems         As Object
    Dim olItem          As Object
    Dim olAtt           As Object
    Dim sSaveToFolder   As String
    Dim Ans             As Long
    
    sSaveToFolder = "C:\Users\admin\Documents\Invoices\" 'change the destination folder accordingly
    
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.Folders("******@***********.co.uk").Folders("Invoices") 'change the source folder accordingly
    Set olItems = olFolder.Items
    
    For Each olItem In olItems
        If olItem.Attachments.Count > 0 Then
            For Each olAtt In olItem.Attachments
                If Right(olAtt.FileName, 4) = ".pdf" Then
                    If Len(Dir(sSaveToFolder & olAtt.FileName)) = 0 Then
                        olAtt.SaveAsFile sSaveToFolder & olAtt.FileName
                        olItem.Save
                    Else
                        Ans = MsgBox(olAtt.FileName & " already exists.  Overwrite file?", vbQuestion + vbYesNo)
                        If Ans = vbYes Then
                            olAtt.SaveAsFile sSaveToFolder & olAtt.FileName
                            olItem.Save
                        End If
                    End If
                End If
            Next olAtt
        End If
    Next olItem
    
    Set olApp = Nothing
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olItems = Nothing
    Set olItem = Nothing
    Set olAtt = Nothing
    
End Sub

可能的原因及修复方法 #

• 文件名大小写判断问题
  原代码用Right(olAtt.FileName, 4) = ".pdf"判断，若附件文件名后缀为.PDF（大写）则会被遗漏。
  修复：将判断改为不区分大小写的形式：

  If LCase(Right(olAtt.FileName, 4)) = ".pdf" Then
  

• 未过滤嵌入型附件
  Outlook的Attachments集合包含嵌入到邮件正文的附件（比如签名图片、内嵌PDF），这类附件类型为olEmbeddeditem（数值5），并非独立可保存的附件。原代码未区分附件类型，可能跳过真正的附件或处理无效项导致中断。
  修复：添加附件类型判断，只处理独立附件（类型olByValue，数值1）：

  If olAtt.Type = 1 And LCase(Right(olAtt.FileName, 4)) = ".pdf" Then
  

• 未遍历子文件夹
  原代码仅处理指定文件夹的顶级邮件，若PDF附件存在于该文件夹的子文件夹中，会被完全遗漏。
  修复：添加递归函数遍历所有子文件夹（完整优化代码如下）：

  Sub SavePdfAttachments()
      Dim olApp           As Object
      Dim olNS            As Object
      Dim olFolder        As Object
      Dim sSaveToFolder   As String
      
      sSaveToFolder = "C:\Users\admin\Documents\Invoices\"
      
      Set olApp = CreateObject("Outlook.Application")
      Set olNS = olApp.GetNamespace("MAPI")
      Set olFolder = olNS.Folders("******@***********.co.uk").Folders("Invoices")
      
      '调用递归函数处理文件夹及子文件夹
      ProcessFolder olFolder, sSaveToFolder
      
      Set olApp = Nothing
      Set olNS = Nothing
      Set olFolder = Nothing
  End Sub
  
  Sub ProcessFolder(olFolder As Object, sSaveToFolder As String)
      Dim olItem As Object
      Dim olAtt As Object
      Dim Ans As Long
      Dim subFolder As Object
      
      '处理当前文件夹的邮件
      For Each olItem In olFolder.Items
          '只处理邮件类型项，跳过会议邀请、任务等
          If olItem.Class = 43 Then
              If olItem.Attachments.Count > 0 Then
                  For Each olAtt In olItem.Attachments
                      If olAtt.Type = 1 And LCase(Right(olAtt.FileName, 4)) = ".pdf" Then
                          Dim cleanFileName As String
                          cleanFileName = ReplaceIllegalChars(olAtt.FileName)
                          
                          '检查路径长度是否超过Windows限制
                          If Len(sSaveToFolder & cleanFileName) > 259 Then
                              MsgBox "文件名过长，无法保存：" & olAtt.FileName, vbExclamation
                          Else
                              If Len(Dir(sSaveToFolder & cleanFileName)) = 0 Then
                                  olAtt.SaveAsFile sSaveToFolder & cleanFileName
                                  olItem.Save
                              Else
                                  Ans = MsgBox(cleanFileName & " 已存在，是否覆盖？", vbQuestion + vbYesNo)
                                  If Ans = vbYes Then
                                      olAtt.SaveAsFile sSaveToFolder & cleanFileName
                                      olItem.Save
                                  End If
                              End If
                          End If
                      End If
                  Next olAtt
              End If
          End If
      Next olItem
      
      '递归处理子文件夹
      For Each subFolder In olFolder.Folders
          ProcessFolder subFolder, sSaveToFolder
      Next subFolder
  End Sub
  
  '替换文件名中的非法字符
  Function ReplaceIllegalChars(fileName As String) As String
      fileName = Replace(fileName, "\", "_")
      fileName = Replace(fileName, "/", "_")
      fileName = Replace(fileName, ":", "_")
      fileName = Replace(fileName, "*", "_")
      fileName = Replace(fileName, "?", "_")
      fileName = Replace(fileName, """", "_")
      fileName = Replace(fileName, "<", "_")
      fileName = Replace(fileName, ">", "_")
      fileName = Replace(fileName, "|", "_")
      ReplaceIllegalChars = fileName
  End Function
  

• 未过滤非邮件项
  文件夹中可能包含会议邀请、任务、联系人等非邮件项，这些项没有Attachments属性或处理时会抛出错误，导致循环提前中断，遗漏后续邮件的附件。
  修复：添加邮件类型判断，仅处理Class为olMail（数值43）的项，如上述递归函数中的If olItem.Class = 43 Then。

• 文件名长度或非法字符问题
  Windows系统中，路径+文件名总长度超过260字符会导致保存失败；文件名包含\ / : * ? " < > |等非法字符时也会保存失败，且无提示。
  修复：添加文件名清理和长度检查，如上述代码中的ReplaceIllegalChars函数和路径长度判断。

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