Outlook “Send and archive”

Do you still save all your incoming emails in separate folders and keep all your outgoing emails in your sent items folder? Here’s a VBA macro for Outlook (2000 – 2010 beta) that allows you to archive emails to the folder of your choice right when you click on “Send e-mail”.

In addition, it will also look for keywords that indicate that you wanted to attach a file, but forgot it.

Installation instructions:

1. Open Visual Basic Editor in Outlook with Alt-F11.
2. Choose “ThisOutlookSession”. This file should be empty for most users.
   
3. Copy the macro code into the file and select “Debug” -> “Compile” to make sure there are no errors.
4. Close the VB Editor
5. Change your macro security settings to allow macros with notifications.
6. Restart Outlook.

If you have trouble send an email to michael@designitsimple.de

VBA code

Dim objFolder As MAPIFolder

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'************************************
' Author:           Michael Hartmann, michael@designitsimple.de
' Description:      Performs various checks upon sending an email
'
' Version
' 1.0, July 24, 2006: Creation
' 1.1, June 21, 2010: Deleted check for IsInDefaultStore
'************************************

 ' Variable declaration
 Dim objNS As NameSpace
 Dim colKeywords As New Collection
 Dim vntRecipients As Variant
 Dim bolExternalEmail As Boolean

 ' Set variables
 Set objNS = Application.GetNamespace("MAPI")

 ' Set up list of keywords that you use when attaching files
 colKeywords.Add "attachement"
 colKeywords.Add "Attachement"
 colKeywords.Add "attached"
 colKeywords.Add "Attached"

 ' Check for attechment keywords and check for number of attachments
 If checkForKeywords(colKeywords, Item.Body) And (Item.Attachments.Count = 0) Then

 ' If attachments should be in email ask for continue
 If MsgBox("Attachement missing. Send e-mail anyway?", vbYesNo) = vbNo Then
 Cancel = True
 Exit Sub
 End If

 End If

 ' Check for subject
 If Item.Subject = "" Then
 MsgBox "Please specify a subject"
 Cancel = True
 Exit Sub
 End If

 ' Only enable actions for emails
 If Item.Class = olMail Then

 ' Get folder to save email
 Set objFolder = objNS.PickFolder

 ' Check if folder has been specified
 If TypeName(objFolder) <> "Nothing" Then

 ' If folder has been specified move email
 Set Item.SaveSentMessageFolder = objFolder
 Else
 ' Otherwise do not send email and get back to email
 Cancel = True
 End If

 End If

send_message:
 ' Unset everything
 Set objFolder = Nothing
 Set objNS = Nothing

End Sub

Private Function checkForKeywords(colKeyWordList As Collection, strText As String) As Boolean
'************************************
' Author:           Michael Hartmann, michael@designitsimple.de
' Last modified:    August, 8th 2006
'
' Description:      Checks for certain keywords from a collection in a string
'************************************

 ' Variable declaration
 Dim varKeyword As Variant

 ' Set initial return variable.
 checkForKeywords = False

 For Each varKeyword In colKeyWordList
 If (InStr(1, strText, varKeyword, vbTextCompare) > 0) Then
 checkForKeywords = True
 Exit Function
 End If
 Next

End Function