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

Answer 2

Try this

Sub CopyMailFromSentFolder()
    Dim oNS As Outlook.Namespace
    Dim oDefaultFolder As Outlook.MAPIFolder
    Dim oSentFolder As Outlook.MAPIFolder
    Dim oDestinationFolder As Outlook.MAPIFolder
    Dim oItems As Outlook.Items
    Dim oDestItems As Outlook.Items
    Dim oItemToCopy As MailItem
    Dim intCounter, intSecCounter As Integer
    Dim bolItemFound As Boolean

    Set oNS = GetNamespace("MAPI")
    Set oDefaultFolder = oNS.GetDefaultFolder(olFolderInbox)
    Set oSentFolder = oNS.GetDefaultFolder(olFolderSentMail)
    Set oItems = oSentFolder.Items

    For intCounter = 1 To oItems.Count
        If InStr(1, oItems(intCounter).Subject, "testing") > 0 Then 'And oItems(intCounter).Unread = True Then

            Set oDestinationFolder = oDefaultFolder.Folders("Just Testing")
            Set oDestItems = oDestinationFolder.Items
            bolItemFound = False

            For intSecCounter = 1 To oDestItems.Count
                If oDestItems(intSecCounter).Subject = oItems(intCounter).Subject And oDestItems(intSecCounter).SentOn = oItems(intCounter).SentOn Then
                    bolItemFound = True
                    Exit For
                End If
            Next
            If Not bolItemFound Then
                Set oItemToCopy = oItems(intCounter).Copy
                oItemToCopy.Move oDestinationFolder
                Set oItemToCopy = Nothing
            End If
            Set oDestinationFolder = Nothing
            Set oDestItems = Nothing

            'oItems(intCounter).Unread = False
        End If
    Next

    Set oNS = Nothing
    Set oDefaultFolder = Nothing
    Set oSentFolder = Nothing
    Set oItems = Nothing

End Sub

This should avoid copying duplicates. Try adding it to Application_ItemSend. Not sure if it would slow down the sending process but it would give you the desired result

Answer 3

If you don't need a copy in the Sent Items folder, you can simply set the MailItem.SaveSentMessageFolder property - Outlook will move the item to that folder after it is sent.

Answer 4

Based on the answer from niton I changed the code so that it will work with multiple folders. Ready for CnP. Thanks to all the contributors!

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 DestinationFolder As Folder     ' desired destination folder
    Dim CopiedItem As MailItem

    If TypeName(item) = "MailItem" Then

        Set myFolder = Session.GetDefaultFolder(olFolderInbox) ' inbox


        If InStr(1, item.Subject, "XYZ", vbTextCompare) Or _
           InStr(1, item.Subject, "BLA", 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.

            'define destination folder
            If InStr(1, item.Subject, "XYZ", vbTextCompare) Then
                Set DestinationFolder = myFolder.Folders("XY")

            ElseIf InStr(1, item.Subject, "BLA", vbTextCompare) Then
                Set DestinationFolder = myFolder.Folders("XBLA")

            End If

            ' copy the send mail to destination folder
            Set CopiedItem = item.Copy ' create a copy
            CopiedItem.Move DestinationFolder ' move copy to folder

            'Debugging
            'Debug.Print "mail w. subject: " & item.Subject & " copied to : " & DestinationFolder

            On Error GoTo 0

        End If

    End If

ExitRoutine:
    Set myFolder = Nothing
    Set DestinationFolder = Nothing
    Set CopiedItem = Nothing

End Sub