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