Determine a Folder for Sent Items

Save Email in a Subfolder of the Inbox

By default, all emails are stored in the 'Sent Items' folder. You can change the folder manually via the Options dialog of a message. However, if you want to save all messages in a different folder, you need a macro if you don't want to set the folder manually for each message.

The first sample stores all sent emails, except those you want to delete, in a subfolder of the inbox, which is called 'File'.

  How to add macros to Outlook

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
  If TypeOf Item Is Outlook.MailItem Then
    SaveSentMail Item
  End If
End Sub

Private Sub SaveSentMail(Item As Outlook.MailItem)
  Dim Inbox As Outlook.MAPIFolder
  Dim Subfolder As Outlook.MAPIFolder

  If Item.DeleteAfterSubmit = False Then
    Set Inbox = Application.Session.GetDefaultFolder(olFolderInbox)
    Set Subfolder = Inbox.Folders("File")
    Set Item.SaveSentMessageFolder = Subfolder
  End If
End Sub

Pick the Folder Manually

This sample displays the folder picker for each outgoing email. Press Cancel on the dialog if you want to store the message in the default folder.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
  If TypeOf Item Is Outlook.MailItem Then
    SaveSentMail Item
  End If
End Sub

Private Sub SaveSentMail(Item As Outlook.MailItem) 
  Dim F As Outlook.MAPIFolder

  If Item.DeleteAfterSubmit = False Then
    Set F = Application.Session.PickFolder
    If Not F Is Nothing Then
      Set Item.SaveSentMessageFolder = F
    End If
  End If
End Sub

File Depending on the Sending Account

This sample checks the name of the sending account and saves the sent message in a determined subfolder of the inbox. Add as many Cases as you need, and add the names of your accounts and the names of the subfolders.

This sample works only for Outlook 2007 and higher.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
  If TypeOf Item Is Outlook.MailItem Then
    SaveSentMail Item
  End If
End Sub

Private Sub SaveSentMail(Item As Outlook.MailItem)
  Dim Inbox As Outlook.Folder
  Dim SubFolder As Outlook.Folder

  If Item.DeleteAfterSubmit = False Then
    Set Inbox = Application.Session.GetDefaultFolder(olFolderInbox)

    Select Case LCase$(Item.SendUsingAccount.DisplayName)
    Case "Account_1"
      Set SubFolder = Inbox.Folders("Folder_1")
    Case "Account_2"
      Set SubFolder = Inbox.Folders("Folder_2")
    End Select

    If Not SubFolder Is Nothing Then
      Set Item.SaveSentMessageFolder = SubFolder
    End If
  End If
End Sub