scripts for create rules for special folder in Outlook 2016

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.

HTML Code:

---

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


---

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

Code:

---

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

---