Results 1 to 2 of 2

Thread: Replicate Search Folder Functionality / Move Categories to Subfolders

  1. #1
    VBAX Newbie
    Jul 2020

    Replicate Search Folder Functionality / Move Categories to Subfolders

    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

  2. #2
    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 - - 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
        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
                GoTo GetCategories
            End If
        End If
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts