VBA script - Categorizing emails based on the subject

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!

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

Code:

---

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

---

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?

Duplicated :banghead:

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

Code:

---

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.

Code:

---

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 :)

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!

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.

Code:

---

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

---

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?

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:

Code:

---

        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?

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

e.g.

Code:

---

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.

Code:

---

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

---

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:

Code:

---

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?

hey, any feedback for me?