Thread: Save emails sent on behalf of another mailbox in correct sent items folder

Not a question, just something I've put together to solve an issue we've had at work which I thought I'd share.

I have multiple mailboxes on my Outlook account and am able to send items either from myself or on behalf of any of them. The problem was that all sent items were being stored in my sent items not the ones relating to the other mailboxes. This made keeping an audit trail difficult and meant I had to manually remember to copy the items I'd sent on behalf of another mailbox into the correct folder which was a pain.

The following code checks if an email has been sent on behalf of another mailbox and if so moves it into the correct one. All our mailboxes are called "Mailbox - mailbox name" which I'm not sure if is standard as I'm pretty new to using Outlook. The code would need amending if your mailboxes are differently named.

The code needs to be placed on the ThisOutlookSession of your Outlook VBA Project.

I'm new to coding in Outlook and not an expert so there may be issues I've not picked up.

Hope it helps someone anyway.

Dom

Private Sub Application_MAPILogonComplete()
  
  '   Set the sent items to process
    
    Dim objNS As Outlook.NameSpace
    Dim objSentFolder As Outlook.MAPIFolder
    Set objNS = Application.GetNamespace("MAPI")
    strDefaultName = objNS.CurrentUser
    Set objSentFolder = objNS.GetDefaultFolder(olFolderSentMail)
    Set sentItems = objSentFolder.Items
    Set objSentFolder = Nothing
    Set objNS = Nothing

End Sub

Private Sub Application_Quit()
     
     Set sentItems = Nothing

End Sub


Private Sub SentItems_ItemAdd(ByVal Item As Object)

  '   Dom Hill, Leeds City Council - Business Support Centre, 6th April 2010

Dim objDestFolder As Outlook.MAPIFolder

If TypeOf Item Is Outlook.MailItem Then
  '   Check if sent on behalf of someone
    If Item.SentOnBehalfOfName <> strDefaultName Then
   
  '   Attempt to retrieve sent items folder from required mailbox
        Set objDestFolder = GetFolder("Mailbox - " & Item.SentOnBehalfOfName & "\Sent Items")
  '   If sent items folder is set then move sent items to that mailbox's
        If Not objDestFolder Is Nothing Then
            Item.Move objDestFolder
        End If
    End If
End If

Set objDestFolder = Nothing

End Sub


Public Function GetFolder(strFolderPath As String) As MAPIFolder
  
  '   borrowed from Sue Moshers site: http://www.outlookcode.com/d/code/getfolder.htm
  
  '   strFolderPath needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales" or
  '   "Personal Folders\Inbox\My Folder"

  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.MAPIFolder
  Dim arrFolders() As String
  Dim I As Long
  On Error Resume Next

  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders() = Split(strFolderPath, "\")
  Set objApp = Application
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For I = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(I))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If

  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function

Edits:

Changed code to use Application_MAPILogonComplete rather than Application_Startup as it can be a bit flaky
Also realised it was moving all sent mail to the correct Sent Mail folder so updated to avoid processing mail sent from the default mailbox.