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:
- Open Visual Basic Editor in Outlook with Alt-F11.
- Choose “ThisOutlookSession”. This file should be empty for most users.
- Copy the macro code into the file and select “Debug” -> “Compile” to make sure there are no errors.
- Close the VB Editor
- Change your macro security settings to allow macros with notifications.
- 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
' Last modified: July, 24 2006
'
' Description: Performs various checks upon sending an email
'************************************
' 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" And IsInDefaultStore(objFolder) 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
Public Function IsInDefaultStore(objOL As Object) As Boolean
'************************************
' Author: Michael Hartmann, michael@designitsimple.de
' Last modified: August, 8th 2006
'
' Description: Checks if folder is in default store
'************************************
' Variable declaration
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
' Start error handling
On Error Resume Next
' Initialize variables
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
' Check folder class
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
' Unset variables
Set objApp = Nothing
Set objNS = Nothing
Set objInbox = Nothing
End Function
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