查找 Outlook 中放错位置的文件夹

Question

我目前正在编写 Outlook 中的 VBA 代码以作为宏运行，该宏将帮助查找从主邮箱、辅助邮箱甚至存档邮箱 (PST) 错误移动的文件夹。

当前运行时的代码将离线切换 Outlook，询问您的文件夹名称（可以部分作为通配符搜索），返回找到的名称的第一个实例并带您到文件夹，最后将 Outlook 恢复到在线模式。

我正试图找出让它迭代所有搜索实例的过程（例如，主邮箱和档案中名为“April”的多个文件夹）。我知道它可能需要一个 do until 循环并指定一个计数器，但不确定如何实现。

这是当前的工作代码：

Sub ToggleWorkOfflineMode()
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
If Not OutApp.Session.Offline = True Then
If MsgBox("Do you want to enable Work Offline Status?", vbQuestion Or vbYesNo) = vbYes Then
OutApp.GetNamespace("MAPI").Folders.GetFirst.GetExplorer.CommandBars.FindControl(, 5613).Execute
Else
MsgBox "Status Not Changed.", vbInformation
End If
Else
If MsgBox("Do you Want to disable Work Offline Status?", vbQuestion Or vbYesNo) = vbNo Then
MsgBox "Working offline", vbInformation
Else
OutApp.GetNamespace("MAPI").Folders.GetFirst.GetExplorer.CommandBars.FindControl(, 5613).Execute
End If
End If
End Sub
Sub FindFolderByName()
    Dim Name As String
    Dim FoundFolder As Folder

    Name = InputBox("Find Name:", "Search Folder")
    If Len(Trim$(Name)) = 0 Then Exit Sub

    Set FoundFouder = FindInFolders(Application.Session.Folders, Name)

    If Not FoundFouder Is Nothing Then
        If MsgBox("Activate Folder: " & vbCrLf & FoundFouder.FolderPath, vbQuestion Or vbYesNo) = vbYes Then
            Set Application.ActiveExplorer.CurrentFolder = FoundFouder
        End If
    Else
        MsgBox "Not Found", vbInformation
    End If
End Sub
Function FindInFolders(TheFolders As Outlook.Folders, Name As String)
    Dim SubFolder As Outlook.MAPIFolder

    On Error Resume Next

    Set FindInFolders = Nothing

    For Each SubFolder In TheFolders
        If LCase(SubFolder.Name) Like LCase(Name) Then
            Set FindInFolders = SubFolder
            Exit For
        Else
            Set FindInFolders = FindInFolders(SubFolder.Folders, Name)
            If Not FindInFolders Is Nothing Then Exit For
        End If
    Next
End Function

Answer 1

在离开 FindInFolders 函数之前验证是否已找到文件夹。

Sub FindFolderByName()

    Dim Name As String
    Dim FoundFolder As Folder

    Name = InputBox("Find Name:", "Search Folder")
    If Len(Trim$(Name)) = 0 Then Exit Sub

    ' Session.Folders is too broad
    ' With Toggle Offline you probably have it narrowed down
    '  to the folders you are interested in.
    Set FoundFolder = FindInFolders(Session.Folders, Name)

    ' Alternatives are PickFolder and hardcoding the folder
    'Set FoundFolder = FindInFolders(Session.GetDefaultFolder(olFolderInbox).Folders, Name)

    If FoundFolder Is Nothing Then
        ' Move the confirmation inside the function
        ' so the search does not end prematurely
         MsgBox "Not Found", vbInformation
    End If

    Set FoundFolder = Nothing

    Debug.Print "Done."

End Sub

Function FindInFolders(TheFolders As Outlook.Folders, Name As String)

    'Dim SubFolder As Outlook.MAPIFolder
    Dim SubFolder As Folder ' 2007 and subsequent

    'On Error Resume Next
    ' Only for a specific purpose and followed closely by
    'On Error GoTo 0

    Set FindInFolders = Nothing

    For Each SubFolder In TheFolders
        ' Stay online to see
        '  the many unfamiliar folders in Session.Folders
         Debug.Print " - " & SubFolder

        If LCase(SubFolder.Name) Like LCase(Name) Then

            Set FindInFolders = SubFolder
            Set ActiveExplorer.CurrentFolder = FindInFolders

            If MsgBox("Activate Folder: " & vbCrLf & FindInFolders.FolderPath, vbQuestion Or vbYesNo) = vbYes Then
                Exit For
            End If

        Else

            Set FindInFolders = FindInFolders(SubFolder.Folders, Name)
            If Not FindInFolders Is Nothing Then Exit For

        End If

    Next

End Function