Replicate Search Folder Functionality / Move Categories to Subfolders

[tfarrell]

I used categories to organize my mail at work (by client). My number of of search folders is capped at 10 which is far less than the number of clients I have. I've tried a number of different resources for recreating the functionality of a search with VBA (ie, moving categorized mail to a corresponding subfolder), but nothing I have found works. All of my category names have corresponding subfolders with the same name. I'm imagining a scenario where it pulls the category name as a string then moves to a subfolder with that same string. Ideally, it would move each mail to its folder when it is categorized. I do have mail with multiple categories, so not sure that is causing issues?

My VBA experience is limited to basic Excel. For some reason Outlook feels more challenging. I'm apparently limited to # of URLs I can post as a new member so I can't share what I've looked at, but I've tried a number of different threads on this site and stackexchange.

Does anyone have other suggestions to look at or a possible solution?

I'm on Outlook 2013

[gmayor]

What I suspect you are looking for is something like the following. The macro runs on the selected message and determines whether it has categories. If it does it moves a copy of the message to a folder bearing the category name that is a subfolder of Inbox. If the folder doesn't exist it is created. If there is no category it prompts for one then moves the message to the category named folder (or creates that folder, if it doesn't exist). The original message is then deleted.


Sub MoveMessageToCategoryFolder()
'Graham Mayor - https://www.gmayor.com - Last updated - 06 Aug 2020
Dim olMsg As Object, objCopy As Object
Dim vCategory As Variant
Dim strFolder As String
Dim olFolder As Folder, olSubFolder As Folder
Dim i As Integer
Dim bFound As Boolean

On Error Resume Next
Select Case Outlook.Application.ActiveWindow.Class
Case olInspector
Set olMsg = ActiveInspector.currentItem
Case olExplorer
Set olMsg = Application.ActiveExplorer.Selection.Item(1)
End Select

GetCategories:
If TypeName(olMsg) = "MailItem" Then
Set olFolder = Session.GetDefaultFolder(olFolderInbox)
If olMsg.Categories <> "" Then
vCategory = Split(olMsg.Categories, ",")
For i = 0 To UBound(vCategory)
bFound = False
strFolder = Trim(vCategory(i))
For Each olSubFolder In olFolder.folders
If olSubFolder.Name = strFolder Then
Set objCopy = olMsg.Copy
objCopy.Move olSubFolder
bFound = True
Exit For
End If
Next olSubFolder
If Not bFound Then
Set olSubFolder = olFolder.folders.Add(strFolder)
Set objCopy = olMsg.Copy
objCopy.Move olSubFolder
End If
Next i
Else
olMsg.ShowCategoriesDialog
GoTo GetCategories
End If
olMsg.Delete
End If
lbl_Exit:
Exit Sub
End Sub