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
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.
Code:
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
End Sub
