Copy sent mail to folder based on key words in subject

Question

When I send an email which contains the word XYZ in the subject, I want Outlook to copy that email in the folder XY including the sent-date and marked as read.

I found two approaches – both not working:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If TypeName(Item) <> "MailItem" Then Exit Sub
       
    ' ~~> Search for Subject
    Set ol = New Outlook.Application
    Set olns = ol.GetNamespace("MAPI")
    Set myFolder = olns.GetDefaultFolder(olFolderInbox) ' inbox 
    Set XYFolder = myFolder.Folders("XY")' desired destination folder
       
    If InStr(1, Item.Subject, "XYZ", vbTextCompare) Then
    
        ‘ ~~ approach A: copy the object ~~~ 
        Set CopiedItem = Item.Copy ' create a copy 
        CopiedItem.Move XYFolder ' moce copy to folder 
        ' Set CopiedItem.SendOn = CopiedItem.CreationTime '<- not working, write protected 
    
        ‘ ~~ approach B: send me a copy (includes using filters afterwards )~~~
        Item.CC = Item.CC & "[email protected]"      
    End If
           
End Sub

Problems approach A:
The mail items is copied correctly, however the send date and time is blank, as the items has not yet been sent.

Problems approach B:
The new address is added, however as all known addresses are replaced by “user-friendly” names, I get a weird message, that the sender (TO) cannot be resolved any more. Thus the mail will not be sent. Furthermore I would need to add manual filters – which is rather ugly.

General thoughts

1. I want to leave a copy in the send folder. Thus scanning the Send-Folder daily would lead to tons of duplicates in the XY-folder of the same mail.
2. Using the Mailitem.SaveMyPersonalItems property would move the mail only in the folder XY but would not leave a copy in sent-folder.
3. Possibly the Items.ItemAdd event may be a solution, but I did not yet understand how to check if a new item is added to the sent-folder.
4. The built-in filters of outlook allow copying a sent email containing “XYZ” to folder “XY”. However it’s impossible to mark them as read.

Answer 1

Item Add works the same on any folder.

For the ThisOutlookSession module:

Option Explicit

Private WithEvents snItems As Items

Private Sub Application_Startup()
    '   default local Sent Items folder
    Set snItems = Session.GetDefaultFolder(olFolderSentMail).Items 
End Sub

Private Sub snItems_ItemAdd(ByVal item As Object) 

    Dim myFolder as Folder
    Dim XYFolder as Folder
    Dim CopiedItem as mailitem

    If TypeName(item) = "MailItem" Then

        Set myFolder = Session.GetDefaultFolder(olFolderInbox) ' inbox 
        Set XYFolder = myFolder.Folders("XY")' desired destination folder

        If InStr(1, Item.Subject, "XYZ", vbTextCompare) Then

            On Error Resume Next
            ' Appears CopiedItem is considered
            '  an item added to Sent Items folder
            ' Code tries to run more than once.
            ' It would be an endless loop
            '  but that item has been moved.
            '
            ' Skip all lines on the second pass.
            Set CopiedItem = item.copy ' create a copy
            CopiedItem.UnRead = True
            CopiedItem.Move XYFolder ' move copy to folder
            On Error GoTo 0

        End If

    End If

ExitRoutine:
    Set myFolder = Nothing
    Set XYFolder = Nothing
    Set CopiedItem = Nothing

End Sub