Keep sent items in the Additional Mailbox' Sent Items

I have an additonal mailbox attached to my outlook as does a number of people in my office but when we reply to or send an email from the additional mailbox the sent email is in the sent items of my account not the Additional Mailbox.

I know there is a reg setting to change the location of the deleted items but is there one for the sent items??
Who is Participating?
David LeeConnect With a Mentor Commented:
Here's the code for doing this.  Follow these instructions to use it.

1.  Start Outlook.
2.  Click Tools->Macro->Visual Basic Editor.
3.  If not already expanded, expand Modules and click on Module1.
4.  Copy the code below and paste it into the right-hand pane of the VB Editor.
5.  Edit the code as needed.  I placed comments where things must/should be edited.
6.  Click the diskette icon on the toolbar to save the changes.
7.  Close the VB Editor.
8.  Click Tools->Macro->Security.
9.  Change the Security Level setting to Medium.

This works by monitoring the Sent Items folder.  When an item hits the folder the code fires.  It checks the item to see if it's a mail message.  If it is, then it checks the sender name.  If the name matches the one specified in code, then it moves the message to the folder of your choice, in this case the Sent Items folder of the other user's mailbox.
Private WithEvents olkSentItems As Outlook.Items
Private Sub Application_Quit()
    Set olkSentItems = Nothing
End Sub
Private Sub Application_Startup()
    Set olkSentItems = Session.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub olkSentItems_ItemAdd(ByVal Item As Object)
    Dim olkFolder As Outlook.MAPIFolder
    If Item.Class = olMail Then
        'Change the name on the following line as needed.  It will have to match the name in the message exactly.'
        If Item.SenderName ="SomeName" Then
            'Change the folder path on the following line to that of the folder you want the item moved to'
            Set olkFolder = OpenOutlookFolder("Mailbox - Doe, John\Sent Items")
            Item.Move olkFolder
        End If
    End If
    Set olkFolder = Nothing
End Sub
Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
    IsNothing = False
  End If
End Function
Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        olkFolder As Outlook.MAPIFolder
    On Error GoTo ehOpenOutlookFolder
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
        If Left(strFolderPath, 1) = "\" Then
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        End If
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            If IsNothing(olkFolder) Then
                Set olkFolder = Session.Folders(varFolder)
                Set olkFolder = olkFolder.Folders(varFolder)
            End If
        Set OpenOutlookFolder = olkFolder
    End If
    On Error GoTo 0
    Exit Function
    Set OpenOutlookFolder = Nothing
    On Error GoTo 0
End Function

Open in new window

You can have a look at this KB article from MS:

Otherwise this tool may help:

Although not free....
David LeeCommented:
Hi, mitre-technical.  

If you don't want to pay for a solution and don't mind using a script based solution, then I can provide a script that'll do this.
mitre-technicalAuthor Commented:
I dont really want to shell out any money so i would be interested in a script based solution
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.