Consulting

Results 1 to 2 of 2

Thread: scripts for create rules for special folder in Outlook 2016

  1. #1
    VBAX Newbie
    Joined
    Jan 2019
    Posts
    1
    Location

    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
    
    Last edited by angel_if; 01-03-2019 at 08:19 AM.

  2. #2
    VBAX Mentor skatonni's Avatar
    Joined
    Jun 2006
    Posts
    347
    Location
    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
    To debug, mouse-click anywhere in the code. Press F8 repeatedly to step through the code. http://www.cpearson.com/excel/DebuggingVBA.aspx

    If your problem has been solved in your thread, mark the thread "Solved" by going to the "Thread Tools" dropdown at the top of the thread. You might also consider rating the thread by going to the "Rate Thread" dropdown.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •