与 Exchange 服务器的连接断开时出错后继续处理 ItemAdd 事件

Question

我有 Outlook VBA 代码等待邮件到达 Groupmailbox。

它处理数千封电子邮件，然后与 Exchange 服务器的连接断开，触发错误并停止处理。

我添加到子目录中希望跳过当前电子邮件并继续处理。

On Error GoTo endProc
endProc:

这消除了错误，但 VBA 代码终止，我必须关闭并打开 Outlook 才能继续常规操作。

如何说服 Outlook 继续？

Private WithEvents olInboxItems As Items
 
Private Sub Application_Startup()
    Dim objNS As NameSpace
    Set objNS = Application.Session
    Set olInboxItems = GetFolderPath("GROUPMAILBOX\Inbox").Items
    Set objNS = Nothing
End Sub
 
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
    On Error GoTo endProc
    
    ~some VBA mumbojumbo
 
endProc:

End Sub

Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
      
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function
    
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
    
End Function

Answer 1

如果错误被捕获，错误处理程序可以触发

Application_Startup

。

目的是重新初始化

olInboxItems

。

Option Explicit

Private WithEvents olInboxItems As Items

Private Sub Application_Startup()

    Dim folderPath As String
    Dim olFolder As folder
    
    folderPath = "GROUPMAILBOX\Inbox"
    Debug.Print "folderPath: " & folderPath
    
    On Error Resume Next
    Set olFolder = GetFolderPath(folderPath)
    On Error GoTo 0
    
    If Not olFolder Is Nothing Then
        Debug.Print "Found: " & folderPath
        Set olInboxItems = olFolder.Items
    Else
        Debug.Print "Not found: " & folderPath
    End If
        
End Sub


Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

    On Error GoTo endProc
    
    Err.Raise 1
    
    Exit Sub
    
endProc:

    ' A handled error can trigger Application_Startup
    Debug.Print "Err.Number     : " & Err.Number
    Debug.Print "Err.Description: " & Err.Description
    Application_Startup
    
End Sub


Function GetFolderPath(ByVal folderPath As String) As folder

    ' https://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
    
    Dim oFolder As folder
    Dim foldersArray As Variant
    Dim i As Long
    
    On Error GoTo GetFolderPath_Error
    If Left(folderPath, 2) = "\\" Then
        folderPath = Right(folderPath, Len(folderPath) - 2)
    End If
    
    'Convert folderpath to array
    foldersArray = Split(folderPath, "\")
    Set oFolder = Session.Folders.Item(foldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(foldersArray, 1)
            Dim subFolders As Folders
            Set subFolders = oFolder.Folders
            Set oFolder = subFolders.Item(foldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function
    
GetFolderPath_Error:
    Set GetFolderPath = Nothing
 
End Function