保存选定的 Outlook 电子邮件随机失败

Question

我使用此代码多年，从 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

现在它在导出随机数量的消息文件后停止。我认为有一个错误导致它退出。因此我将其更改如下（不是错误处理程序）：

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

版本为 2308（内部版本 16731.20504 即点即用）。

如果我在失败的地方重新启动，该电子邮件就会导出。任何电子邮件似乎都没有什么特别之处。

如果我删除错误恢复，则通常的“调试”选项不会显示在弹出窗口中。只有“确定”和“帮助”按钮。

Answer 1

无论是什么原因，这都应该处理

上的任何错误

oMail.SaveAs sPath & sName, olMSG

Option Explicit

Public Sub SaveMessageAsMsg_ErrorWithoutDebugDialog()
    
    Dim oMail As MailItem
    
    Dim sPath As String
    Dim sName As String
    Dim sPathName As String
    
    Dim dtDate As Date
    Dim i As Long
    
    Dim retryFlag As Boolean
    
    Dim selItems As selection
    
    Dim errNum As Long
    Dim errDesc As String
    
retry:
    
    Set selItems = ActiveExplorer.selection
    Debug.Print "selItems.count: " & selItems.count
            
    retryFlag = False
    
    For i = selItems.count To 1 Step -1
    
        If selItems(i).MessageClass = "IPM.Note" Then
                
            Set oMail = selItems(i)
            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\"
            
            ' This error would generate the usual debug dialog.
            'sPath = sPath & "NoFolder\"        ' To test the bypass
            Debug.Print sPath
            
            sPathName = sPath & sName
            Debug.Print sPathName
            
            ' Applicable in rare circumstances, when the error is known and expected.
            On Error Resume Next
            oMail.SaveAs sPathName, olMsg
                        
            ' Risky extra lines in the error bypass.
            errNum = Err.Number
            errDesc = Err.Description
                        
            '  Remove error bypass as soon as the purpose is served
            On Error GoTo 0
                        
            Debug.Print " errNum.: " & errNum
            Debug.Print " errDesc: " & errDesc
                        
            If errDesc = "" Then
                ' Success
                ActiveExplorer.RemoveFromSelection oMail
                DoEvents
                Debug.Print " Success. Item removed from selection."
                                
            Else
                ' Failure
                retryFlag = True
                Debug.Print " Failure. Item remains selected."
                
            End If
            
        End If
        
    Next
    
    If retryFlag = True Then
        If MsgBox("Retry", vbYesNo) = vbYes Then
            GoTo retry
        End If
    End If
    
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