Sending an email from a automapped (usually shared) mailboxes – I don’t know why, because everyone hates that – has two issues: 1. user needs to change From address every time from his primary mailbox to the correct one, 2. Sent emails are saved in primary mailbox Sent folder, not in the folder of the shared mailbox.
We want Outlook to use From address based on selected folder in Outlook and also, we want this email to be saved in correct Sent folder. This issue has been present ever since and MS approach to first spit out registry hacks and then enable setting some parameters – only for each Mailbox separately (!) to deal with issue #2 is unacceptable. As usually we need to make some hacks to fix that.
Private WithEvents objInspectors As Outlook.Inspectors
Private WithEvents sentItems As Outlook.Items
Function findAddressOfCurrentFolder()
Set selectedFolder = Application.ActiveExplorer.CurrentFolder
' Initialize the Outlook NameSpace
Set namespace = Application.GetNamespace("MAPI")
Set Stores = namespace.Stores
storeDisplayName = selectedFolder.Parent.Store.DisplayName
Set storeRecipient = Session.CreateRecipient(storeDisplayName)
If storeRecipient.AddressEntry.Type = "EX" Then
findAddressOfCurrentFolder = storeRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
If storeRecipient.AddressEntry.Type = "SMTP" Then
findAddressOfCurrentFolder = storeRecipient.Address
End If
End Function
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If TypeName(Inspector.CurrentItem) = "MailItem" Then
storeSMTPAddress = findAddressOfCurrentFolder
If storeSMTPAddress <> "" Then
Inspector.CurrentItem.SentOnBehalfOfName = storeSMTPAddress
End If
End If
End SubWe just fixed the first issue! One more to go.
Function isSentItemsFolder(ByVal Folder As Outlook.Folder)
sentFolderNames = Array("Sent Items", "Odeslaná pošta", "Odoslaná pošta")
For i = LBound(sentFolderNames) To UBound(sentFolderNames)
If sentFolderNames(i) = Folder.Name Then
isSentItemsFolder = True
Exit Function
End If
Next i
isSentItemsFolder = False
End Function
Private Sub sentItems_ItemAdd(ByVal Item As Object)
Dim correctSentFolder As Outlook.Folder
Dim myNamespace As Outlook.namespace
Dim mailbox As Outlook.MAPIFolder
If TypeName(Item) = "MailItem" Then 'If Item is a MailItem
If Item.SentOnBehalfOfName <> Session.Accounts.Item(1).CurrentUser Then 'And if Item is Sent on Behalf of the users own inbox
'Move the email into the Sent Items folder for the inbox in question
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = GetNamespace("MAPI").CreateRecipient(Item.SentOnBehalfOfName)
myRecipient.Resolve
If myRecipient.Resolved Then
'Set sentFolder = GetNamespace("MAPI").GetSharedDefaultFolder(myRecipient, olFolderSentMail)
Set mailbox = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderInbox).Parent
For Each Folder In mailbox.Folders
If Folder.DefaultItemType = olMailItem Then
If (isSentItemsFolder(Folder)) Then
Set correctSentFolder = Folder
End If
End If
Next Folder
End If
If Not correctSentFolder Is Nothing Then Item.Move correctSentFolder
End If
End If
End SubAnd that’s the fix for the second issue – saving items in proper folder. There is no way to get Sent folder of a shared/automapped mailbox. We need to iterate and check for its names. If English is used “Sent Items” is sufficient. For other languages, we need to add translations (function isSentItemsFolder).