Auto Assign Category colours to Incoming Emails based on whom the email is addressed

reubendayal

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Exchange Server 2013
Hi All,

I am trying to auto assign colour categories (which are based on team members in my team) on all Incoming emails to our shared mailbox. I've used the tips available on this slipstick thread - Processing Incoming E-mails with Macros but the code doesn't seem to fire as planned. I am going the VBA route as with rules the actions are a bit limited. Another challenge with rules is that I will need to write a script for the rule to fire and categorize the email based on who the sender is addressing it to.

One other issue I also see is that this code is made to work on a shared mailbox. But for some reason that could be creating a challenge. Perhaps my code which I have put in ThisOutlookSession, needs correction.

Here's what I have on the top of ThisOutlookSession:

Code:
Option Explicit

Public RegularStartup As Boolean
Private WithEvents Items As Outlook.Items
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents As Boolean
Private objNS As Outlook.NameSpace
Dim i As Long
Private WithEvents olInboxItems As Items
Dim oReply As MailItem
Dim MyCuFolder As Outlook.MAPIFolder

Where mainly it is the 2nd line of Private "WithEvents Items As Outlook.Items" is what I am using as per the slipstick page's advise.

Further in the code for the application startup contains a few things as I am using it for other macros as well:

Code:
Public Sub Application_Startup()
If RegularStartup = False Then

    Set Items = Session.GetDefaultFolder(olFolderSentMail).Items
    Set oExpl = Application.ActiveExplorer
    
    bDiscardEvents = False
    'MsgBox "Done!"

ElseIf RegularStartup = True Then
    
Dim objMyInbox As Outlook.MAPIFolder
Set objNS = Application.GetNamespace("MAPI")

Set objMyInbox = objNS.GetDefaultFolder(olFolderInbox)
Set Items = objMyInbox.Items
Set objMyInbox = Nothing
    
    Set Items = Session.GetDefaultFolder(olFolderSentMail).Items
    Set oExpl = Application.ActiveExplorer
    
    bDiscardEvents = False
    RegularStartup = False
    MsgBox "Application Startup - Restarted!"
    
End If
End Sub

And then the ItemAdd event to do the things I am trying to achieve.

Code:
Private Sub Items_ItemAdd(ByVal Item As Object)
'Ensure we are only working with e-mail items

Dim EmlItem As MailItem
Dim EmlBody As String
Dim EmlSubj As String
'Dim MyFolder As Folder
If Item.Class <> OlMail Then Exit Sub

Set EmlItem = Item
MsgBox EmlItem.Subject

If LCase(InStr(EmlItem.Subject, "re:")) Or _
    LCase(InStr(EmlItem.Subject, "fw:")) Then

Exit Sub

EmlBody = EmlItem.Body

'If InStr(EmlSubj, "Welcome to Deloitte" & vbCrLf & vbCrLf & "Maersk Immigration Services") Then

    If LCase(InStr(EmlBody, "dear anne")) Or _
        LCase(InStr(EmlBody, "dear anna")) Or _
        LCase(InStr(EmlBody, "hi anne")) Or _
        LCase(InStr(EmlBody, "hi anna")) Then _
        Item.Categories = "Anne"
    ElseIf LCase(InStr(EmlBody, "dear reuben")) _
        Or LCase(InStr(EmlBody, "dear rueben")) _
        Or LCase(InStr(EmlBody, "hi reuben")) _
        Or LCase(InStr(EmlBody, "hi reuben")) _
        Or LCase(InStr(EmlBody, "dear ruben")) _
        Or LCase(InStr(EmlBody, "hi ruben")) _
        Then Item.Categories = "Reuben"
    End If
    
Set EmlItem = Nothing

End Sub

Any help is appreciated!

Thank you so much.
 

reubendayal

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Exchange Server 2013
Hi All,

I am trying to auto assign colour categories (which are based on team members in my team) on all Incoming emails to our shared mailbox. I've used the tips available on this slipstick thread - Processing Incoming E-mails with Macros but the code doesn't seem to fire as planned. I am going the VBA route as with rules the actions are a bit limited. Another challenge with rules is that I will need to write a script for the rule to fire and categorize the email based on who the sender is addressing it to.

One other issue I also see is that this code is made to work on a shared mailbox. But for some reason that could be creating a challenge. Perhaps my code which I have put in ThisOutlookSession, needs correction.

Here's what I have on the top of ThisOutlookSession:

Code:
Option Explicit

Public RegularStartup As Boolean
Private WithEvents Items As Outlook.Items
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents As Boolean
Private objNS As Outlook.NameSpace
Dim i As Long
Private WithEvents olInboxItems As Items
Dim oReply As MailItem
Dim MyCuFolder As Outlook.MAPIFolder

