RSSI hear from a lot of user's who don't like how Outlook handles sent items with an IMAP accounts. In older versions of Outlook, IMAP sent items use the local Sent Items folder. While Outlook 2007 and 2010 can be configured to use the IMAP sent folder, when you use a Send by email command in other applications, the sent item goes into the local data file, ignoring the account configuration. Outlook 2013 uses XLIST to determine the sent items folder, but if the IMAP server doesn't support XLIST, the sent item is saved locally.
This macro solves the problem by monitoring the sent items folder and moving sent messages to the desired folder.
To use this macro, you need to use the GetFolderPath macro from GetFolderPath.
You'll also need to set macro security to low to test the macro.
Press Alt+F11 to open the VBA editor. Expand Project1 and Microsoft Outlook Objects then double click on ThisOutlookSession. Paste the code into ThisOutlookSession. GetFolderPath can be pasted below this macro or in a new module.
To use this with multiple accounts, copy the IF... End IF block and change the account name and folder path for each account.
The account name and the data file name are usually the same - in Outlook 2010, both are the email address by default.
You need to use the account name as seen in File, Account Settings (or in the From field if you have multiple accounts) and the data file name (and path to the Sent folder) as seen in the folder list.
Note: this macro will work with any account type.
This macro starts when Outlook stars. To test it without restarting Outlook, click in the Application_Startup macro and click the Run button (or press F5).
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Set Items = Session.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
'repeat for each account
If Item.SendUsingAccount = "alias@domain.com" Then
' Get the GetFolderPath function from http://slipstick.me/getfolderpath
Set MovePst = GetFolderPath("data file name\Inbox\Sent")
Item.UnRead = False
Item.Move MovePst
End If
End Sub
To move sent messages to multiple folders, you can repeat the If / End If block in the code sample above or set the MovePst variable in each If statement, like so:
If Item.SendUsingAccount = "alias@domain1.com" Then
Set MovePst = GetFolderPath("data file name1\Inbox\Sent")
End If
If Item.SendUsingAccount = "alias@domain2.com" Then
Set MovePst = GetFolderPath("data file name2\Inbox\Sent")
End If
Item.UnRead = False
Item.Move MovePst
You could also use Case statements to set the correct Move path.
More Information
Messages Aren't Saved in the Sent Items Folder
Configure and Use IMAP Accounts
Choosing the Folder to Save a Sent Message In
![Diane Poremsky [Outlook MVP]](http://cdn.slipstick.com/images/2013/mvp-icon.png){kind=icon}
I tried this with multiple IMAP acoounts but all sent mail ends up in the first email account sent items folder only.
Did you repeat this for each account?
If oAccount = "second account name" Then
Set MovePst = GetFolderPath("second-imap-account\Inbox\Sent")
Item.UnRead = False
Item.Move MovePst
End If
Yes:
For Each oAccount In Application.Session.Accounts
If oAccount = "mail.com" Then
Set MovePst = GetFolderPath("\\mail.com\Sent")
Item.UnRead = False
Item.Move MovePst
End If
If oAccount = "gmail.com" Then
Set MovePst = GetFolderPath("\\gmail.com\[Gmail]\Sent Mail")
Item.UnRead = False
Item.Move MovePst
End If
Next
This is in Outlook 2007, gmail.com sent mail ends up in the mail.com sent folder.
Don't use \\ on the path - also, gmail accounts shouldn't need this. Gmail saves copies in it's sent folder automatically.
Removed the \\ on the path. Still the same outcome. All sent items go to the first account's sent items folder.
I have 3 other non-gmail accounts so would like to get this working.
Is the first account the default account? I've been working on the premise that 'first account' was the one listed first in the code... but if it's the folder all the sent mail goes to when you don't use code, then the code isn't running. Make sure macro security is set to low and click in the Startup macro and click Run.
There are 6 .pst data files. The default .pst containing the default Sent Items folder for Outlook (created by my original POP3 account which has long been deleted) and one for each of the 5 IMAP accounts.
With no code, the IMAP sent emails go to the default Sent Items folder in the default .pst and not the Sent Mail folder for each IMAP account, hence this code.
After adding the code, any sent mail goes to the default Sent Items folder and the code in the Items_ItemAdd event is triggered.
There are 5 accounts (one for each IMAP account) in Application.Session.Accounts, mail.com being the first.
The mail is moved, but only to the first IMAP account listed. In this case the mail.com Sent folder. The code is definitely running.
I'm sorry but I can't seem to get this to work in Outlook 2013. The mail in 'Sent Items (This computer only)' don't move to the 'Sent Items' folder I am pointing to. Macro security is disabled and debugging doesn't seem to find an error in the code. Clearly I am doing something wrong and I am a novice with this so any help is appreciated.
Here is my code:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Set Items = Session.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim oAccount As Outlook.Account
For Each oAccount In Application.Session.Accounts
'repeat for each account
If oAccount = "PSI Email" Then
Set MovePst = GetFolderPath("PSI Email\Sent Items")
Item.UnRead = False
Item.Move MovePst
End If
Next
End Sub
Sub Whatever()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
'use the default folder
Set Items = Ns.GetDefaultFolder(olFolderSentMail).Items
'do whatever
End Sub
You need the GetFolderPath function.
Try this:
Private Sub Application_Startup()Set Items = Session.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim oAccount As Outlook.Account
For Each oAccount In Application.Session.Accounts
'repeat for each account
If oAccount = "PSI Email" Then
Set MovePst = GetFolderPath("PSI EmailSent Items")
Item.UnRead = False
Item.Move MovePst
End If
Next
End Sub
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
Thanks for this but for some reason it still does not work. The emails are still in Sent Items (This computer only). Not sure what else to try.
I'll test it. (I might regret not testing the code I gave you the other day. :) )
I've also tried the code with no success. I'm using Windows 8, the german version of Outlook 2013 and Mailaccounts from gmx.de and 1und1.de - if that matters. Would love to see a working workaround for this isse.
Do you get any error messages?
No nothing.
For myself I get absolutely no error messages, only that the messages do not move.
Thanks for this, but I'm having an issue with multiple accounts.
Outlook 2013 this works great with one account. However, when I add another account, nothing happens when I send from the 2nd account. BUT, when I send from the first account this happens:
1. the mail gets moved to the Sent boxes of BOTH accounts, and
2. I get this error popup, even when sending from the first account:
Mircosoft Visual Basic
Run-time error '-2147221233 (8004010f)':
the items were copied instead of moved because the original items cannot be deleted. The operation failed. An object cannot be found.
When I debug, it's stopped next to the 2nd account line:
Item.Move MovePst
Here's my code:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Set Items = Session.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim oAccount As Outlook.Account
For Each oAccount In Application.Session.Accounts
'repeat for each account
If oAccount = "David IMAP" Then
' Get the GetFolderPath function from http://slipstick.me/getfolderpath
Set MovePst = GetFolderPath("David IMAP\Inbox\Sent")
Item.UnRead = False
Item.Move MovePst
End If
If oAccount = "HostrupHR" Then
' Get the GetFolderPath function from http://slipstick.me/getfolderpath
Set MovePst = GetFolderPath("HostrupHR\Inbox\Sent")
Item.UnRead = False
Item.Move MovePst
End If
Next
End Sub
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
I tried changing the code to:
If oAccount = "David IMAP" Then
' Get the GetFolderPath function from http://slipstick.me/getfolderpath
Set MovePst = GetFolderPath("David IMAP\Inbox\Sent")
Item.UnRead = False
Item.Move MovePst
ElseIf oAccount = "HostrupHR" Then
' Get the GetFolderPath function from http://slipstick.me/getfolderpath
Set MovePst = GetFolderPath("HostrupHR\Inbox\Sent")
Item.UnRead = False
Item.Move MovePst
End If
That didn't help. I wonder if it's related to the For Each...
This error: the items were copied instead of moved because the original items cannot be deleted. The operation failed. An object cannot be found. says there is a problem deleting the message. When you move with imap, you copy to a folder and delete it from the other folder. Try changing item.move to item.copy and see if it works.
It looks like i have a typo in the code - you need to check the display name:
For Each oAccount In Application.Session.Accounts
'repeat for each account
If oAccount.DisplayName = "account name" Then
For multiple accounts wit would be better to assign the account name to a variable and use that in the code - provided the display name and the data file name is identical. I'll update the code to do that too.
I added the .DisplayName, this didn't seem to change anything. When I use just one account, it works fine. When I add the 2nd account, it fails. I tried changing just the 2nd account's loop to item.copy instead of item.move, and it threw this error: 450: Wrong number of arguments or invalid property assignment.
It's worth noting that this is what causes the failure:
Condition 1:
I send 1 message from account A. The failure ("cannot be deleted") is in the loop for account B, even though it shouldn't be affected. Notably, the message does get saved in the SENT box for BOTH account A and account B. I'm hoping this helps debug.
Condition 2:
I send 1 message from account B. No failure/error message, BUT the message is NOT saved in either accounts' SENT box.
Condition 3:
I comment out account A in the code, so this should only work for account B.
I send 1 message from account A (nothing should happen). Message gets stored only in the sent folder for account B.
I send 1 message from account B, no message gets stored in either SENT box.
Condition 4:
I comment out account B, uncomment account A.
I send 1 message from account A, the code works properly.
hope this helps. I'm not much of a de-bugger....
Thanks for this code, Diane.
However, I'm also having difficulty making this work correctly. I want to set it up for multiple accounts. However, once I add the first account, all mail, regardless of the Display Name of the account I send through, gets moved to the first folder path I list in the code.
I really need to get this working, so would appreciate any suggestions/help anyone can offer.
In fact, testing this further, it seems that the problem is that the If statement isn't working: the code seems to trigger a move for any sent mail -- regardless of the sending account -- to the specified folder path.
Any ideas?
Add msgbox oAccount.DisplayName right after the if statement and see if it pops up the expected account name.
Thanks, Diane.
So, that gave me:
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim oAccount As Outlook.Account
For Each oAccount In Application.Session.Accounts
'repeat for each account
If oAccount.DisplayName = "NAME1" Then
msgbox oAccount.DisplayName
' Get the GetFolderPath function from http://slipstick.me/getfolderpath
Set MovePst = GetFolderPath("NAME1\Sent")
Item.UnRead = False
Item.Move MovePst
End If
If oAccount.DisplayName = "NAME2" Then
' Get the GetFolderPath function from http://slipstick.me/getfolderpath
Set MovePst = GetFolderPath("NAME2\Sent Items")
Item.UnRead = False
Item.Move MovePst
End If
Next
End Sub
Interestingly, what happens now is that regardless of which account I send an email through, the Message Box pops up with the Display Name "Name1", and then the message gets moved to the Sent Items box listed for account "Name2"! So, the If/End doesn't seem to be working...
What version of Outlook are you using?
Sorry to post again before you've had a chance to reply, Diane, but I think I know what's happening now - just not how to fix it!
Of the two accounts I have listed in the code, I tried changing the first one to something that doesn't exist. Then, the message was moved to the Sent Items box listed for the second account.
So, it seems that instead of the script saying "If the message was sent through "NAME1" move it to "NAME1\Sent", but continue to the next option, if it wasn't", it's actually behaving as "If an account with "NAME1" exists - and regardless of whether the message was sent through it - move the message to "NAME1\Sent".
Does that make sense, and could it explain what's going on? If so, how can I fix it?!
Many thanks.
That does make sense and if often the reason why If's fail. Doubling up on If's can be a problem to, but usually only if using an OR or a "not if". I'll take a look at the code and test it next.
Outlook 2013 32-bit. Thanks for continuing to look at this for me.
Hi Diane, Just wondering if you had any more thoughts on this, please? I'm in the process of switching email providers, and am keeping my fingers crossed that we can get this code to work, so I can simplify my setup!
I'm trying to get caught up on things here and haven't had a chance to test it thoroughly yet.
OK, no worries - I don't mean to rush you, of course. Thanks again for continuing to try and help with this.
Hi Diane, I'm sorry to post again about this, but I was wondering if you've had a chance to look at the code, yet? This is the only code I can find online that comes close to what I need to do, and it would be great if we can get it working with Outlook 2013.
I see what the problem is - the code was messed up, it's just checking the accounts, not the message.
use this for the if -
If Item.SendUsingAccount = "name1" Then
Many thanks, Diane - this is now working perfectly. Thank you so much for your help - much appreciated.