- In Outlook, enable macros. Click Tools > Macro > Security > Warnings for all macros (radio button) and OK. *Note: These steps will be slightly different if you are using Outlook 2010.
- In Outlook, open the Visual Basic Editor via Tools > Macro > Visual Basic Editor or ALT+F11.
- Once in the Editor go to Tools > References and select Microsoft Excel 12 Object Library (office 2007 – It will be Microsoft Excel 14 Object Library if you are using MS Outlook 2010). Click OK.
- Close the Editor and Outlook.
- Open Outlook again, go back into the Editor. Right-click Project 1, select Create Module (if module is not already there). Copy and paste all the code inside the module. You will find the code you need below.
- Make sure the .xls file is in C:/Outlook/ folder. If folder is not present, then create it.
- In the Editor, go to Run > Run Sub/User form or Click on F5 to run code.
This code can be downloaded from the project page.
Microsoft Library bb206765
1: 'Code written by David Gardner ------- [email protected]
2: 'v1.24b 01/23/2012
3: '
4: 'It is recommended that you backup your existing rules by using the export rules feature
5: '
6: ' In order for this code to work you must:
7: ' 1)In Outlook, enable macros. Click Tools > Macro > Security > Warnings for all macros (radio button) and OK.
8: ' *Note: These steps will be slightly different if you are using Outlook 2010.
9: ' 2) In Outlook, open the Visual Basic Editor via Tools > Macro > Visual Basic Editor or ALT+F11.
10: ' 3) Once in the Editor go to Tools > References and select Microsoft Excel 12 Object Library
11: ' (office 2007 – It will be Microsoft Excel 14 Object Library if you are using MS Outlook 2010).
12: ' Click OK.
13: ' 4) Close the Editor and Outlook.
14: ' 5) Open Outlook again, go back into the Editor. Right-click Project 1, select Create Module
15: ' (if module is not already there). Copy and paste all the code inside the module.
16: ' 6) Make sure the .xls file is in C:/Outlook/ folder. If folder is not present, then create it.
17: ' 7) In the Editor, go to Run > Run Sub/User form or Click on F5 to run code.
18:
19:
20:
21:
22: Sub Main()
23:
24: Dim arrData As Variant
25: Dim xlApp As Excel.Application
26: Dim xlWorkbook As Excel.Workbook
27:
28: Dim x As Integer 'Used to cycle trough the rows of the spreadsheet
29:
30: Dim colRules As Outlook.Rules
31: Dim oRule As Outlook.Rule
32: Dim colRuleActions As Outlook.RuleActions
33: Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
34: Dim oExceptSubject As Outlook.TextRuleCondition
35: Dim oIncludeSubject As Outlook.TextRuleCondition
36: Dim oSendersAddress As Outlook.AddressRuleCondition
37:
38: Dim oInbox As Outlook.Folder
39: Dim oMoveTarget As Outlook.Folder
40: Dim arrSubject() As String
41: Dim arrSendersAddress() As String
42: Dim arrExeptions() As String
43:
44:
45: ' Open up Excel but do not show it
46: Set xlApp = New Excel.Application
47: xlApp.Visible = False
48:
49: ' load the spreadsheet from the following location
50: Set xlWorkbook = xlApp.Workbooks.Open("c:\Outlook\rules.xls", ReadOnly = True)
51:
52: 'Specify the data range to be used
53: arrData = xlApp.Sheets("Sheet1").Range("A6").CurrentRegion.Value
54:
55: 'Dereference variables and Quit Excel
56: xlApp.Quit
57: Set xlWorkbook = Nothing
58: Set xlApp = Nothing
59:
60: 'Start from high to low so that alphabetical order is preserved
61: For x = UBound(arrData) To LBound(arrData) +1 Step -1
62:
63: 'remove any spaces from the beginning or the end of the string
64: arrData(x, 1) = Trim(arrData(x, 1))
65: arrData(x, 2) = Trim(arrData(x, 2))
66: arrData(x, 3) = Trim(arrData(x, 3))
67: arrData(x, 4) = Trim(arrData(x, 4))
68:
69: 'If folder doesn't exist create it and continue
70: If CheckForFolder(arrData(x, 1)) = False Then
71: Set MyFolder = CreateSubFolder(arrData(x, 1))
72: End If
73:
74: 'Specify target folder for rule move action
75: Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
76:
77: 'Set the target folder for the rule
78: Set oMoveTarget = oInbox.Folders(arrData(x, 1))
79:
80: 'Get Rules from Session.DefaultStore object
81: Set colRules = Application.Session.DefaultStore.GetRules()
82:
83:
84: '***********************************************
85: 'Create the Subjects Rule if both fields are not empty
86: If Len(arrData(x, 1)) > 0 Then
87: If Len(arrData(x, 2)) > 0 Then
88:
89: Set oRule = colRules.Create(arrData(x, 1) & "_S", olRuleReceive)
90:
91: 'Specify condition of containing words in subject
92: 'Obtain data in the second column of the spreadsheet and parse it
93: Set oIncludeSubject = oRule.Conditions.Subject
94: With oIncludeSubject
95: .Enabled = True
96: arrSubject = Split(arrData(x, 2))
97: .Text = arrSubject
98: End With
99:
100: 'Specify the action in a MoveOrCopyRuleAction object
101: 'Action is to move the message to the target folder
102: Set oMoveRuleAction = oRule.Actions.MoveToFolder
103: With oMoveRuleAction
104: .Enabled = True
105: .Folder = oMoveTarget
106: End With
107:
108: 'Specify the exception condition for the subject in a TextRuleCondition object
109: 'If the data in column 4 is not empty then parse words into the exeption field
110: If Len(arrData(x, 4)) > 0 Then
111: Set oExceptSubject = oRule.Exceptions.Subject
112: With oExceptSubject
113: .Enabled = True
114: arrExeptions = Split(arrData(x, 4))
115: .Text = arrExeptions
116: End With
117: End If
118: End If
119: End If
120: '********************************************************
121: 'Create the People rules if sendersAddress if present
122: If Len(arrData(x, 1)) > 0 Then
123: If Len(arrData(x, 3)) > 0 Then
124: Set oRule = colRules.Create(arrData(x, 1) & "_P", olRuleReceive)
125:
126: 'Specify the condition in a ToOrFromRuleCondition object
127: 'Condition is if the message is from "Dan Wilson"
128: Set oSendersAddress = oRule.Conditions.SenderAddress
129: With oSendersAddress
130: .Enabled = True
131: arrSendersAddress = Split(arrData(x, 3))
132: .Address = arrSendersAddress
133: End With
134:
135: 'Specify the action in a MoveOrCopyRuleAction object
136: 'Action is to move the message to the target folder
137: Set oMoveRuleAction = oRule.Actions.MoveToFolder
138: With oMoveRuleAction
139: .Enabled = True
140: .Folder = oMoveTarget
141: End With
142: End If
143: End If
144:
145: 'Update the server rules
146: colRules.Save
147:
148: 'Dereference the rest of the variables
149: Set oInbox = Nothing
150: Set oMoveTarget = Nothing
151:
152: Set colRules = Nothing
153: Set oRule = Nothing
154: Set oIncludeSubject = Nothing
155: Set oMoveRuleAction = Nothing
156: Set oExceptSubject = Nothing
157: Set oSendersAddress = Nothing
158:
159: Erase arrSubject
160: Erase arrSendersAddress
161:
162: Next x
163:
164: Erase arrData
165:
166:
167: End Sub
168:
169: Function CheckForFolder(ByVal strFolder As String) As Boolean
170: ' looks for subfolder of specified folder, returns TRUE if folder exists.
171: Dim olApp As Outlook.Application
172: Dim olNS As Outlook.NameSpace
173: Dim olInbox As Outlook.MAPIFolder
174: Dim FolderToCheck As Outlook.MAPIFolder
175:
176: Set olApp = Outlook.Application
177: Set olNS = olApp.GetNamespace("MAPI")
178: Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
179:
180: ' try to set an object reference to specified folder
181: On Error Resume Next
182: Set FolderToCheck = olInbox.Folders(strFolder)
183: On Error GoTo 0
184:
185: If Not FolderToCheck Is Nothing Then
186: CheckForFolder = True
187: End If
188:
189: ExitProc:
190: Set FolderToCheck = Nothing
191: Set olInbox = Nothing
192: Set olNS = Nothing
193: Set olApp = Nothing
194: End Function
195:
196: Function CreateSubFolder(ByVal strFolder As String) As Outlook.MAPIFolder
197: ' assumes folder doesn't exist, so only call if calling sub knows that
198: ' the folder doesn't exist; returns a folder object to calling sub
199: Dim olApp As Outlook.Application
200: Dim olNS As Outlook.NameSpace
201: Dim olInbox As Outlook.MAPIFolder
202:
203: Set olApp = Outlook.Application
204: Set olNS = olApp.GetNamespace("MAPI")
205: Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
206:
207: Set CreateSubFolder = olInbox.Folders.Add(strFolder)
208:
209: ExitProc:
210: Set olInbox = Nothing
211: Set olNS = Nothing
212: Set olApp = Nothing
213: End Function
