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

Status
Not open for further replies.

reubendayal

Senior Member
Outlook version
Outlook 365 64 bit
Email Account
Office 365 Exchange
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,

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.
 
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.
 
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
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
P Auto assign shared mailbox Outlook VBA and Custom Forms 1
P Email address auto-completes work fine on laptop, but no longer on desktop Using Outlook 2
C New pc, new outlook, is it possible to import auto-complete emailaddress Using Outlook 4
R Outlook 365 VBA AUTO SEND WITH DELAY FOR EACH EMAIL Outlook VBA and Custom Forms 0
Nufc1980 Outlook "Please treat this as private label" auto added to some emails - Help. Using Outlook 3
K vba code to auto download email into a specific folder in local hard disk as and when any new email arrives in Inbox/subfolder Outlook VBA and Custom Forms 0
F Auto changing email subject line in bulk Using Outlook 2
T Outlook 2019 Not Using Auto Compete After Deletion of 365 Using Outlook 1
richardwing Auto forward email that is moves into a specific outlook folder Outlook VBA and Custom Forms 5
D Auto Remove [EXTERNAL] from subject - Issue with Macro Using Outlook 21
nmanikrishnan Auto-reply from default account Using Outlook 1
A Imap account not auto syncing inbox at startup Using Outlook 0
K Run a script rule to auto 'send again' on undeliverable emails? Outlook VBA and Custom Forms 1
FryW Need help modifying a VBA script for in coming emails to auto set custom reminder time Outlook VBA and Custom Forms 0
S Auto forward for multiple emails Outlook VBA and Custom Forms 0
DDB VBA to Auto Insert Date and Time in the signature Outlook VBA and Custom Forms 2
V Auto-complete stopped working Using Outlook 4
D auto forward base on email address in body email Outlook VBA and Custom Forms 0
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

Similar threads

Back
Top