Macro to bulk create Outlook rules from CSV file

Copper Contributor

I am new to Outlook VBA and have struggled for a day now to write a macro that creates rules from a CSV file in a shared mailbox with the trigger for Body or Subject in column 1 and the path to the folder to move the message to in column 2. I have the following code that runs OK but does not add any rules. Could someone please identify my errors?

PowerShell I cannot use due to organization's network restrictions.

Sub ImportRulesFromCSVTest()

Dim sharedMailboxName As String
sharedMailboxName = "email address removed for privacy reasons"

Dim olApp As Outlook.Application
Set olApp = Outlook.Application

Dim olNamespace As Outlook.NameSpace
Set olNamespace = olApp.GetNamespace("MAPI")

Dim olRecipient As Outlook.Recipient
Set olRecipient = olNamespace.CreateRecipient(sharedMailboxName)
olRecipient.Resolve

Dim olStore As Outlook.Store
Set olStore = olNamespace.GetSharedDefaultFolder(olRecipient, olFolderInbox).Store

Dim olRules As Outlook.Rules
Set olRules = olStore.GetRules

Dim csvFilePath As String
csvFilePath = "C:\Users\xyz\Test4.csv"

Open csvFilePath For Input As #1

Do While Not EOF(1)
    Line Input #1, csvLine

    Dim csvValues() As String
    csvValues = Split(csvLine, ",")
    
    If UBound(csvValues) = 2 Then
        trigger = csvValues(0)
        folderPath = csvValues(1)
        
        'Create rule
        Dim olRule As Outlook.Rule
        Set olRule = olRules.Create(trigger, olRuleClientOnly)
        
        'Set trigger condition
        Dim olRuleConditions As Outlook.RuleConditions
        Set olRuleConditions = olRule.Conditions
        
        Dim olSubjectCondition As Outlook.TextRuleCondition
        Set olSubjectCondition = olRuleConditions.BodyOrSubject
        olSubjectCondition.Text = Array(trigger)
        
        'Set exception exclude messages To (i.e. restrict rule to Cc and Bcc)
        Dim oToCondition As Outlook.ToOrFromRuleCondition
        Set oToCondition = oRule.olConditionNotTo
        With oToCondition
            .Enabled = True
            .Recipients.Add ("email address removed for privacy reasons")
            .Recipients.ResolveAll
        End With
        
        'Set move action
        Dim olRuleActions As Outlook.RuleActions
        Set olRuleActions = olRule.Actions
        
        Dim olFolder As Outlook.Folder
        Set olFolder = olStore.GetRootFolder.Folders(folderPath)
        
        Dim olMoveOrCopyRuleAction As Outlook.MoveOrCopyRuleAction
        Set olMoveOrCopyRuleAction = olRuleActions.MoveToFolder
        
        With olMoveOrCopyRuleAction
        .Enabled = True
        .Folder = olFolder
        End With
        
        olRules.Save
        
    End If
Loop

Close #1

MsgBox "Rules imported", vbInformation
End Sub

 

5 Replies

@cdfjdk 

There are a few errors in your code that are preventing the rules from being created.

Here are the corrections you can make:

  1. Missing variable declarations: At the beginning of your code, add the following variable declarations:

vba code:

Dim csvLine As String
Dim trigger As String
Dim folderPath As String
  1. Rule conditions and actions: Update the lines where you set the rule conditions and actions:

vba code:

'Set trigger condition
Dim olRuleConditions As Outlook.RuleConditions
Set olRuleConditions = olRule.Conditions

Dim olSubjectCondition As Outlook.TextRuleCondition
Set olSubjectCondition = olRuleConditions.Subject
olSubjectCondition.Text = Array(trigger)

'Set move action
Dim olRuleActions As Outlook.RuleActions
Set olRuleActions = olRule.Actions

Dim olMoveOrCopyRuleAction As Outlook.MoveOrCopyRuleAction
Set olMoveOrCopyRuleAction = olRuleActions.MoveToFolder

With olMoveOrCopyRuleAction
    .Enabled = True
    .Folder = olFolder
End With
  1. Exception condition: Update the lines where you set the exception condition:

vba code:

 

'Set exception exclude messages To (i.e. restrict rule to Cc and Bcc)
Dim oToCondition As Outlook.ToOrFromRuleCondition
Set oToCondition = olRuleConditions.ToOrFrom
With oToCondition
    .Enabled = True
    .Recipients.Add "email address removed for privacy reasons"
    .Recipients.ResolveAll
End With
  1. Saving the rules: Move the olRules.Save line outside the loop to save the rules once after all the rules are created.

With these corrections, the macro should be able to read the CSV file, create rules based on the trigger and folder path, and save the rules. Make sure the CSV file is correctly formatted with the trigger in column 1 and the folder path in column 2 for each rule.

Remember to test the code with caution and have a backup of your rules before running it to avoid any unintended changes.The text, steps and the code are the result of various AI's put together.

 

My answers are voluntary and without guarantee!

 

Hope this will help you.

@cdfjdk 

Here is the updated code with the corrections:

