Managing email can be a challenge. I wanted to create a button that would simplify the process to send an email and direct the saved message to a particular folder instead of SentItems.
To be clear, the Outlook 2010 ribbon already has this feature, however it requires switching tabs, selecting the destination folder, changing tabs again and pressing Send. More often than not I find I forget to select the destination folder and have to move my sent messages manually.
The solution I created gives me a button that calls up a folder dialog so I can select the save to folder, when I click OK it also sends the message.
Setup is fairly easy. To begin, make sure you have created a self signed certificate using the Microsoft SelfCert utility. On my 64 bit system SelfCert.exe is located in the folder C:\Program Files\Microsoft Office\Office14. Just double click SelfCert.exe and type your name in the box to create a certificate.
Now that you have a certificate, let's setup the VBA code.
1. Open Microsoft Outlook 2. Press Alt+F11 3. On the left hand side, double click ThisOutlookSession 4. In the right hand pane, paste the following code
Sub SendAndFile() On Error Resume Next 'First find the current mail object Dim objMailItem As Object Set objMailItem = Application.ActiveInspector.CurrentItem Dim objNS As NameSpace Dim objFolder As MAPIFolder
If Item.Class = olMail Then ' used to act only on mail messages Set objNS = Application.GetNamespace("MAPI") 'Now browse to the folder to send to Set objFolder = objNS.PickFolder If Not objFolder Is Nothing Then If IsInDefaultStore(objFolder) Then 'Set the folder to save in to our choice Set objMailItem.SaveSentMessageFolder = objFolder End If Else Exit Sub End If End If 'Send the email message objMailItem.Send
Set objFolder = Nothing End Sub
Public Function IsInDefaultStore(objOL As Object) As Boolean Dim objApp As Outlook.Application Dim objNS As Outlook.NameSpace Dim objInbox As Outlook.MAPIFolder On Error Resume Next Set objApp = CreateObject("Outlook.Application") Set objNS = objApp.GetNamespace("MAPI") Set objInbox = objNS.GetDefaultFolder(olFolderInbox) Select Case objOL.Class Case olFolder If objOL.StoreID = objInbox.StoreID Then IsInDefaultStore = True End If Case olAppointment, olContact, olDistributionList, _ olJournal, olMail, olNote, olPost, olTask If objOL.Parent.StoreID = objInbox.StoreID Then IsInDefaultStore = True End If Case Else MsgBox "This function isn't designed to work " & _ "with " & TypeName(objOL) & _ " items and will return False.", _ , "IsInDefaultStore" End Select Set objApp = Nothing Set objNS = Nothing Set objInbox = Nothing End Function
5. Click Tools, Digital Signature 6. Click the Choose button and select your self signed certificate 7. Click the Save button 8. Close the VBA editor 9. Click the New Mail icon in the ribbon 10. Right click the blank space on the right side of the ribbon 11. Select "Customize the Ribbon" 12. Click New Group on the right side 13. Click Rename 14. Type Send and File then click OK 15. Select Macros from the dropdown on the left side 16. Select the Send and File macro on the left 17. Click Add>> 18. Select the macro on the right side and click Rename 19. Rename the text to "Send and File" 20. Select a different icon if desired 21. Click OK twice
You should now see a new icon on the new message screen's ribbon. Compose your email and use this new button instead
of the standard send button to allow you to send the email and be prompted for a folder to save the message in.
If you would like to add a button to the ribbon or quick launch to allow you to select multiple messages in your inbox or sent items and move them to a sub folder, the process is relatively the same as above. First right click on ThisOutlookSession and choose Insert> Module. Paste the following code into the new module window. Save the changes and add a button to your ribbon. You will now be able to select multiple items, press the button and specify what folder to move the items to. Note that you will likely need to close Outlook and re-open it for the new module to kick in.
Sub MoveToProjectFolder() On Error Resume Next
Dim ns As Outlook.NameSpace Dim MoveToFolder As Outlook.MAPIFolder Dim objItem As Outlook.MailItem
Set ns = Application.GetNamespace("MAPI")
'Now browse to the folder to send to Set MoveToFolder = ns.PickFolder
If Application.ActiveExplorer.Selection.Count = 0 Then MsgBox ("No item selected") Exit Sub End If
If MoveToFolder Is Nothing Then MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error" End If
For Each objItem In Application.ActiveExplorer.Selection If MoveToFolder.DefaultItemType = olMailItem Then If objItem.Class = olMail Then objItem.Move MoveToFolder End If End If Next
Set objItem = Nothing Set MoveToFolder = Nothing Set ns = Nothing