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

[reubendayal]

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:

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:

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.

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]

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:

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:

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.

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.

 

[Globalforester]

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.

 

[Globalforester]

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