Outlook选定邮件随机保存失败问题求助（附VBA代码）

我用以下VBA代码导出Outlook选定邮件已经好几年了：

Option Explicit
Public Sub SaveMessageAsMsg()
  On Error Resume Next
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String

   For Each objItem In ActiveExplorer.Selection
    Err.Clear
    If objItem.MessageClass = "IPM.Note" Then
        Set oMail = objItem

        sName = oMail.Subject
        ReplaceCharsForFileName sName, "-"

        dtDate = oMail.ReceivedTime
        sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
                vbUseSystem) & Format(dtDate, "-hhnnss", _
                vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

        sPath = "D:\Data\ml\"
        Debug.Print sPath & sName
        oMail.SaveAs sPath & sName, olMSG  
    End If
  Next
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

现在这段代码会在导出随机数量的.msg文件后停止运行，我猜测是某个错误导致程序退出。于是我修改了错误处理逻辑，修改后的代码如下：

Option Explicit
Public Sub SaveMessageAsMsg()
  On Error GoTo ErrorContinue
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String

   For Each objItem In ActiveExplorer.Selection
    Err.Clear
    If objItem.MessageClass = "IPM.Note" Then
        Set oMail = objItem

        sName = oMail.Subject
        ReplaceCharsForFileName sName, "-"

        dtDate = oMail.ReceivedTime
        sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
                vbUseSystem) & Format(dtDate, "-hhnnss", _
                vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

        sPath = "D:\Data\ml\"
        Debug.Print sPath & sName
        oMail.SaveAs sPath & sName, olMSG
ErrorContinue:
    Resume Next
    
    End If
  Next
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

我的Outlook版本是2308（内部版本16731.20504 点击运行）。如果从失败的位置重新运行代码，之前导出失败的邮件又能正常导出，看起来不是特定邮件的问题。移除错误恢复语句后，弹出的错误窗口没有Debug选项，只有“确定”和“帮助”按钮。

解决办法 #

1. 修正错误处理逻辑 #

你修改后的错误处理标签位置错误，导致循环流程被打断。正确的写法应该把错误控制限定在单个邮件处理周期内，同时记录错误信息方便排查：

Option Explicit
Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String

   For Each objItem In ActiveExplorer.Selection
    On Error Resume Next ' 仅当前循环项启用错误恢复
    Err.Clear
    If objItem.MessageClass = "IPM.Note" Then
        Set oMail = objItem

        sName = oMail.Subject
        ReplaceCharsForFileName sName, "-"

        dtDate = oMail.ReceivedTime
        sName = Format(dtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
                vbUseSystem) & Format(dtDate, "-hhnnss", _
                vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"

        sPath = "D:\Data\ml\"
        ' 确保目标文件夹存在
        If Dir(sPath, vbDirectory) = "" Then MkDir sPath
        
        Debug.Print sPath & sName
        oMail.SaveAs sPath & sName, olMSG
        
        ' 短暂延迟避免Outlook API限制
        Application.Wait Now + TimeValue("00:00:01")
    End If
    ' 记录错误信息
    If Err.Number <> 0 Then
        Debug.Print "处理失败: " & Err.Description & " | 邮件主题: " & objItem.Subject
        Err.Clear
    End If
    On Error GoTo 0 ' 关闭错误恢复
  Next
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

2. 启用调试模式 #

要让错误窗口出现Debug选项，需要调整Outlook宏安全设置：

• 打开Outlook → 文件 → 选项 → 信任中心 → 信任中心设置 → 宏设置
• 选择「通知我所有宏」，并勾选「信任对VBA工程对象模型的访问」
• 重启Outlook后再运行代码，错误弹窗会显示Debug按钮

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