I created an Outlook VBA macro to allow the user to automatically create/run a rule to move the currently selected or opened email to a user-selected Outlook folder path. It will only create the rule if it doesn't already exists, and in either case it will prompt to run the rule on all message in the current folder.
It's been working OK until suddenly I'm getting a VBA error "-2147221233 The attempted operation failed. An object could not be found." (see green-highlighted line in the code below) trying to retrieve one of the rules. The rule that it's failing on has existed for years. Unlike the other rules that are based on acting on the sender's email address (or message header - that's due to the pervasive use of "<email address with random suffixes> on behalf of ..." used by allegedly legitimate commercial email vendors - don't get me started on that one
), this rule acts on 'selected properties' (via 'advanced search') then performs actions (deletes emails with blank subjects) and includes exceptions.
The only thing I could think of was perhaps the PST file was corrupt so I ran scanpst on it, but the error persists. I've been forced to incorporate a kludgy error handler to make the main loop that reads the Name property from each rule in the collection skip the offending item and continue. Would be useful to better understand what is causing this sudden failure. Here's the code snippet:
<code>
Sub CreateRuleFromSelectedSender()
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 oMoveTarget, oCurrFolder As Outlook.folder
Dim oMsg As Outlook.MailItem
Dim strSenderEmail As String
Dim i As Integer
Dim bRuleFound As Boolean
On Error GoTo ErrHandler
'Assume that target folder already exists - must convert path to folder object
'Set oMoveTarget = GetFolder("\\C2PublicFolders\Test Folder\Test SubFolder\Dest Folder)
Set olApp = Outlook.Application
Set olSession = olApp.GetNamespace("MAPI")
Set oMoveTarget = olSession.PickFolder
If oMoveTarget Is Nothing Then
Set olApp = Nothing
Set olSession = Nothing
Exit Sub
End If
'Retrieve currently selected email message (or opened message)
Set oMsg = GetCurrentItem()
'Get Rules from Session.DefaultStore object
Set colRules = Application.Session.DefaultStore.GetRules() 'retrieve rules collection
Set oCurrFolder = Outlook.Application.ActiveExplorer.CurrentFolder 'retrieve currently selected folder (used when executing rule)
strSenderEmail = oMsg.SenderEmailAddress
'Determine if rule already exists for the sender's email address (don't want to create a duplicate)
bRuleFound = False
i = 1
Do While Not (bRuleFound) And i <= colRules.Count
'Look for rule named after strSenderEmail
If colRules.Item(i).Name = strSenderEmail Then
'If Rule name found, mark it as found and exit
bRuleFound = True
'run the rule without creating the duplicate
colRules.Item(i).Execute ShowProgress:=True, folder:=oCurrFolder
Else
Skip: i = i + 1
End If
Loop
'Create the rule by adding a Receive Rule to Rules collection, only if this doesn't already exist for this email address
If Not (bRuleFound) Then
Set oRule = colRules.Create(strSenderEmail, olRuleReceive)
Set oFromCondition = oRule.Conditions.From
With oFromCondition
.Enabled = True
.Recipients.Add (strSenderEmail)
.Recipients.ResolveAll
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 rules collection and display progress dialog when running the rule
colRules.Save
'add code here to offer the option to run the rule now
If MsgBox("Run Rules Now?", vbYesNo) = vbYes Then oRule.Execute ShowProgress:=True, folder:=oCurrFolder
End If
Set colRules = Nothing
Set oRule = Nothing
Set oMoveTarget = Nothing
Set oMsg = Nothing
Exit Sub
ErrHandler:
Debug.Print Err.Number & vbTab & Err.Description
Resume Skip
End Sub
</code>
.
.
.
Ironically, with Outlook's convoluted object model, it turns out to be harder to specify a Outlook path (\\<mailbox store name>\folder\subfolder) path then to use the GetNameSpace("MAPI").pickfolder method, since the MoveToFolder method requires a folder object. I had to write a function GetFolder(<Outlook folder path>) to parse the path and return a folder object.
It's been working OK until suddenly I'm getting a VBA error "-2147221233 The attempted operation failed. An object could not be found." (see green-highlighted line in the code below) trying to retrieve one of the rules. The rule that it's failing on has existed for years. Unlike the other rules that are based on acting on the sender's email address (or message header - that's due to the pervasive use of "<email address with random suffixes> on behalf of ..." used by allegedly legitimate commercial email vendors - don't get me started on that one
), this rule acts on 'selected properties' (via 'advanced search') then performs actions (deletes emails with blank subjects) and includes exceptions.The only thing I could think of was perhaps the PST file was corrupt so I ran scanpst on it, but the error persists. I've been forced to incorporate a kludgy error handler to make the main loop that reads the Name property from each rule in the collection skip the offending item and continue. Would be useful to better understand what is causing this sudden failure. Here's the code snippet:
<code>
Sub CreateRuleFromSelectedSender()
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 oMoveTarget, oCurrFolder As Outlook.folder
Dim oMsg As Outlook.MailItem
Dim strSenderEmail As String
Dim i As Integer
Dim bRuleFound As Boolean
On Error GoTo ErrHandler
'Assume that target folder already exists - must convert path to folder object
'Set oMoveTarget = GetFolder("\\C2PublicFolders\Test Folder\Test SubFolder\Dest Folder)
Set olApp = Outlook.Application
Set olSession = olApp.GetNamespace("MAPI")
Set oMoveTarget = olSession.PickFolder
If oMoveTarget Is Nothing Then
Set olApp = Nothing
Set olSession = Nothing
Exit Sub
End If
'Retrieve currently selected email message (or opened message)
Set oMsg = GetCurrentItem()
'Get Rules from Session.DefaultStore object
Set colRules = Application.Session.DefaultStore.GetRules() 'retrieve rules collection
Set oCurrFolder = Outlook.Application.ActiveExplorer.CurrentFolder 'retrieve currently selected folder (used when executing rule)
strSenderEmail = oMsg.SenderEmailAddress
'Determine if rule already exists for the sender's email address (don't want to create a duplicate)
bRuleFound = False
i = 1
Do While Not (bRuleFound) And i <= colRules.Count
'Look for rule named after strSenderEmail
If colRules.Item(i).Name = strSenderEmail Then
'If Rule name found, mark it as found and exit
bRuleFound = True
'run the rule without creating the duplicate
colRules.Item(i).Execute ShowProgress:=True, folder:=oCurrFolder
Else
Skip: i = i + 1
End If
Loop
'Create the rule by adding a Receive Rule to Rules collection, only if this doesn't already exist for this email address
If Not (bRuleFound) Then
Set oRule = colRules.Create(strSenderEmail, olRuleReceive)
Set oFromCondition = oRule.Conditions.From
With oFromCondition
.Enabled = True
.Recipients.Add (strSenderEmail)
.Recipients.ResolveAll
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 rules collection and display progress dialog when running the rule
colRules.Save
'add code here to offer the option to run the rule now
If MsgBox("Run Rules Now?", vbYesNo) = vbYes Then oRule.Execute ShowProgress:=True, folder:=oCurrFolder
End If
Set colRules = Nothing
Set oRule = Nothing
Set oMoveTarget = Nothing
Set oMsg = Nothing
Exit Sub
ErrHandler:
Debug.Print Err.Number & vbTab & Err.Description
Resume Skip
End Sub
</code>
.
.
.
Ironically, with Outlook's convoluted object model, it turns out to be harder to specify a Outlook path (\\<mailbox store name>\folder\subfolder) path then to use the GetNameSpace("MAPI").pickfolder method, since the MoveToFolder method requires a folder object. I had to write a function GetFolder(<Outlook folder path>) to parse the path and return a folder object.
