Find a Folder Misplaced in Outlook

Question

I am currently working on a VBA code in Outlook to run as a macro that will help find a folder that was moved in error from the main mailbox, secondary mailbox or even archive mailbox (PST).

Currently the code when ran will toggle outlook offline, ask you for the folder name(which can be partial as wildcard search is implemented), returns the first instance found of the name and takes you to the folder and finally restores Outlook to online mode.

I am trying to figure out the process to have it iterate all instances of the search (ex. Multiple folders with the name "April" within primary mailbox and archives). I know it may require a do until loop with a counter specified but am unsure how to implement.

Here is the current working code:

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

Take out the `Exit For` statements in `FindInFolders` and put the results in some sort of collection container instead. — Comintern, Mar 29 '16 at 23:21
To search "Multiple folders with the name "April" within primary mailbox" then separately "Multiple folders with the name "April" within archives. http://stackoverflow.com/questions/27189429/searching-for-a-folder-in-outlook-folders-multiple-outcomes — niton, Mar 30 '16 at 01:33
@niton with the code provided in the link, macro fails with "Object Required" when inside Loopfolders Sub at If Not MyFolder Is Nothing Then Exit For — Matt, Mar 30 '16 at 20:37

score 0 · Accepted Answer · answered Apr 12 '16 at 20:12

Verify whether the folder has been found before leaving the FindInFolders function.

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

Find a Folder Misplaced in Outlook

1 Answers1