vbaoutlookrules

Outlook macro not writing to shared mailbox


The following macro creates an Outlook rule correctly, but only in my private email account, not in the shared mailbox I am targeting. Can someone please identify any errors/omissions in the code that are causing it not to link to the shared mailbox?

Sub CreateRule_MSmodified5()
'Creates rule in private folder, not shared mailbox

Dim sharedMailboxName As String
sharedMailboxName = "sharedmailbox@abcxyz.zz"

Dim olApp As Object
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 oInbox As Outlook.Folder
If olRecipient.Resolved Then
    Set oInbox = olNamespace.GetSharedDefaultFolder(olRecipient, olFolderInbox)
End If

Dim oMoveTarget As Outlook.Folder
Set oMoveTarget = oInbox.Folders("Test")

Dim colRules As Outlook.Rules
Set colRules = olNamespace.DefaultStore.GetRules()
Dim oRule As Outlook.Rule
Set oRule = colRules.Create("C5", olRuleReceive)
  
Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
Set oMoveRuleAction = oRule.Actions.MoveToFolder
With oMoveRuleAction
    .Enabled = True
    .Folder = oMoveTarget
End With

Dim oExceptSubject As Outlook.TextRuleCondition
Set oExceptSubject = oRule.Exceptions.Subject
With oExceptSubject
    .Enabled = True
    .Text = Array("string1", "string2")
End With

colRules.Save

End Sub

Solution

  • Whether saving to another store is feasible, "technically" you need the non-default store.

    It could look like this.

    Option Explicit
    
    Sub CreateRule_MSmodified5_nondefaultStore()
    
    Dim sharedMailboxName As String
    sharedMailboxName = "sharedmailbox@abcxyz.zz"
    
    Dim olNamespace As namespace
    Set olNamespace = GetNamespace("MAPI")
    
    Dim olRecipient As Recipient
    Set olRecipient = olNamespace.CreateRecipient(sharedMailboxName)
    olRecipient.Resolve
    
    Dim oInbox As folder
    'Email address is always resolved. Use when not an email address.
    If olRecipient.Resolved Then   
        Set oInbox = olNamespace.GetSharedDefaultFolder(olRecipient, olFolderInbox)
    End If
    
    Dim oMoveTarget As folder
    Set oMoveTarget = oInbox.Folders("Test")
    
    Dim colRules As Rules
    
    Dim i As Long
    For i = 1 To Session.Stores.count
    
        Debug.Print Session.Stores(i)
        
        If Session.Stores(i) = sharedMailboxName Then
    
            Set colRules = Session.Stores(i).GetRules()
            
            Dim oRule As Rule
            Set oRule = colRules.Create("C5", olRuleReceive)
              
            Dim oMoveRuleAction As MoveOrCopyRuleAction
            Set oMoveRuleAction = oRule.Actions.MoveToFolder
            With oMoveRuleAction
                .Enabled = True
                .folder = oMoveTarget
            End With
            
            Dim oExceptSubject As TextRuleCondition
            Set oExceptSubject = oRule.Exceptions.subject
            With oExceptSubject
                .Enabled = True
                .Text = Array("string1", "string2")
            End With
            
            colRules.Save
            
            Exit For
            
        End If
    Next
    
    End Sub