Finding Folder

First, let me start out by saying that I did post this question in the MrExcel forum, but am posting it on here because VBAExpress has a specific Outlook forum.

I have this code below which helps me find a folder based on a search string. However, I am looking to improve the code in 2 ways. 1) The ability to type a partial name of the folder and still get results and 2) For all the results to be listed and then the option to select which folder I want to go into.

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

To use a partial search change the line

Code:

---

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

---

to

Code:

---

If LCase(SubFolder.Name) Like "*" & LCase(Name) & "*" Then

---

This will give you the first item that matches your entered string

If you are going to start listing matching items, you might as well just use the PickFolder command to select the folder you require, which is altogether a much easier option.

You could confirm the folder is the one you want before leaving the search.

Code:

---

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 FoundFolder = FindInFolders(Application.Session.Folders, Name)
   
If Not FoundFolder Is Nothing Then
    'If MsgBox("Activate Folder: " & vbCrLf & FoundFolder.FolderPath, vbQuestion Or vbYesNo) = vbYes Then
        Set Application.ActiveExplorer.CurrentFolder = FoundFolder
    '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
    Debug.Print SubFolder.Name
   

    If LCase(SubFolder.Name) Like "*" & LCase(Name) & "*" Then
   
        If MsgBox("Activate Folder: " & vbCrLf & SubFolder.FolderPath, vbQuestion Or vbYesNo) = vbYes Then
            Set FindInFolders = SubFolder
            Exit For
        Else
            ' If folder is rejected act as if it was never suggested.
            GoTo nextFolder
        End If
       
    Else
   
nextFolder:
        Set FindInFolders = FindInFolders(SubFolder.Folders, Name)
        If Not FindInFolders Is Nothing Then Exit For
    End If
Next
End Function

---

Not a list to choose from, this offers up one folder at a time to confirm.

When crossposting try to leave a link so everyone knows the status.

Thanks!

Those responses were both brilliant and it does help me out a lot. I have a bad habit of naming folders, making subfolder and then not being able to find the folders.

To follow-up 1) Can I make the search specific to a single pst file? 2) Is there a way to get this search into the move option? So when I right-click an email and select Move can there be a search option in that section, that will then allow me to find the folder and move the email there?

Thanks.

You can address any store that is open in Outlook - see my reply a couple of minutes ago to http://www.vbaexpress.com/forum/show...t-to-copy-mail

Code:

---

Private Sub MoveToFolderByName()
Dim Name As String
Dim FoundFolder As Folder
Name = InputBox("Find Name:", "Search Folder")
If Len(Trim$(Name)) = 0 Then Exit Sub
'Set FoundFolder = FindInFolders(Application.Session.Folders, Name)
Set FoundFolder = FindInFolders(Application.Session.Folders("name of pst").Folders, Name)
If Not FoundFolder Is Nothing Then
    ActiveExplorer.Selection(1).move FoundFolder
Else
    MsgBox "Not Found", vbInformation
End If
End Sub

---