Outlook rule to move sent items with Excel VBA

Question

I have to sort about 8000 emails into the specific folders in Outlook (2013).

I created the folders in Outlook through an Excel list. This spreadsheet contains beside the foldername, as well the senders/receivers email address.

I want to create rules, following this example:

emails -> Received by sheet1.cells(i,4) -> move to folder =sheet1.cells(i,5)

Through googling I created this code:

Sub createOutlookRule()
Dim appOutlook As Outlook.Application
Dim olRules As Outlook.Rules
Dim myRule As Outlook.Rule
Dim moveToAction As Outlook.MoveOrCopyRuleAction
Dim fromAction As Outlook.ToOrFromRuleCondition
Dim myInbox As Outlook.Folder
Dim moveToFolder As Outlook.Folder

For i = 2 To 5
Set appOutlook = New Outlook.Application
Set myInbox = appOutlook.Session.GetDefaultFolder(olFolderInbox)

Set olRules = appOutlook.Session.DefaultStore.GetRules()
Set myRule = olRules.Create(Sheet2.Cells(i, 1), olRuleReceive)
Set fromAction = myRule.Conditions.From

a = Sheet2.Cells(i, 3)

Set moveToFolder = myInbox.Folders("Mifid").Folders(a)

With fromAction
.Enabled = True

If IsEmpty(Sheet2.Cells(i, 4)) Then GoTo 4 Else

.Recipients.Add (Sheet2.Cells(i, 4))

If IsEmpty(Sheet2.Cells(i, 5)) Then GoTo 3 Else

.Recipients.adds (Sheet2.Cells(i, 5))
3:

End With

Set moveToAction = myRule.Actions.moveToFolder

With moveToAction
.Enabled = True
.Folder = moveToFolder
End With
olRules.Save
4:
Next i
End Sub

This essentially creates the rule but so far does not move items.

I adjusted it for the sent-items but during the "move part" I get an error

Sub createOutlookRuleSENTITEMS()
Dim appOutlook As Outlook.Application
Dim olRules As Outlook.Rules
Dim myRule As Outlook.Rule
Dim moveToAction As Outlook.MoveOrCopyRuleAction
Dim SENTAction As Outlook.ToOrFromRuleCondition
Dim myInbox As Outlook.Folder
Dim moveToFolder As Outlook.Folder

For i = 2 To 5
Set appOutlook = New Outlook.Application
Set myInbox = appOutlook.Session.GetDefaultFolder(olFolderInbox)

Set olRules = appOutlook.Session.DefaultStore.GetRules()
Set myRuleSENT = olRules.Create(Sheet2.Cells(i, 1), olRuleSend)
Set TOAction = myRuleSENT.Conditions.SentTo

a = Sheet2.Cells(i, 3)

Set moveToFolder = myInbox.Folders("Mifid").Folders(a)

With TOAction
.Enabled = True
If IsEmpty(Sheet2.Cells(i, 4)) Then GoTo 4 Else
.Recipients.Add ("test@example.com")
If IsEmpty(Sheet2.Cells(i, 5)) Then GoTo 3 Else
.Recipients.adds (Sheet2.Cells(i, 5))
3:
End With
Set moveToAction = myRuleSENT.Actions.moveToFolder

With moveToAction
.Enabled = True
.Folder = moveToFolder
End With
olRules.Save
4:

Next i
End Sub

Error-Message:

Run-time error
Invalid operation. this rule action cannot be enabled because either the rule is read-only or invalid for the rule type, or the action conflicts with another action on the rule

To move items you could use `Application.ItemSend` instead. https://stackoverflow.com/a/48551515/1571407 — niton, Sep 30 '22 at 20:30

score 0 · Answer 1 · answered Sep 30 '22 at 19:57

The rules interface for sent items allows copy not move. (Does not prove it impossible.)

Option Explicit

Sub createOutlookRuleSENTITEMS()

' Reference Outlook nn.n Object Library
Dim appOutlook As Outlook.Application
Dim olRules As Outlook.Rules
Dim myRuleSENT As Outlook.Rule

Dim ToCondition As Outlook.ToOrFromRuleCondition
Dim CopySentItemRuleAction As Outlook.MoveOrCopyRuleAction

Dim myInbox As Outlook.Folder
Dim copyToFolder As Outlook.Folder

Dim i As Long

Set appOutlook = New Outlook.Application
Set myInbox = appOutlook.Session.GetDefaultFolder(olFolderInbox)

For i = 2 To 5
    
    Set olRules = appOutlook.Session.DefaultStore.GetRules()

    Debug.Print "Sheet2.Cells(i, 1): " & Sheet2.Cells(i, 1)
    Set myRuleSENT = olRules.Create(Sheet2.Cells(i, 1), olRuleSend)
    
    Set ToCondition = myRuleSENT.Conditions.SentTo
   
    Dim a As String
    a = Sheet2.Cells(i, 3)
    Debug.Print "a: " & a
    
    Set copyToFolder = myInbox.Folders("Mifid").Folders(a)
    
    With ToCondition
        .Enabled = True
        
        Debug.Print "Sheet2.Cells(i, 4): " & Sheet2.Cells(i, 4)
        
        If Not IsEmpty(Sheet2.Cells(i, 4)) Then
        
            .Recipients.Add ("test@example.com")
        
            If Not IsEmpty(Sheet2.Cells(i, 5)) Then
                .Recipients.Add (Sheet2.Cells(i, 5))
            End If
            
            ' The rules interface for sent items allows copy not move.
            ' (Does not prove it impossible.)
            '
            'Action is to copy, not move, the sent item
            Dim oCopyTarget As Outlook.Folder
            
            Set copyToFolder = myInbox.Folders("Mifid").Folders(a)
            
            Set CopySentItemRuleAction = myRuleSENT.Actions.copyToFolder
            With CopySentItemRuleAction
                .Enabled = True
                .Folder = copyToFolder
            End With
            
            olRules.Save
            
        End If
    End With
Next i

Debug.Print "Done."

End Sub

Outlook rule to move sent items with Excel VBA

1 Answers1