Desired functionality:
Whenever 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.
For now I have found 2 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 & "my.name@company.com"
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
- 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.
- Using the Mailitem.SaveMyPersonalItems property
would move the mail only in the folder XY but would not leave a copy in sent-folder.
- 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.
- 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.
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
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
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.
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