Assigning categories to all e-mail in folder tree using VBA

I have a very large mail store with a deeply-nested folder structure that I wish to flatten out by leveraging the power of categories/tags.  Given that I do not wish to manually assign tags discretely for each-and-every legacy e-mail, I would like to write some VBA enabling me to:

- highlight a selected folder
- input one or more categories
- have specified categories assigned to all e-mails underneath the selected folder

Going forward, I will use rules to automatically assign categories for all new mail as it is received.
Lloyd CharlierChief Executive OfficerAsked:
Who is Participating?
 
Chris BottomleyConnect With a Mentor Software Quality Lead EngineerCommented:
IN regard to the prompt and then running it down through the sub folders how about this?

Chris
Sub allTheseFolders()
Dim cat As String
 
    On Error Resume Next
    cat = InputBox("Enter the category string", "Apply Category to all Subfolders")
    pf_allFoldersCat Application.ActiveExplorer.CurrentFolder, cat
 
End Sub
Sub pf_allFoldersCat(startFolder As MAPIFolder, cat As String)
Dim fldr As Outlook.MAPIFolder
Dim objItem As Object
'Dim mai As mailitem
    On Error Resume Next
    
    ' process all the subfolders of this folder
    For Each fldr In startFolder.folders
        Call pf_allFoldersCat(fldr, cat)
    Next
    
    For Each objItem In startFolder.items
        If objItem.Type = olMail Then
            AddCat objItem, cat
        End If
    Next
'Set mai = Nothing
Set fldr = Nothing
End Sub

Open in new window

0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Hello SpatiaX,

Place the following code in a normal code module and execute allFolders.

This will cycle around every folder and for each sub folder in outlook it will ask for the categories to be assigned.  For each folder that category will be added to every message in teh folder.  Please let me know how it goes or any changes to my assumptions.

Regards,
Chris
Sub allFolders()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim myfolder As Outlook.MAPIFolder
Dim strStoresItem As Variant
    
    On Error Resume Next
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    For Each strStoresItem In Application.Session.Stores
        Set myfolder = objns.GetFolderFromID(strStoresItem.StoreID)
        pf_allFolders myfolder
    Next
 
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Sub pf_allFolders(startFolder As MAPIFolder)
Dim fldr As Outlook.MAPIFolder
Dim objItem As Object
Dim cats As String
Dim arrCats() As String
    On Error Resume Next
    
    ' process all the subfolders of this folder
    For Each fldr In startFolder.folders
        Call pf_allFolders(fldr)
    Next
    cats = InputBox("Enter COMMA SEPERATED list of categories to add to folder " & vbCrLf & startFolder.FolderPath, "Auto Add Categories")
    arrCats = Split(cats, ",")
    For Each objItem In startFolder.items
        If objItem.Type = olMail Then
            AddCat objItem, arrCats
        End If
    Next
'Set mai = Nothing
Set fldr = Nothing
End Sub
 
 
Sub AddCat(mai, arrcat As Variant)
Dim catCOunt As Integer
Dim blnChanged As Boolean
Dim maiCats() As String
Dim catstring As String
Dim dictCats As Object
Dim arrCats As Variant
Dim strAdd As String
    
    Set dictCats = CreateObject("scripting.dictionary")
    maiCats = Split(mai.CAtegories, ",")
    If UBound(maiCats) >= 0 Then
        For catCOunt = 0 To UBound(maiCats)
            strAdd = Trim(maiCats(catCOunt))
            If Not dictCats.Exists(LCase(strAdd)) Then dictCats.Add LCase(strAdd), strAdd
        Next
    End If
    If UBound(arrcat) >= 0 Then
        For catCOunt = 0 To UBound(arrcat)
            strAdd = Trim(arrcat(catCOunt))
            If Not dictCats.Exists(LCase(strAdd)) Then
                dictCats.Add LCase(strAdd), strAdd
                blnChanged = True
            End If
        Next
    End If
    If blnChanged Then
        arrCats = dictCats.items
        mai.CAtegories = ""
        For catCOunt = 0 To UBound(arrCats)
            If mai.CAtegories = "" Then
                mai.CAtegories = CStr(arrCats(catCOunt))
            Else
                mai.CAtegories = mai.CAtegories & ", " & CStr(arrCats(catCOunt))
            End If
        Next
        mai.Save
    End If
End Sub

Open in new window

0
 
Lloyd CharlierChief Executive OfficerAuthor Commented:
Chris,

Sorry it took so long to reply - I've been swamped with work the past ten days or so.

Your piece of code works well but it doesn't quite work the way I need it to.  It appears that, in its current form, the code walks the entire mail store and prompts for categories to assign at each level of folder nesting.  Given the size and complexity of my mail store (1000's of folders - I know, I'm working to get rid of them!), it it possible to instead have the program begin execution only on the folder currently selected (and down) and not have it prompt for at each sub-folder level?  Ideally, I would like to highlight a top-level folder, for example, "Customers", and assign a category that is subsequently applied to every e-mail underneath that folder, regardless of how many levels of sub-folders exist.  I then might highlight one of the sub-folders and assign additional categories that are to added to whatever categories already exist for those e-mails below this point - and so on...
0
Cloud Class® Course: CompTIA Healthcare IT Tech

This course will help prep you to earn the CompTIA Healthcare IT Technician certification showing that you have the knowledge and skills needed to succeed in installing, managing, and troubleshooting IT systems in medical and clinical settings.

 
Chris BottomleySoftware Quality Lead EngineerCommented:
Should be easy enough ... add the following sub to work with pf_allFolders

Chris
Sub allTheseFolders()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim myfolder As Outlook.MAPIFolder
Dim strStoresItem As Variant
    
    On Error Resume Next
    Set olkApp = Outlook.Application
    Set objns = olkApp.GetNamespace("MAPI")
    pf_allFolders Application.ActiveExplorer.CurrentFolder
 
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub

Open in new window

0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Sorry missed about the prompt ... what do you want - a category entered the first time and then use that category for all the folders in teh slected folder structure?

Chris
0
 
Lloyd CharlierChief Executive OfficerAuthor Commented:
Just what I needed - thanks Chris!
0
 
Lloyd CharlierChief Executive OfficerAuthor Commented:
Chris,

The code you authored really helped wrap my head around what I ultimately was trying to achieve.  In case anyone is curious, after playing around a bit with different approaches, I eventually embellished the core code so that it could be launched from the Outlook folder context menu and when selected, the macro spawns a userform modeled after Outlook's native Category form.  The result of this effort is that I can now easily select any folder and add/replace/clear any combination of categories for all mail items underneath the selected top-level folder - all from one dialog.  I have attached a screenshot for illustration.
OutlookFolderCategorize.jpg
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Looks like you have extended the core code into something that is very specific to your needs and I hope satisfying for you to have done some of the work yourself.

THanks for the grade
Chris
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.