Categorizing emails based on the subject

[Ludo]

Hi Everyone,

i am really new into VBA so I am sorry in advance if my questions are dumb

I am trying to write script to have a macro button. The goal is that I want to select a bunch of email, click on the macro button to run the script and have these email assigned to a category (in the same Inbox folder) based on initials found in the subject.

Here is my first attempt:

Public Sub autocategories()
    If InStr(Email.Subject, "[CAT1]",vbTextCompare) > 0 Then
        Email.Categories = CAT1
        Email.Save
    ElseIf InStr(Email.Subject, "[CAT2]",vbTextCompare) > 0 Then
        Email.Categories = CAT2
        Email.Save
    ElseIf InStr(1, Email.Subject, "[CAT3]", vbTextCompare) > 0 Then
        Email.Categories = CAT3
    End If
End Sub

However, when i click on the macro button, Nothing happens...
Can you please check this and let me know what I am doing wrong? Or is there any other way to have this function added?
We used to work with Oulook rules, but we have so many that our Exchange server cannot handle them all...

Many thanks in advance!

[gmayor]

The macro doesn't know what Email is. You need to tell it where to look.

Public Sub autocategories()
Dim olItem As Object
    For Each olItem In Application.ActiveExplorer.Selection
        If InStr(1, olItem.Subject, "[CAT1]", vbTextCompare) > 0 Then
            olItem.Categories = "CAT1"
        ElseIf InStr(1, olItem.Subject, "[CAT2]", vbTextCompare) > 0 Then
            olItem.Categories = "CAT2"
        ElseIf InStr(1, olItem.Subject, "[CAT3]", vbTextCompare) > 0 Then
            olItem.Categories = "CAT3"
        End If
         olItem.Save
       Next olItem
Set olItem = Nothing
End Sub

[Ludo]

I own you a beer this work perfectly!

Now an additional question if I may.
Is this possible to have this script running automatically for incoming emails?

[gmayor]

Duplicated

[gmayor]

You could run the AutoCategorize macro below as a script from a rule that applies to all incoming messages, but as you said you were reluctant to use a rule, you could add the following to the ThisOutlookSession module

Option Explicit

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
    lbl_Exit:
    Exit Sub
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)
    On Error GoTo ErrorHandler
    If TypeName(item) = "MailItem" Then
        AutoCategorize item
    End If
    lbl_Exit:
    Exit Sub
    ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub

In a normal module enter the modified version of the code below, then restart Outlook (or manually run Application_Startup) to activate the event.

Public Sub AutoCategorize(olItem As MailItem)
    With olItem
        If InStr(1, olItem.Subject, "[CAT1]", vbTextCompare) > 0 Then
            olItem.Categories = "CAT1"
            olItem.Save
        ElseIf InStr(1, olItem.Subject, "[CAT2]", vbTextCompare) > 0 Then
            olItem.Categories = "CAT2"
            olItem.Save
        ElseIf InStr(1, olItem.Subject, "[CAT3]", vbTextCompare) > 0 Then
            olItem.Categories = "CAT3"
            olItem.Save
        End If
    End With
    lbl_Exit:
    Exit Sub
End Sub

'Beers' can be delivered to my web site

[Ludo]

So Sorry I couldn't answer before, I have been overloaded at work!

I sent you a "beer" on your website.
Not sure how much you receive usually so I really hope it's not too low

Could you help me again please?
I did try your method to have the script running automatically, but it doesn't seems to work.
I sent a test email with the required initials in the subject but the email does not assign. Am I missing something? Ideally I'd like to have the same for the "Sent email", I guess same kind of script can be applied?

Thanks again for your support on this, you're a huge help!

[gmayor]

Hard to say what the problem is, but the search is case sensitive so using the example the subject would have to contain e.g. [CAT1]

If you make changes to the code, you would need to run Application_Startup again

If you want to run the process on mails you send then in the ThisOutlookSession module add the following. This is a built-in event so doesn't rely on the Application_Startup macro to work.

