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

[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