PDA

View Full Version : [SOLVED:] Bulk creating rules Outlook 2013



Xav1050
12-01-2015, 12:13 AM
Hi,

I need to create +/- 250 move to folder-rules in Outlook 2013.
I found a VBA code on the Microsoft site but It's only to create 1 rule :


Sub CreateRule()

Dim colRules As Outlook.Rules

Dim oRule As Outlook.Rule

Dim colRuleActions As Outlook.RuleActions

Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction

Dim oFromCondition As Outlook.ToOrFromRuleCondition

Dim oExceptSubject As Outlook.TextRuleCondition

Dim oInbox As Outlook.Folder

Dim oMoveTarget As Outlook.Folder



'Specify target folder for rule move action

Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)

'Assume that target folder already exists

Set oMoveTarget = oInbox.Folders("Dan")



'Get Rules from Session.DefaultStore object

Set colRules = Application.Session.DefaultStore.GetRules()



'Create the rule by adding a Receive Rule to Rules collection

Set oRule = colRules.Create("Dan's rule", olRuleReceive)



'Specify the condition in a ToOrFromRuleCondition object

'Condition is if the message is sent by "DanWilson"

Set oFromCondition = oRule.Conditions.From

With oFromCondition

.Enabled = True

.Recipients.Add ("DanWilson")

.Recipients.ResolveAll

End With



'Specify the action in a MoveOrCopyRuleAction object

'Action is to move the message to the target folder

Set oMoveRuleAction = oRule.Actions.MoveToFolder

With oMoveRuleAction

.Enabled = True

.Folder = oMoveTarget

End With



'Specify the exception condition for the subject in a TextRuleCondition object

'Exception condition is if the subject contains "fun" or "chat"

Set oExceptSubject = _

oRule.Exceptions.Subject

With oExceptSubject

.Enabled = True

.Text = Array("fun", "chat")

End With



'Update the server and display progress dialog

colRules.Save

End Sub

I don't succeed to use a file as input (*.csv, *.xlsx or *txt) via a For Each method.
I found code to import appointments from .xlsx files but nothing to import rules...

My input file should look like this :

rule,from,folder
rule1,name-at-domain.com, folder1
rule2,name2-at-domain.com,folder2

Can you help me ?

Thank you,

Xavier

skatonni
12-01-2015, 03:58 PM
You can pull the information like this:


Option Explicit

Sub SplitTxtFile()

