in Programming |

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.

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
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