Find a Folder Misplaced in Outlook - vba

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

Answer 1

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