Where mainly it is the 2nd line of Private "WithEvents Items As Outlook.Items" is what I am using as per the slipstick page's advise.

Further in the code for the application startup contains a few things as I am using it for other macros as well:

Code:
Public Sub Application_Startup()
If RegularStartup = False Then

    Set Items = Session.GetDefaultFolder(olFolderSentMail).Items
    Set oExpl = Application.ActiveExplorer
   
    bDiscardEvents = False
    'MsgBox "Done!"

ElseIf RegularStartup = True Then
   
Dim objMyInbox As Outlook.MAPIFolder
Set objNS = Application.GetNamespace("MAPI")

Set objMyInbox = objNS.GetDefaultFolder(olFolderInbox)
Set Items = objMyInbox.Items
Set objMyInbox = Nothing
   
    Set Items = Session.GetDefaultFolder(olFolderSentMail).Items
    Set oExpl = Application.ActiveExplorer
   
    bDiscardEvents = False
    RegularStartup = False
    MsgBox "Application Startup - Restarted!"
   
End If
End Sub

And then the ItemAdd event to do the things I am trying to achieve.

Code:
Private Sub Items_ItemAdd(ByVal Item As Object)
'Ensure we are only working with e-mail items

Dim EmlItem As MailItem
Dim EmlBody As String
Dim EmlSubj As String
'Dim MyFolder As Folder
If Item.Class <> OlMail Then Exit Sub

Set EmlItem = Item
MsgBox EmlItem.Subject

If LCase(InStr(EmlItem.Subject, "re:")) Or _
    LCase(InStr(EmlItem.Subject, "fw:")) Then

Exit Sub

EmlBody = EmlItem.Body

'If InStr(EmlSubj, "Welcome to Deloitte" & vbCrLf & vbCrLf & "Maersk Immigration Services") Then

    If LCase(InStr(EmlBody, "dear anne")) Or _
        LCase(InStr(EmlBody, "dear anna")) Or _
        LCase(InStr(EmlBody, "hi anne")) Or _
        LCase(InStr(EmlBody, "hi anna")) Then _
        Item.Categories = "Anne"
    ElseIf LCase(InStr(EmlBody, "dear reuben")) _
        Or LCase(InStr(EmlBody, "dear rueben")) _
        Or LCase(InStr(EmlBody, "hi reuben")) _
        Or LCase(InStr(EmlBody, "hi reuben")) _
        Or LCase(InStr(EmlBody, "dear ruben")) _
        Or LCase(InStr(EmlBody, "hi ruben")) _
        Then Item.Categories = "Reuben"
    End If
   
Set EmlItem = Nothing

End Sub

Any help is appreciated!

Thank you so much.
Hi All,

Anyone that could help with the above?

Thank you.
 
Outlook version
Outlook 2010 64 bit
Email Account
IMAP
Maybe I have picked this up wrong but I would start with something simple like this in ThisOutlookSession:
Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items

Private Sub Application_Startup()
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Set objWatchFolder = objNS.Folders(.......) 'the folder to watch
Set objItems = objWatchFolder.Items
Set objWatchFolder = Nothing
End Sub

Private Sub objItems_ItemAdd(ByVal Item As Object)
Dim EntryID As String
With Item
'use Entry ID so long as the item is not moved to another folder by a rule
EntryID = .EntryID
'Call a public macro by passing the EntryID
End With
End Sub

Then have a simple macro that then processes the email according to the content.
 
Outlook version
Outlook 2010 64 bit
Email Account
IMAP
Haven't checked if this works but perhaps the macro could be something like:

Public Sub ProcessEmail(EntryID As String)
Dim objNS As Outlook.NameSpace
Set objNS = Application.GetNamespace("MAPI")
Dim mailItem As Outlook.mailItem
Set mailItem = objNS.GetItemFromID(EntryID) 'seems not to need StoreID
Dim strSubject As String
Dim strSenderName As String
Dim strSenderEmail As String
Dim strRecTime As String
Dim strBody As String
Dim myStr() As String
Dim MsgLStr As String
Dim l As Long

On Error GoTo ProcessEmailErr

'set variables
With mailItem
strSubject = .Subject
strSenderName = .SenderName
strSenderEmail = .SenderEmailAddress
strRecTime = CDate(.ReceivedTime)
strBody = .Body
End With

'Step 1 - Check if relevant message or can do the check in Items_ItemAdd
If InStr(strSubject, "Welcome to Deloitte" & vbCrLf & vbCrLf & "Maersk Immigration Services") > 0 Then
myStr = Split(strBody, vbLf)
For l = LBound(myStr) To UBound(myStr)
MsgLStr = lcase(myStr(l))
If Left(MsgLStr, 10) = "hi anne" Then ' can do checks on the first part whether hi or dear or perhaps check if the first line contains the name?
mailItem.Categories = "Anna"
mailItem.Save
Set objNS = Nothing
Set mailItem = Nothing
Exit sub
End If
Next l
Else
'stop processing
Set objNS = Nothing
Set mailItem = Nothing
Exit Sub
End If

