Automated outlook rules

The attached file (see download link provided) can be used for creating rules in MS Outlook by filling in the information in the chart, which will filter your emails based on key words in the subject line OR the sender's email domain (@yahoo.com, @davgar.com, etc), and makes exceptions for keywords you want to avoid being filtered. To use this file, follow the steps below.

1. 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.
2. In Outlook, open the Visual Basic Editor via Tools > Macro > Visual Basic Editor or ALT+F11.
3. 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.
4. Close the Editor and Outlook.
5. 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.
6. Make sure the .xls file is in C:/Outlook/ folder. If folder is not present, then create it.
7. In the Editor, go to Run > Run Sub/User form or Click on F5 to run code.

Thank you JPSoftware for folder creation code taken from here.

This code can be downloaded from the project page.

   1:  'Code written by David Gardner ------- davgar@gmail.com

   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) 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) & "_Subject", 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) & "_People", 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