Find Folder Misplaced in Outlook

[nandeotifur]

I am currently trying to modify some code to be able to find a folder that may have been moved in error within Outlook 2013. I am a beginner at VBA coding(Outlook Macros), and want to see if this may be possible.

Premise:

User has multiple mailboxes, pst files and public/shared mailboxes.
User has multiple Folders named the same (eg "\\emailaddress\Inbox\Monthly Review" and "\\2014\Monthly Review")
User trying to locate moved folder to put back to original location

Issues:

Current code accepts Boolean search but stops at first instance of folder ("\\emailaddress\Inbox\Monthly Review")
Also, script seems to only be able to run effectively while Outlook is in work offline mode. When Outlook is online, it freezes the Outlook session until you cancel server requests.

Anyone have an idea as to how to fix these two issues? Trying to get this when you hit no as to the folder location prompt it goes to the next folder matching the context until search is exhausted or you select yes for the proper folder. Work offline issue is not to important, more of a feature creep I guess.



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


Thanks in advance to all who wish to contribute their advice.

[nandeotifur]

Adding this code as a separate process helps



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



Trying to see though how to integrate into initial code as it breaks focus of activating folder if I call as a function. I am still looking to see how to enumerate instances of items found in case user has multiple similar folder names.


I am currently trying to modify some code to be able to find a folder that may have been moved in error within Outlook 2013. I am a beginner at VBA coding(Outlook Macros), and want to see if this may be possible.

Premise:

User has multiple mailboxes, pst files and public/shared mailboxes.
User has multiple Folders named the same (eg "\\emailaddress\Inbox\Monthly Review" and "\\2014\Monthly Review")
User trying to locate moved folder to put back to original location

Issues:

Current code accepts Boolean search but stops at first instance of folder ("\\emailaddress\Inbox\Monthly Review")
Also, script seems to only be able to run effectively while Outlook is in work offline mode. When Outlook is online, it freezes the Outlook session until you cancel server requests.

Anyone have an idea as to how to fix these two issues? Trying to get this when you hit no as to the folder location prompt it goes to the next folder matching the context until search is exhausted or you select yes for the proper folder. Work offline issue is not to important, more of a feature creep I guess.



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


Thanks in advance to all who wish to contribute their advice.