Folder Madness

[Kovenna]

Hi there,

I have built up a tree of hundreds of folders under my "InBox".
I'm now finding it next to impossible to find stuff by folder now because there does not appear to be a method of finding folders in Outlook as opposed to emails etc.

Is it possible to set up a search function whereby I type in say "Attix5 Setup" and it finds the folder and sets the focus to it, wherever it is buried within the tree?

Many thanks

[SamT]

See if this will help you
Jacob' VBA Tip #4 - Outlook Email Organization

[Kovenna]

Thanks Sam,

Phew - quite a bit of code to wade through. I'll check it out

[Charlize]

Kovenna,

Tried several things but for now, this one is the only one that more of less can find a folder based on a searchstring (partial even).

The pickfolder routine I was trying at first, doesn't give a possibility to define a folder to be highlighted by default.

Anyway, here the code that finds a subfolder based on a searchstring.

Sub Get_Sub_Folders()
    'declare some variables to use
    Dim myinbox As Folder, mynofolders As Long, myfoldername As String
    Dim foldersfound As Long, storefolder As String
    'set your inbox to myinbox
    Set myinbox = Application.Session.GetDefaultFolder(olFolderInbox)
    'set variable to zero
    foldersfound = 0
    'display number of subfolders of myinbox = your default inbox
    MsgBox myinbox.Folders.Count
    'give a searchstring, can be partial but needs to give unique folder
    myfoldername = InputBox("Give name ...", "Get folder ...")
    'loop through subfolders of inbox
    For mynofolders = 1 To myinbox.Folders.Count
        'compare given searchstring with foldername
        'if string is found then it must be greater than zero
        If InStr(1, myinbox.Folders(mynofolders).Name, myfoldername) > 0 Then
            'add 1 to foldersfound = to know if only one folders was found
            'with searchstring
            foldersfound = foldersfound + 1
            'display messagebox
            MsgBox "Folder <<< " & myinbox.Folders(mynofolders).Name & _
                   " >>>  located with search : " & myfoldername
            'store the name of the folder you found in a variable
            storefolder = myinbox.Folders(mynofolders).Name
        Else
            'if searchstring isn't found in the subfolder name, display mesage
            MsgBox myfoldername & " <> " & myinbox.Folders(mynofolders).Name
        End If
    'loop through all the subfolders of inbox
    Next mynofolders
    'if only one folder was found with searchstring, you found the folder
    If foldersfound = 1 Then
        MsgBox "Save to " & storefolder
    Else
    'if more, you need to give another searchstring to find a unique folder
        MsgBox "More folders found with searchstring : " & myfoldername
    End If
End Sub

Charlize

[Kovenna]

Hi Charlize,

Thanks for this. I created the module and it works as designed, so thank you very much for this.
However, I need to tweak it to do the following:

1. List all the results at one go, rather than having to click "ok" to see the next dialog
2. Show all the preceding folders back up to Inbox

For example, I asked for folders called "Meetings" - I think there are about 15 of them lol so I had to plough through each dialog noting them down.

The results screen needs to look like this as an example:

Inbox->Project 1->Meetings
Inbox->Manager->HR->Meetings
Inbox->Assignments->Local Govt->Halton BC->Meetings

etc etc

This then would be seriously helpful.

Obviously, I can hunt around and try and amend this myself now that you kindly got me started, but if you have any thoughts on how I might achieve the above, please let me know ;-)

Anyway, thanks once again

[Kovenna]

Hmmm. Actually, working through it line by line in the code its doesn't work lol
Just finds 20 folders under Inbox, then throws up 20 found dialogs even if not true. Chuckle.
I'm trying to correct it now...

[Kovenna]

Worked the problem and I think this is the answer - works a treat:

Sub CountAllFolders()
    Dim MyArray() As String
    ReDim MyArray(1)
    Dim MySearch As String
    Dim numfolders, numsubfolders As Long
    Dim ArrayElem As Integer
        
    ArrayElem = 1
    MySearch = InputBox("Enter the text to Search for", "Find folders")
    Set myNameSpace = Application.GetNamespace("MAPI")
    Set myinbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    '------------------------------------------------------------------------------------------------------
    For num1folders = 1 To myinbox.Folders.Count
        'Debug.Print "* " & myinbox.Folders(num1folders).Name
        If InStr(1, myinbox.Folders(num1folders).Name, MySearch) > 0 Then
            ReDim Preserve MyArray(UBound(MyArray) + 1)
            MyArray(ArrayElem) = "Inbox\" & myinbox.Folders(num1folders).Name
            'Debug.Print MyArray(ArrayElem)
            ArrayElem = ArrayElem + 1
        End If
        '-------------------------------------------
        Set Sub1Folder = myinbox.Folders(num1folders)
        For num2folders = 1 To Sub1Folder.Folders.Count
            'Debug.Print " -> " & Sub1Folder.Folders(num2folders).Name
            If InStr(1, Sub1Folder.Folders(num2folders).Name, MySearch) > 0 Then
            ReDim Preserve MyArray(UBound(MyArray) + 1)
                 MyArray(ArrayElem) = "Inbox\" & myinbox.Folders(num1folders).Name & "\" & Sub1Folder.Folders(num2folders).Name
                 'Debug.Print MyArray(ArrayElem)
                ArrayElem = ArrayElem + 1
            End If
            '-------------------------------------------
            Set sub2folder = Sub1Folder.Folders(num2folders)
                For num3folders = 1 To sub2folder.Folders.Count
                    'Debug.Print "   -> " & sub2folder.Folders(num3folders).Name
                    If InStr(1, sub2folder.Folders(num3folders).Name, MySearch) > 0 Then
                    ReDim Preserve MyArray(UBound(MyArray) + 1)
                        MyArray(ArrayElem) = "Inbox\" & myinbox.Folders(num1folders).Name & "\" & Sub1Folder.Folders(num2folders).Name & "\" & sub2folder.Folders(num3folders).Name
                        'Debug.Print MyArray(ArrayElem)
                        ArrayElem = ArrayElem + 1
                    End If
                    '---------------------------------------
                    Set sub3folder = sub2folder.Folders(num3folders)
                        For num4folders = 1 To sub3folder.Folders.Count
                            'Debug.Print "     ->" & sub3folder.Folders(num4folders).Name
                            If InStr(1, sub3folder.Folders(num4folders).Name, MySearch) > 0 Then
                            ReDim Preserve MyArray(UBound(MyArray) + 1)
                                MyArray(ArrayElem) = "Inbox\" & myinbox.Folders(num1folders).Name & "\" & Sub1Folder.Folders(num2folders).Name & "\" & sub2folder.Folders(num3folders).Name & "\" & sub3folder.Folders(num3folders).Name
                                'Debug.Print MyArray(ArrayElem)
                                ArrayElem = ArrayElem + 1
                            End If
                        '---------------------------------------
                        Next num4folders
                Next num3folders
        Next num2folders
    Next num1folders
    '--------------------------------------------------------------------
    ' Now display the list
    '--------------------------------------------------------------------
    For i = LBound(MyArray) To UBound(MyArray)
            msg = msg & MyArray(i) & vbNewLine
        Next i
    MsgBox "The folders with '" & MySearch & "' in them are:" & vbNewLine & msg
End Sub