VBA保存Outlook附件突发路径不存在运行时错误如何解决

问题现象 #

运行Outlook附件自动保存脚本时触发运行时错误：

无法保存附件，路径不存在，请验证路径正确性
报错固定触发于at.SaveAsFile开头的附件保存代码行。

已完成的基础排查：

• 路径变量fPat取值为"H:\VBA"，与历史正常运行时的配置完全一致
• H盘为服务器映射网络盘，可通过Windows文件资源管理器正常访问对应路径
• 重启电脑后故障仍未解决
• 脚本此前长期正常运行，无相关异常，为突发故障

问题复现代码 #

Sub Save_Outlook_Attachements_Calls()

Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim callfol As Outlook.Folder
Dim salefol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim at As Outlook.Attachment
Dim fPat As String
fPat = ThisWorkbook.Path

Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set FSO = CreateObject("Scripting.FileSystemObject")

Set callfol = ns.Folders("xxx.xxx@xxx.com").Folders("OutlookData").Folders("Calls")
    
For Each i In callfol.Items
    If i.Class = olMail Then
        Set mi = i
        If mi.Attachments.Count > 0 And Format(mi.ReceivedTime, "yyyy-mm-dd") = Format(Date, "yyyy-mm-dd") Then
            For Each at In mi.Attachments
                ' 报错触发行
                at.SaveAsFile (fPat & "\Outlookdata\calls\" & Date & "." & FSO.GetExtensionName(fPat & "\Outlookdata\calls\" & at.Filename))
            Next at
        End If
    End If
Next i
End Sub

可行排查与解决方案 #

按故障概率从高到低依次排查：

• 检查程序运行权限上下文
  如果你是用「以管理员身份运行」启动的Outlook或Excel，高权限会话和普通用户会话的网络盘符映射是完全隔离的，哪怕资源管理器里能正常访问H盘，高权限运行的VBA脚本也识别不到用户级挂载的映射盘，直接退出所有Office程序，用普通用户权限重新打开文件运行脚本即可。这是网络映射盘场景下该报错最高发的诱因。
• 修复路径拼接的逻辑错误
  现有代码的路径拼接存在3个明确问题，任意一个触发都会报路径不存在错误：
  1. 未校验子目录存在性：SaveAsFile方法不会自动创建不存在的目录，你当前拼接的目标路径是H:\VBA\Outlookdata\calls\，不要只确认H:\VBA存在，要手动确认这两级子目录真实存在，否则直接报错。
  2. 扩展名获取逻辑错误：你调用FSO.GetExtensionName时传入的是不存在的目标路径+附件名，会导致取到的扩展名为空，生成非法文件名。正确写法是直接传入附件本身的文件名取扩展名：FSO.GetExtensionName(at.FileName)
  3. 文件名含非法路径字符：系统默认Date函数返回的日期带/分隔符（如2024/05/20），/是Windows路径的保留分隔符，拼到文件名里会被程序识别为子目录层级，去找不存在的文件夹。之前能正常运行大概率是系统日期格式临时被修改，恢复默认格式后就会触发报错，需要显式指定日期格式为无斜杠的合法格式。
• 增加目录自动创建逻辑
  在执行保存操作前先判断目标目录是否存在，不存在则自动创建，从根源避免目录缺失问题，修正后的核心保存逻辑参考：

  ' 提前定义完整保存目录
  Dim saveDir As String
  saveDir = fPat & "\Outlookdata\calls\"
  ' 目录不存在则创建
  If Not FSO.FolderExists(saveDir) Then
      FSO.CreateFolder saveDir
  End If
  
  For Each at In mi.Attachments
      ' 修正日期格式、扩展名获取逻辑
      Dim saveFullPath As String
      saveFullPath = saveDir & Format(Date, "yyyy-mm-dd") & "." & FSO.GetExtensionName(at.FileName)
      at.SaveAsFile saveFullPath
  Next at
  

• 排查映射盘连接状态
  部分网络映射盘在开机后如果没有被手动访问过，会处于未激活的断开状态，脚本访问时会被识别为路径不存在，先在资源管理器中点进H盘触发网络重连，再运行脚本即可。如果该问题频繁出现，可以把路径改成UNC网络绝对路径（如\\你的服务器地址\共享目录名\VBA）代替H盘盘符映射，避免盘符连接失效的问题。

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