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 with 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 language is 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