Set Email catagories based on the folder name it's located in

[thommo]

Hi,
Sorry that this is such a blatant cry for help, but that's what it is!

I have hundreds of folders with names following the same format - prefix SFxxxx - Label name. So SF1234 - Project1, SF1235 - Project2 and so on. Hundreds of them.

These folders have Emails in them. Sometimes less than 10, sometimes less than 100.

I want to assign the category of all Emails under each folder, with the prefix of the folder name - so SFxxxx (left most 6 characters of folder name will work)

I have never done Outlook VBA - ever. But have done Excel numerous times.

Can anyone help tell me where to start? Like how to assign categories and recurse folders to do so on every item in each folder?

Huge thanks in advance for any help as I have to do this manually otherwise.

Alan

[gmayor]

The following should work. Try it on a sub folder with a few messages. The macro will prompt for the folder to start at and it will process that folder and the folders under it.

Option Explicit

Sub AddCategoryToSF()
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim SubFolder As Folder
Dim olNS As Outlook.NameSpace
    On Error Resume Next
    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.PickFolder
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1
        ProcessFolder olFolder
        For Each SubFolder In olFolder.folders
            cFolders.Add SubFolder
        Next SubFolder
    Loop
lbl_Exit:
    Set olFolder = Nothing
    Set SubFolder = Nothing
    Exit Sub
err_Handler:
    GoTo lbl_Exit
End Sub


Sub ProcessFolder(oFolder As Folder)
Dim i As Long
Dim olItem As Object
    'Debug.Print oFolder
    For i = 1 To oFolder.items.Count
        Set olItem = oFolder.items(i)
        If TypeName(olItem) = "MailItem" Then
            If olItem.Subject Like "SF*" Then
                olItem.Categories = Left(olItem.Subject, 6)
            End If
        End If
    Next i
lbl_Exit:
    Set olItem = Nothing
    Exit Sub
End Sub