Dim hf As Integer
Dim lines() As String
Dim cols() As String
Dim i As Long
Dim j As Long
hf = FreeFile
Open "h:\test\test.txt" For Input As #hf
lines = Split(Input$(LOF(hf), #hf), vbNewLine)
Close #hf
Debug.Print
For i = 0 To UBound(lines)
Debug.Print "Line"; i; "="; lines(i)
cols = Split(lines(i), ",")
For j = 0 To UBound(cols)
Debug.Print " cols"; j; "="; cols(j)
Next j
Next i
End Sub


Instead of the j loop use your code. Replace the hardcoded text with cols(0), cols(1) and cols(2)

Xav1050
12-01-2015, 10:20 PM
Thank you Skatonni for your reply !

I pull your code but it seems to create only the rule which is the last line and not the previous ones.
What should I do to make the loop on all the lines ?
Thank you for your help !

Here is my code :


Option Explicit

Sub BulkRules()

Dim hf As Integer
Dim lines() As String
Dim cols() As String
Dim i As Long
Dim j As Long
hf = FreeFile
Open "C:\Users\Xavier\Desktop\testrule.txt" For Input As #hf
lines = Split(Input$(LOF(hf), #hf), vbNewLine)
Close #hf
Debug.Print
For i = 0 To UBound(lines)
Debug.Print "Line"; i; "="; lines(i)
cols = Split(lines(i), ",")
For j = 0 To UBound(cols)
Debug.Print " cols"; j; "="; cols(j)
Next j
Next i

Dim colRules As Outlook.Rules

Dim oRule As Outlook.Rule

Dim colRuleActions As Outlook.RuleActions

Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction

Dim oFromCondition As Outlook.ToOrFromRuleCondition

Dim oExceptSubject As Outlook.TextRuleCondition

Dim oInbox As Outlook.Folder

Dim oMoveTarget As Outlook.Folder



'Specify target folder for rule move action

Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)

'Assume that target folders already exists!!! --> Col3 = folder

Set oMoveTarget = oInbox.Folders(cols(2))



'Get Rules from Session.DefaultStore object

Set colRules = Application.Session.DefaultStore.GetRules()



'Create the rule by adding a Receive Rule to Rules collection --> col1 = RuleName

Set oRule = colRules.Create(cols(0), olRuleReceive)



'Specify the condition in a ToOrFromRuleCondition object

'Condition is if the message is sent by "From" --> Col2 = from

Set oFromCondition = oRule.Conditions.From

With oFromCondition

.Enabled = True

.Recipients.Add (cols(1))

.Recipients.ResolveAll

End With



'Specify the action in a MoveOrCopyRuleAction object

'Action is to move the message to the target folder

Set oMoveRuleAction = oRule.Actions.MoveToFolder

With oMoveRuleAction

.Enabled = True

.Folder = oMoveTarget

End With


'Specify the exception condition for the subject in a TextRuleCondition object

'Exception condition is if the subject contains "fun" or "chat"

'Set oExceptSubject = _

'oRule.Exceptions.Subject

'With oExceptSubject

'.Enabled = True

'.Text = Array("fun", "chat")

'End With



'Update the server and display progress dialog

colRules.Save

End Sub

skatonni
12-02-2015, 02:41 PM
I pull your code but it seems to create only the rule which is the last line and not the previous ones.
What should I do to make the loop on all the lines ?


As indicated. Put the code inside the I loop.


Sub BulkRules()

Dim hf As Integer
Dim lines() As String
Dim cols() As String
Dim i As Long
Dim j As Long
hf = FreeFile
Open "C:\Users\Xavier\Desktop\testrule.txt" For Input As #hf
lines = Split(Input$(LOF(hf), #hf), vbNewLine)
Close #hf
Debug.Print
For i = 0 To UBound(lines)
Debug.Print "Line"; i; "="; lines(i)
cols = Split(lines(i), ",")
For j = 0 To UBound(cols)
Debug.Print " cols"; j; "="; cols(j)
Next j
' your code here
Next I
End Sub

Xav1050
12-03-2015, 12:40 AM
Ok I'm a stupid noob!;-)
Thank you so much skatonni !!!

Here is the code for posterity...


Option Explicit

Sub BulkRulesCreate()

'Loop on the txt file containing the rules without field names:
'Rule1,example-at-domain.com,folder1,Exception1
'Rule2,example2-at-domain2.com,folder2,Exception2
'....

Dim hf As Integer
Dim lines() As String
Dim cols() As String
Dim i As Long
Dim j As Long
hf = FreeFile
Open "C:\Users\Xavier\Desktop\testrule.txt" For Input As #hf
lines = Split(Input$(LOF(hf), #hf), vbNewLine)
Close #hf
Debug.Print
For i = 0 To UBound(lines)
Debug.Print "Line"; i; "="; lines(i)
cols = Split(lines(i), ",")
For j = 0 To UBound(cols)
Debug.Print " cols"; j; "="; cols(j)
Next j

Dim colRules As Outlook.Rules
Dim oRule As Outlook.Rule
Dim colRuleActions As Outlook.RuleActions
Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
Dim oFromCondition As Outlook.ToOrFromRuleCondition
Dim oExceptSubject As Outlook.TextRuleCondition
Dim oInbox As Outlook.Folder
Dim oMoveTarget As Outlook.Folder

'Specify target folder for rule move action

Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)

'Assume that target folders already exists under Inbox !!! --> TargetFolder

Set oMoveTarget = oInbox.Folders(cols(2))

'Get Rules from Session.DefaultStore object

Set colRules = Application.Session.DefaultStore.GetRules()

'Create the rule by adding a Receive Rule to Rules collection --> RuleName

Set oRule = colRules.Create(cols(0), olRuleReceive)

'Specify the condition in a ToOrFromRuleCondition object

'Condition is if the message is sent by "From"

Set oFromCondition = oRule.Conditions.From

With oFromCondition

.Enabled = True

.Recipients.Add (cols(1))

.Recipients.ResolveAll

End With

'Specify the action in a MoveOrCopyRuleAction object

'Action is to move the message to the target folder

Set oMoveRuleAction = oRule.Actions.MoveToFolder

With oMoveRuleAction

.Enabled = True

.Folder = oMoveTarget

End With


'Specify the exception condition for the subject in a TextRuleCondition object

'Exception condition is if the subject contains "cols(3)" --> uncomment if necessary

'Set oExceptSubject = _

'oRule.Exceptions.Subject

'With oExceptSubject

'.Enabled = True

'.Text = Array(cols(3))

'End With

'Update the server and display progress dialog

colRules.Save

Next i
End Sub