I as well as several of my colleagues have had an ongoing problem where we get bombarded with hundreds if not thousands of emails each day which come from automated services, such as SQL DBmail and other similar mechanisms. Many of these notifications are not really important to look at, and they are almost always sent to large mailing lists. A bit like this... ;-)
Many of us have so many Outlook rules that we have exceeded the maximum amount of rules permitted. Running all those rules on all incoming mail is slow and can bog down Outlook. So I have decided to write this script which can be ran as the top-most rule and will allow us to turn off most of the other rules. I tested it and it works good, and is way faster than having so many rules.
I have written comments throughout to help my colleagues edit the script for their own needs (e.g. different folder names, or slightly different filtering criteria). I have formatted it in such a way that hopefully will look familiar to a user whose primary familiarity is with SQL.
I don't write VBA very often, and this is my first Outlook VBA attempt, so I would like to improve it in any way possible. Here is the code, keep in mind everything is contained in the same module.
'Make all text matching case-Insensitive
'To make case-Sensitive change to: Option Compare Binary
Option Compare Text
'No implicit variables allowed:
Option Explicit
Sub FilterMailItems(item As Outlook.mailItem)
'This is to be used largely for notifications from SQL and other
'automated notifications, which notifications are not necessarily important
'to look at in the immediate and can be archived.
Dim recip As Recipient
For Each recip In item.Recipients
'Filter for RECIPIENTS (e.g. mailing group)
If ( _
InStr(recip.Name, "intdev") > 0 _
) _
Then
'Filter for SENDER:
If ( _
InStr(item.SenderName, "SQLAdmin") > 0 _
Or InStr(item.SenderName, "intdev") > 0 _
) _
Then
'Exceptions to NOT handle and skip:
'IMPORTANT: use the Not operator!
If ( _
Not InStr(item.Subject, "Supplies") > 0 _
And Not InStr(item.Subject, "Referral") > 0 _
) _
Then
'Filters for MISC items:
'NOTE: use as precise of a match as possible to make this work best:
If ( _
InStr(item.Subject, "QueryDatabases") > 0 _
Or InStr(item.Subject, "has processed a file") > 0 _
Or InStr(item.Subject, "Transaction Cleanup") > 0 _
) _
Then
'Folder to move MISC items to:
MarkReadAndMoveToFolder item, "_MiscDump"
'Filters for ERROR items:
ElseIf ( _
InStr(item.Subject, "error") > 0 _
Or InStr(item.Subject, "exception") > 0 _
Or InStr(item.Subject, "failure") > 0 _
) _
Then
'Folder to move ERROR items to:
MarkReadAndMoveToFolder item, "_ErrorDump"
End If
'If not matching any above conditions, then leave alone
End If
End If
End If
Next recip
End Sub
Private Function MarkReadAndMoveToFolder(item As Outlook.mailItem, destination As String) As Boolean
'Set up Outlook application and inbox variables
Dim nameSpace As Outlook.nameSpace
Dim inbox As Outlook.Folder
Dim destFolder As Outlook.Folder
Set nameSpace = Application.GetNamespace("MAPI")
Set inbox = nameSpace.GetDefaultFolder(olFolderInbox)
Set destFolder = inbox.Folders(destination)
'Mark as read and move to destination folder in inbox
item.UnRead = False
item.Move destFolder
End Function
