I hate Outlook, but unfortunately one has to use it for work purposes, and since I’m partially responsible for supporting exchange, I tend to get users that whine about how Outlook works out-of-the-box.

By default, when using ‘Send As’ permissions to send email from an attached account, Outlook will save the sent item to your own personal mailbox. This is not desired by a lot of people. Sure, Outlook allows you to change where you want the Sent Item to be stored, but it does not work if you select another mailbox’s Sent Items folder. How annoying.

Fortunately, VBA comes to the rescue.

After a lot of googling, I managed to find some code that would do what I wanted, however it only worked for one additional mailbox, and you had to hardcode the mailbox name and “From” information inside the code. Unfortunately most of the users that work here regularly utilise more than one shared mailbox, so I set about to change the code so it would work dynamically. I’ve never coded in VBA before, and have barely touched VB before this (hello login vbscripts), so there are probably much better ways to achieve this.

To install the script, copy it into the clipboard, run Outlook, press ALT+F11 to open the macro editor, expand Project1, expand ‘Microsoft Office Outlook Objects’, and double click ‘ThisOutlookSession’.

Paste the code into the window on the right hand side. Save the macro, then restart Outlook.

You don’t need to change anything in the code, it just works.


' 03 November 2009
' Sent Items go to the correct mailbox when using Send-As permissions
' Run Outlook, press ALT+F11, go to ThisOutlookSession, and paste the code in.
' Restart Outlook
'
Private WithEvents objSentItems As Items
Private MailItem As Outlook.MailItem
Private lo_Folder As Outlook.Folder
Private ar_FolderNames() As String
Private RunSentItemsEvent As Boolean
Private ar_SentStoreID() As String
Private ar_SentEntryID() As String
Private intFolderUBound As Integer

Public Sub Application_Startup()
Dim sfCount As Integer
 If FindAdditionalStores = True Then
 'Code only executes IF there are additional mailboxes attached.
   Set objSentItems = Application.Session.GetDefaultFolder(olFolderSentMail).Items
   'For speed, causes the SentItems_Add event to fire only if there are mailboxes attached. No point otherwise.
   RunSentItemsEvent = True
   'Set this to reduce calls to UBound(ar_FolderNames)
   intFolderUBound = UBound(ar_FolderNames)
   'Initialize the array
   ReDim ar_SentStoreID(0 To intFolderUBound)
   ReDim ar_SentEntryID(0 To intFolderUBound)
   'Retrieve ID for accessing non-default sent folder
   For sfCount = 0 To intFolderUBound
       getStoreFolderID ar_FolderNames(sfCount), sfCount
   Next
 End If
End Sub

Sub getStoreFolderID(StoreName As String, Idx As Integer)
'Retrieves the StoreID of the "Sent Items" folder for the specified mailbox
  Dim Store As Object
  Dim StoreFolder As Object
  Dim i As Integer
  Set Store = Application.GetNamespace("MAPI").Folders
  For Each StoreFolder In Store
    If StoreFolder.Name = StoreName Then
      For i = 1 To StoreFolder.Folders.Count
        If StoreFolder.Folders(i).Name = "Sent Items" Then
           ar_SentEntryID(Idx) = StoreFolder.Folders(i).EntryID
           ar_SentStoreID(Idx) = StoreFolder.Folders(i).StoreID
           Exit For
        End If
      Next
    Exit For
    End If
  Next
  Set Store = Nothing
  Set StoreFolder = Nothing
End Sub

Function FindAdditionalStores() As Boolean
'Retrieves the additional attached mailboxes
 Dim mCount As Integer
  mCount = 0
 For Each lo_Folder In Application.Session.Folders
    If InStr(lo_Folder.Name, "Mailbox") <> 0 Then
'Ignore the default mailbox.
    If lo_Folder.Name <> Application.Session.DefaultStore Then
      'Populate and resize the array
         ReDim Preserve ar_FolderNames(0 To mCount)
         ar_FolderNames(mCount) = lo_Folder.Name
         mCount = mCount + 1
      End If
    End If
 Next
 FindAdditionalStores = IsArrayAllocated(ar_FolderNames)
End Function

Private Function IsArrayAllocated(Arr As Variant) As Boolean
' Thanks to http://www.cpearson.com/excel/isarrayallocated.aspx
' for this code
  On Error Resume Next
  IsArrayAllocated = IsArray(Arr) And _
    Not IsError(LBound(Arr, 1)) And _
    LBound(Arr, 1) < = UBound(Arr, 1)
End Function

Private Sub objSentItems_ItemAdd(ByVal Item As Object)
'Fires when a mail hits the default "Sent Items" folder.
Dim fCount As Integer
fCount = 0
  'Safety Check. No point in running the code if there are no additional mailboxes.
  If RunSentItemsEvent = True Then
    If TypeOf Item Is Outlook.MailItem Then
      With Item
        Set MailItem = Application.GetNamespace("MAPI").GetItemFromID(.EntryID, .Parent.StoreID)
      End With
      For fCount = 0 To intFolderUBound
        'Don't know if this code will work outside of this environment. Essentially it just strips the text "Mailbox - " from the folder name
        If MailItem.SentOnBehalfOfName = Right(ar_FolderNames(fCount), Len(ar_FolderNames(fCount)) - 10) Then
            Set DestinationFolder = Application.Session.GetFolderFromID(ar_SentEntryID(fCount), ar_SentStoreID(fCount))
            MailItem.Move (DestinationFolder)
        End If
      Next
    End If
    Set MailItem = Nothing
  End If
End Sub