Sub ImportRulesFromCSVTest()

    Dim sharedMailboxName As String
    sharedMailboxName = "email address removed for privacy reasons"

    Dim olApp As Outlook.Application
    Set olApp = Outlook.Application

    Dim olNamespace As Outlook.NameSpace
    Set olNamespace = olApp.GetNamespace("MAPI")

    Dim olRecipient As Outlook.Recipient
    Set olRecipient = olNamespace.CreateRecipient(sharedMailboxName)
    olRecipient.Resolve

    Dim olStore As Outlook.Store
    Set olStore = olNamespace.GetSharedDefaultFolder(olRecipient, olFolderInbox).Store

    Dim olRules As Outlook.Rules
    Set olRules = olStore.GetRules

    Dim csvFilePath As String
    csvFilePath = "C:\Users\xyz\Test4.csv"

    Open csvFilePath For Input As #1

    Dim csvLine As String
    Dim trigger As String
    Dim folderPath As String

    Do While Not EOF(1)
        Line Input #1, csvLine

        Dim csvValues() As String
        csvValues = Split(csvLine, ",")

        If UBound(csvValues) = 1 Then
            trigger = csvValues(0)
            folderPath = csvValues(1)

            'Create rule
            Dim olRule As Outlook.Rule
            Set olRule = olRules.Create(trigger, olRuleClientOnly)

            'Set trigger condition
            Dim olRuleConditions As Outlook.RuleConditions
            Set olRuleConditions = olRule.Conditions

            Dim olSubjectCondition As Outlook.TextRuleCondition
            Set olSubjectCondition = olRuleConditions.Subject
            olSubjectCondition.Text = Array(trigger)

            'Set exception exclude messages To (i.e. restrict rule to Cc and Bcc)
            Dim oToCondition As Outlook.ToOrFromRuleCondition
            Set oToCondition = olRuleConditions.ToOrFrom
            With oToCondition
                .Enabled = True
                .Recipients.Add "email address removed for privacy reasons"
                .Recipients.ResolveAll
            End With

            'Set move action
            Dim olRuleActions As Outlook.RuleActions
            Set olRuleActions = olRule.Actions

            Dim olFolder As Outlook.Folder
            Set olFolder = olStore.GetRootFolder.Folders(folderPath)

            Dim olMoveOrCopyRuleAction As Outlook.MoveOrCopyRuleAction
            Set olMoveOrCopyRuleAction = olRuleActions.MoveToFolder

            With olMoveOrCopyRuleAction
                .Enabled = True
                .Folder = olFolder
            End With
        End If
    Loop

    Close #1

    ' Save the rules
    olRules.Save

    MsgBox "Rules imported", vbInformation
End Sub

Please ensure that you have made the necessary adjustments, such as providing the correct CSV file path and the shared mailbox email address.

Remember to review and test the code with caution, and have a backup of your rules before running it to avoid any unintended changes. The text, steps and the code are the result of various AI's put together.

 

My answers are voluntary and without guarantee!

 

Hope this will help you.

 @NikolinoDE - thank you for trying to help, but might I suggest you kindly never post AI code without testing it first? Everyone can find AI code generators and AI code is flakey - the code you posted simply introduced errors into my code that were not there before.
Thanks for the tip. That's why I pointed out at the end that the text, steps, and code are the result of various AIs put together. Pointed out that my answers are voluntary and above all without guarantee, since it was created by the AI's. Thanks again for the tip, I'll make it clearer next time. I wish you continued success and hope that you will quickly come up with a solution that will help you further than the one I sent.

Here is a macro that loops through a list in Excel to create rules in an Outlook shared mailbox (not exactly the same for a private mailbox). User will need to write the rules that route the emails to the correct folder - the MS documentation is here: https://learn.microsoft.com/en-us/office/vba/api/outlook.rules.create

Remember to add references to Excel when running in Outlook.

Sub CreateRules_SharedMailbox_1()

    Dim olApp As Outlook.Application
    Set olApp = New Outlook.Application

    Dim olNamespace As Outlook.NameSpace
    Set olNamespace = olApp.GetNamespace("MAPI")

    Const sharedMailboxName As String = "email address removed for privacy reasons" 'Your shared mailbox name
    Const olFolderInbox As Integer = 6

    Dim olRecipient As Outlook.Recipient
    Set olRecipient = olNamespace.CreateRecipient(sharedMailboxName)
    olRecipient.Resolve

    Dim olFolder As Outlook.Folder
    If olRecipient.Resolved Then
        Set olFolder = olNamespace.GetSharedDefaultFolder(olRecipient, olFolderInbox)
        Dim colRules As Outlook.Rules
        Dim I As Long

        For I = 1 To Session.Stores.Count
            Debug.Print Session.Stores(I)

            If Session.Stores(I).DisplayName = sharedMailboxName Then
                Set colRules = olFolder.Store.GetRules()

                Dim xlApp As Excel.Application
                Set xlApp = CreateObject("Excel.Application")

                Dim wb As Excel.Workbook
                Set wb = xlApp.Workbooks.Open("C:\Users\xyz\YourExcel.xlsx") 'URL and filename for your Excel

                Dim ws As Excel.Worksheet
                Set ws = wb.Sheets("Test") 'Sheet name for your list

                Dim lastRow As Long
                lastRow = ws.Cells(ws.Rows.Count, "A").End(-4162).Row

                Dim iRow As Long
                For iRow = 2 To lastRow '2 to exclude header row
                    Dim trigger As String
                    Dim fldPath As String

                    trigger = ws.Cells(iRow, 1).Value 'Column A contains the trigger values
                    fldPath = ws.Cells(iRow, 2).Value 'Column B contains the fldPath values

                    ' Create a new rule
                    Dim oRule As Outlook.Rule
                    Set oRule = colRules.Create(trigger, olRuleReceive)

                    'Set your rule conditions here
                    
                    Dim oMoveTarget As Outlook.Folder
                    Set oMoveTarget = olFolder.Folders("Test")
             
                Next iRow

                wb.Close False
                xlApp.Quit

                colRules.Save
                Exit For
            End If
        Next

End Sub