Private Sub Application_ItemSend(ByVal olItem As Object, Cancel As Boolean)
    With olItem
        If InStr(1, olItem.Subject, "[CAT1]", vbTextCompare) > 0 Then
            olItem.Categories = "CAT1"
            olItem.Save
        ElseIf InStr(1, olItem.Subject, "[CAT2]", vbTextCompare) > 0 Then
            olItem.Categories = "CAT2"
            olItem.Save
        ElseIf InStr(1, olItem.Subject, "[CAT3]", vbTextCompare) > 0 Then
            olItem.Categories = "CAT3"
            olItem.Save
        End If
    End With
lbl_Exit:
    Exit Sub
End Sub

[Ludo]

Ok, for the sent item I could make it run automatically, I am starting to get the logic. Thanks for that!

But for the emails received, I actually receive the following error when I restart outlook:

"Compile error:
Invalid attribute in Sub or Function"

Also, the following part of the script is highlighted
"...WithEvents Items As Outlook.Items"

Any idea?

[Ludo]

and one last question (i Hope!)
I could manage to point the macro to the item I wanted (subject, sender, body, ...) but is it possible to make it point to the file name of an attached email?
i was expecting to have something like:

ElseIf InStr(1, olItem.Attachemnts, "[CAT1]", vbTextCompare) > 0 Then
    olItem.Categories = "[CAT1]"
    olItem.Save

But it doesn't seems to work and I couldn't find anything else on Google. Would you have any good address where to look that kind of stuff for my knowledge?

[gmayor]

Is the With Events line at the top of the ThisOutlookSession module (before the macros, but after Option Explicit if present)?

e.g.

Option Explicit

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    'etc

as for the attachments you will need to loop through the attachments collection e.g.

For i = 1 To olItem.Attachments.Count
    If InStr(1, olItem.Attachments(i).fileName, "[CAT1]", vbTextCompare) > 0 Then
        olItem.Categories = "CAT1"
        olItem.Save
        Exit For
    End If
Next i

[Ludo]

I copy pasted it at the top of the ThisOutlookSession.
the error message is gone now, but it still doesn't run automatically...

Regarding the attachement, this portion of code can be part of my main code?
Like:

Public Sub autocategories()
Dim olItem As Object
    For Each olItem In Application.ActiveExplorer.Selection
        If InStr(1, olItem.Subject, "[cat1]", vbTextCompare) > 0 Then
            olItem.Categories = "CAT1"
        ElseIf InStr(1, olItem.Subject, "[cat2]", vbTextCompare) > 0 Then
           olItem.Categories = "CAT2"
           For i = 1 To olItem.Attachments.Count
               If InStr(1, olItem.Attachments(i).fileName, "[CAT1]", vbTextCompare) > 0 Then
                   olItem.Categories = "CAT1"
                   olItem.Save
                   Exit For
               End If
          Next i
         olItem.Save
    Next olItem
    Set olItem = Nothing
End Sub

Or should it be part of a different macro?

[Ludo]

hey, any feedback for me?

[Aussiebear]

Maybe try this method

Sub SortEmailsByCategory()
    Dim objOutlook As Object
    Dim objInbox As Object
    Dim objEmail As Object
    Dim objFolder As Object
    Dim strCategory As String
    ' Create an Outlook Application object
    Set objOutlook = CreateObject("Outlook.Application")
    ' Get the Inbox folder
    Set objInbox = objOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    ' Loop through each email in the Inbox
    For Each objEmail In objInbox.Items
        ' Get the category of the email
        strCategory = objEmail.Categories
        ' Check if the email has a category
        If Len(strCategory) > 0 Then
            ' Create the target folder if it doesn't exist
            On Error Resume Next
            Set objFolder = objInbox.Folders(strCategory)
            On Error GoTo 0
            If objFolder Is Nothing Then
                Set objFolder = objInbox.Folders.Add(strCategory)
            End If
            ' Move the email to the category folder
            objEmail.Move objFolder
        End If
    Next objEmail
    ' Clean up
    Set objEmail = Nothing
    Set objFolder = Nothing
    Set objInbox = Nothing
    Set objOutlook = Nothing
End Sub