scripts for create rules for special folder in Outlook 2016

[angel_if]

Hi all. I have some problem wirh VBScript .I want to write a script that creates folders and then creates rules for these folders and I do not want that the code would be so long (more then 1.5 k). Vbscripts do not support OOP. Someone can help? I have 26 folder and for all needs rule.



SubCreateRule() 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 oSubjectCondition 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).Folders.Item("Folder")

'Assume that target folder already exists
Set oMoveTarget = oInbox.Folders("subfolder")

'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("subfolder_rule", olRuleReceive)

'Specify the exception condition for the subject in a TextRuleCondition object
'Exception condition is if the subject contains "fun" or "chat"
Set oSubjectCondition = _
oRule.Conditions.Subject
With oSubjectCondition
.Enabled = True
.Text = Array("hello")
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

'Update the server and display progress dialog
colRules.Save
End Sub

[skatonni]

With the assumption folder name and the word in the subject are the same:



Option Explicit

Private Sub CreateRulesUsingArray()

Dim colRules As rules
Dim oRule As Rule

Dim colRuleActions As RuleActions
Dim oMoveRuleAction As MoveOrCopyRuleAction
Dim oFromCondition As ToOrFromRuleCondition

Dim oSubjectCondition As TextRuleCondition
Dim oExceptSubject As TextRuleCondition

Dim oInbox As Folder
Dim oInboxRuleFolder As Folder

Dim oMoveTarget As Folder

Dim ruleFldrStr As String
Dim subfolderStr As String

Dim i As Long

Dim subjectFolderArray() As Variant

subjectFolderArray = Array("hello", "test", "stuff", "important")

'Specify target folder for rule move action
Set oInbox = Session.GetDefaultFolder(olFolderInbox)

ruleFldrStr = "Folder for move by rule"
On Error Resume Next
' bypass error if folder already exists
oInbox.Folders.Add (ruleFldrStr)
' remove error bypass immediately after purpose is served
On Error GoTo 0

Set oInboxRuleFolder = oInbox.Folders(ruleFldrStr)

For i = LBound(subjectFolderArray) To UBound(subjectFolderArray)

' DoEvents is not very useful here
' Outlook is unusable when saving rules
DoEvents

subfolderStr = subjectFolderArray(i)
Debug.Print subfolderStr

On Error Resume Next
' bypass error if subfolder already exists
oInboxRuleFolder.Folders.Add (subfolderStr)
' remove error bypass immediately after purpose is served
On Error GoTo 0
Set oMoveTarget = oInboxRuleFolder.Folders(subfolderStr)
Debug.Print "Folder available: " & oMoveTarget

'Get Rules from Session.DefaultStore object
Set colRules = Session.DefaultStore.GetRules()

On Error Resume Next
' bypass error if rule does not exist
Debug.Print "Removing: " & subfolderStr & "_rule"
colRules.Remove (subfolderStr & "_rule")
' remove error bypass immediately after purpose is served
On Error GoTo 0

'Create the rule by adding a Receive Rule to Rules collection
'Set oRule = colRules.Create("subfolder_rule", olRuleReceive)
Set oRule = colRules.Create(subfolderStr & "_rule", olRuleReceive)

'Specify the condition for the subject in a TextRuleCondition object
Set oSubjectCondition = oRule.Conditions.Subject
With oSubjectCondition
.Enabled = True
'.text = Array("hello")
.text = Array(subfolderStr)
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

'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

' DoEvents is not very useful here
' Outlook is unusable when saving rules
DoEvents

'Update the server
' Found this had to be done inside the loop
Debug.Print "Saving: " & subfolderStr & "_rule"
colRules.Save

Next

Debug.Print "Done " & Now

End Sub