Exit Sub

ProcessEmailErr:
MsgBox "ProcessEmailError #: " & Err.Number & vbCrLf & Err.Description
End Sub
 
Similar threads
Thread starter Title Forum Replies Date
P Auto assign shared mailbox Outlook VBA and Custom Forms 1
M Replyall macro with template and auto insert receptens Outlook VBA and Custom Forms 1
R Auto Forwarding with different "From" Outlook VBA and Custom Forms 0
P auto-complete is hopelessly broken Using Outlook 0
C Auto Run VBA Code on new email Outlook VBA and Custom Forms 1
S Outlook Macro to send auto acknowledge mail only to new mails received to a specific shared inbox Outlook VBA and Custom Forms 0
V Auto-Submitted: auto-replied in header Using Outlook 0
R Auto display of new email does not work on non-default account Outlook VBA and Custom Forms 0
B Outlook 2016 Auto-archive creates new folder Using Outlook 3
J Edit auto-complete list in Outlook 2016+/365? Using Outlook 0
M Outlook 2010 Problem with OutLook 2010 32 bit, after Windows Auto Update Using Outlook 3
P [SOLVED] Auto remove [EXTERNAL] from subject Using Outlook 16
Z Add text to auto-forwarded e-mail Outlook VBA and Custom Forms 4
N Disable Auto Read Receipts sent after using Advanced Find Using Outlook 4
Q Prompt button to auto turn on Out of Office Outlook VBA and Custom Forms 3
P Auto Insert Current Date or Time into Email Subject Outlook VBA and Custom Forms 2
S Messages moved / deleted by auto-archive are not synchronized to exchange Exchange Server Administration 8
B Outlook 2010 is Auto Purging when not configured for that Using Outlook 1
M VBA to auto forward message with new subject and body text Outlook VBA and Custom Forms 8
A Auto Accept Meetings from the General Calendar Using Outlook 3
R auto send email when meeting closes from a shared calendar only Outlook VBA and Custom Forms 2
S auto-mapping mailboxes in outlook impacting an ost file? Exchange Server Administration 2
M Auto expand Distribution List Before Sending Email Outlook VBA and Custom Forms 1
M Auto-export mail to Excel Outlook VBA and Custom Forms 2
Ms_Cynic Auto-pasting email content in calendar appt? Using Outlook 2
R How Do I insert images in and Auto Reply Using Outlook 3
S Received mail as part of DL, need to auto-CC the same when replying Outlook VBA and Custom Forms 5
T Have Outlook 2016 suggest email address auto complete entries directly from the user's contacts list Using Outlook 10
T Have Outlook 2016 suggest email address auto complete entries directly from the user's contacts list Using Outlook 0
P Auto scroll to specific folder in Folder Pane Outlook VBA and Custom Forms 3
C Auto categorize duplicate subjects Outlook VBA and Custom Forms 11
N Auto-complete - block select emails Using Outlook 3
C Auto save outlook attachments when email is received Outlook VBA and Custom Forms 1
J HELP- Rule to auto strip prepend from external emails Using Outlook 0
S BCM Auto Backup Data and Customizations BCM (Business Contact Manager) 6
G Auto accept meeting request for non primary account Outlook VBA and Custom Forms 1
J Outlook Rules - Changing auto-submit address in multiple rules, according to rule name Outlook VBA and Custom Forms 0
E Outlook Form - Voting Responses Not Auto Processing If Form Contains Any Code Outlook VBA and Custom Forms 0
J Auto Forward - Include Attachment and change Subject depending on original sender Outlook VBA and Custom Forms 3
K Extract email address from body and auto-reply outlook Using Outlook 1
S Auto move search results to folder Outlook VBA and Custom Forms 0
E Outlook 2010 disable date auto-complete Using Outlook 2
C Auto subject,name,email,deferred Using Outlook 2
ashcosta2 Auto Reply rule based on speficied time Outlook VBA and Custom Forms 0
B Auto Preview Attachment in Inspector Reading Pane Outlook VBA and Custom Forms 1
Z Auto Forward Using Outlook 4
M can anyone recommend an alternative to DS auto-followup? Using Outlook 2
S Rules to auto redirect Using Outlook 5
B Auto Save of Attachments from Multiple Emails and forward attachments to user group Outlook VBA and Custom Forms 1
A Auto Insert of filename when selecting 'Remove Attachment' Using Outlook 1

Similar threads

Top