Outlook Rules VBA, to Bypass Exchange’s Rule Limit
Custom Outlook Rules VBA to Bypass Exchange’s 32K rule limit. Add entries to the array returned by Jam_GetRules to add more rules. The first element of each array is a comma-delimited list of properties to check To, From, and/or Subject. The second element is a regular expression supported by Microsoft’s VBScript RegEx class. The third element is a folder to move the item to.
Note that when using Exchange, the address is not example@example.com, but a path containing the user’s domain ID. The rule will also test against the Proper Name associated with the address.
Public WithEvents myOlItems As Outlook.Items
Private Sub Application_Startup()
Jam_Init
End Sub
Private Sub Jam_Init()
Set myOlItems = Outlook.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Function Jam_GetRules()
Jam_GetRules = Array( _
Array("To,From", "domainId", "AP"), _
Array("To,From", "jacob", "IT"), _
Array("Subject", "(approval chg|Ticket #)", "Help Desk"), _
Array("Subject", "weekly job postings", "HR") _
)
End Function
Private Sub myOlItems_ItemAdd(ByVal item As Object)
Jam_ItemAdd item
End Sub
Private Sub Jam_ItemAdd(ByRef item As Object)
' Check to make sure it is an Outlook mail message, otherwise
' subsequent code will probably fail depending on what type
' of item it is.
If TypeName(item) = "MailItem" Then
Jam_HandleMailItem item
End If
End Sub
Private Sub Jam_ProcessInbox()
Dim item As MailItem
For Each item In Outlook.Session.GetDefaultFolder(olFolderInbox).Items
Jam_HandleMailItem item
Next
End Sub
Private Sub Jam_HandleMailItem(ByRef item As MailItem)
Dim itemRecipients: Set itemRecipients = item.Recipients
Dim itemTo: itemTo = Jam_AddressListToString(item.Recipients, "Address", ",")
For Each rule In Jam_GetRules
Dim ruleProps: ruleProps = Split(rule(0), ",")
Dim rulePattern: rulePattern = rule(1)
Dim folderName: folderName = rule(2)
For Each p In ruleProps
Dim toTest: toTest = ""
Select Case p
Case "To"
toTest = itemTo
Case "Subject"
toTest = item.subject
Case "From"
toTest = item.SenderName & " <" & item.SenderEmailAddress & ">"
End Select
If RE_TestInsensitive(toTest, rulePattern) Then
' perform action
' item.Move (MAPIFolder)
Dim folder
Set folder = Jam_GetFolder(folderName)
If Not folder Is Nothing Then
'MsgBox "move " & item.subject & " to " & folderName
item.Move (folder)
Exit For
End If
End If
Next
Next
End Sub
Private Function Jam_AddressListToString(ByRef list, ByVal prop, ByVal delim)
Dim rtn: rtn = Array()
For Each item In list
Array_Append rtn, CStr(item.name & " <" & item.Address & ">")
Next
Jam_AddressListToString = Join(rtn, delim)
End Function
Public Function Jam_GetFolder(ByVal folderName As String) As MAPIFolder
Set Jam_GetFolder = Jam_GetFolderHelper(folderName, _
Outlook.Session.GetDefaultFolder(olFolderInbox))
End Function
Private Function Jam_GetFolderHelper(ByVal folderName As String, ByRef parent As MAPIFolder) As MAPIFolder
Set Jam_GetFolderHelper = Nothing
Dim f As MAPIFolder, rtnFolder As MAPIFolder
For Each f In parent.Folders
If f.name = folderName Then
Set Jam_GetFolderHelper = f
Exit Function
End If
Next
For Each f In parent.Folders
Set rtnFolder = Jam_GetFolderHelper(folderName, f)
If Not rtnFolder Is Nothing Then
Set Jam_GetFolderHelper = rtnFolder
Exit Function
End If
Next
End Function
''
' Appends a value onto the end of an array.
' @param myList The target array
' @param myItem The item to Array_Append
' @todo Add support for appending objects
Function Array_Append(ByRef myList, ByRef myItem)
If Not IsArray(myList) Then
Exit Function
End If
ReDim Preserve myList(UBound(myList) + 1)
myIndex = UBound(myList)
If IsObject(myItem) Then
Set myList(myIndex) = myItem
Else
myList(myIndex) = myItem
End If
Array_Append = myList
End Function
''
' Performs global test
' @return Returns true if pattern matches string
'
Function RE_Test(ByVal str, ByVal pattern, ByVal caseSensitive)
Dim reBase: Set reBase = CreateObject("VBScript.RegExp")
reBase.pattern = pattern
reBase.IgnoreCase = Not caseSensitive
RE_Test = reBase.Test(str)
Set reBase = Nothing
End Function
''
' Tests wehther a string matches a pattern case-insensitively
Function RE_TestInsensitive(ByVal str, ByVal pattern)
RE_TestInsensitive = RE_Test(str, pattern, False)
End Function
