Code Sample Pages

Resend This Message -- automation code -- added 2/25/2008

Event Code to move emails -- NEW! added 4/27/2008

Code Samples

Etiquette Check Code

I am a big believer in netiquette, that is why I use the ItemSend event of the Outlook Application object to monitor my outgoing emails for appropriate subject line, number of attachments, etc. Just replace "part of your signature line" in the code with a line from your signature that would only appear if it was in the email. For example, your phone number or full name.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) ' ' code to manipulate emails after hitting 'Send', but just before they are ' actually sent ' If TypeName(Item) = "MailItem" Then ' we only want to work on messages, not contacts/notes etc Dim olApp As Application Dim objNS As NameSpace Dim objFolder As MAPIFolder Dim Msg As MailItem Dim sRecip As Recipient Set olApp = Application Set objNS = olApp.GetNamespace("MAPI") ' set object reference to item passed byval so we can manipulate Set Msg = Item ' test for missing recipients If Msg.Recipients.Count = 0 Then Cancel = True MsgBox "There are no recipients." & _ Please select a recipient and re-send your message.", vbCritical Msg.Display GoTo ErrorHandle End If ' test for invalid subject lines & empty body Select Case Msg.Subject Case "", "Re:", "RE:", "FW:" Cancel = True MsgBox "You are sending a message without a subject." & vbCr & _ vbCr & "Please correct before sending.", vbCritical Msg.Display GoTo ErrorHandle End Select If Len(Msg.Body) < 2 Then Cancel = True MsgBox "You are sending a message without any body text." & vbCr & _ vbCr & "Please correct before sending.", vbCritical Msg.Display GoTo ErrorHandle End If ' check for too many attachments (or too large), it's rude If Msg.Attachments.Count > 2 Then If MsgBox("You are sending more than 2 attachments." & _ "Some people might consider this rude. Continue?", _ vbYesNo + vbInformation) = vbNo Then Cancel = True Msg.Display GoTo ErrorHandle End If End If If (Msg.Attachments.Count > 0) And (Msg.Size > 100000) Then If MsgBox("Your email is pretty big, do you want to stop " & _ "and zip the attachment(s)?", vbYesNo + vbExclamation) _ = vbYes Then Cancel = True Msg.Display GoTo ErrorHandle End If End If ' check for missing attachments If InStr(Msg.Body, "attach") And (Msg.Attachments.Count = 0) Then If MsgBox("An attachment was mentioned, but there is no " & _ "attachment to this email. Send anyway?" _ , vbYesNo + vbExclamation + vbDefaultButton1) = vbNo Then Cancel = True Msg.Display GoTo ErrorHandle End If End If End If ' check for missing signature, it's rude, but allow send anyway If InStr(Msg.Body, "part of your signature line") = 0 Then If MsgBox("You forgot your signature!" & vbCr & _ "Do you want to add it first?", vbYesNo _ + vbExclamation) = vbYes Then Cancel = True Msg.Display GoTo ErrorHandle End If End If End If ErrorHandle: Set Msg = Nothing Set objNS = Nothing Set objFolder = Nothing Set olApp = Nothing End Sub

Redirect E-Mail message

This macro, added to the email toolbar and/or the Explorer toolbar, will forward the active/selected mail item to the recipient of your choice. The original sender of the mail and the newly selected recipient are placed in the "To:" field. Replies are directed to the newly selected recipient (via Options button, 'Send Replies To') and everyone else from the original email is CC'd (so they can ignore). You can also disable 'Reply To All' so the original sender or the new recipient can't send any more irrelevant emails to you.

Sub RedirectMail() ' ' This macro forwards the active mail item, or if you are in the explorer window, ' select one email and run this code '1. The original sender of the mail, and the newly selected recipient are placed ' in the "To:" field '2. Directs replies to the newly selected recipient '3. Add everybody else on the CC line (so they can safely ignore, since they ' shouldn't have received it in the first place) '4. Disables "Reply to All" (optional) ' based on OL2007 code from aaronlerch.com ' Dim CurrMail As Outlook.MailItem Dim NewFwd As Outlook.MailItem Dim sRecipient As Outlook.Recipient Dim CorrRecip As String Dim DisableReplyToAll As VbMsgBoxResult Dim i As Long On Error Resume Next Set CurrMail = ActiveInspector.CurrentItem If CurrMail Is Nothing Then ' we might be in the explorer window If (ActiveExplorer.Selection.Count = 1) And _ (ActiveExplorer.Selection.Item(1).Class = olMail) Then Set CurrMail = ActiveExplorer.Selection.Item(1) End If End If On Error GoTo 0 If CurrMail Is Nothing Then ' either a mail msg is not open, or more than one email selected in explorer ' window, or no email selected at all, cannot set ref MsgBox "I was not able to forward an email. Please run this code ONLY " & _ "under one of the following conditions:" & vbCr & vbCr & _ "-- You are viewing a single email message." & vbCr & _ "-- You are in your Inbox and have exactly one message selected.", _ vbInformation GoTo ExitProc End If Set NewFwd = CurrMail.forward NewFwd.Display ' delete any "direct replies to" recipients of newly forwarded msg, usually zero If (NewFwd.ReplyRecipients.Count > 0) Then For i = 1 To NewFwd.ReplyRecipients.Count NewFwd.ReplyRecipients.Remove (i) Next i End If ' find out who the email should have gone to, and add them to 'To' field CorrRecip = InputBox("Who should this email have gone to?" & vbCr & vbCr & _ "Enter ONE email address, distribution list, or display name.") DisableReplyToAll = MsgBox("Would you like to disable 'Reply To All'?", _ vbYesNo + vbDefaultButton1) Select Case DisableReplyToAll Case vbYes ActiveInspector.CurrentItem.Actions("Reply to All").Enabled = False Case Else End Select With NewFwd ' add correct recipient as specified to the "direct replies to" option box, ' that way they get any replies if the original sender hits Ctrl-R .ReplyRecipients.Add (CorrRecip) ' add original sender & correct recipients to TO field .Recipients.Add(CurrMail.SenderEmailAddress).Type = olTo .Recipients.Add(CorrRecip).Type = olTo ' add original recipient(s) to CC field For Each sRecipient In CurrMail.Recipients Set sRecipient = .Recipients.Add(sRecipient.Name) With sRecipient .Type = olCC .Resolve End With Next sRecipient ' If NewFwd.BodyFormat <> olFormatHTML Then NewFwd.HTMLBody = "Hello " & Left$(CurrMail.SenderName, _ InStr(1, CurrMail.SenderName, " ") - 1) & "," & _ "I think you sent this to the wrong distribution list. " & _ I am redirecting to the appropriate parties and CC’ing original recipients. Thx all!" & NewFwd.HTMLBody ' Else ' NewFwd.Body = "Hello " & _ Left$(CurrMail.SenderName, InStr(1, CurrMail.SenderName, " ") - 1) & _ "," & vbCr & "I think you sent this to the wrong distribution list." & _ vbCr & "I am redirecting to the appropriate parties and CC’ing original recipients." & NewFwd.Body ' End If .Recipients.ResolveAll .ReplyRecipients.ResolveAll .Display '.Send End With ExitProc: Set CurrMail = Nothing Set NewFwd = Nothing Set sRecipient = Nothing End Sub

Download the code here.

This code is adapted from code found at Aaron Lerch's blog and also some excellent code at Scott Hanselman's blog.

Creating Followup Tasks

This macro, attached to a toolbar button in a mail message, creates a followup task on the email and attaches the original msg to the task. You can also run it from the explorer window, just select ONE email message, then run the code. This is based on code found in Sue Mosher's book (check the Programmer's Library) and here as well. I recommend you drag this macro to one of the Explorer toolbars, and also open a mail message and add it to one of the message toolbars, so you can use it in either circumstance.

Sub CreateFollowUpTask() ' ' you can specify how many (business) days later you want the reminder ' ' don't forget to include the 'NextBusinessDay' function as well, if you copy ' this code somewhere else ' Dim objNS As Outlook.NameSpace Set objNS = Application.GetNamespace("MAPI") If objNS.GetDefaultFolder(olFolderInbox).Parent = "Mailbox - Jimmy Pena" Then Dim objItem As Outlook.MailItem Dim objTask As Outlook.TaskItem Dim NumOfDays As Integer Dim DayToRemind As Date Const attPath As String = "C:\" ' set reference to email being viewed ' ' if we are running this code from the Inbox, then no email would be ' displayed, so we'll try to check the selection first ' On Error Resume Next Set objItem = Outlook.ActiveInspector.CurrentItem If objItem Is Nothing Then ' we are probably in the explorer window If (ActiveExplorer.Selection.Count = 1) And _ (ActiveExplorer.Selection.Item(1).Class = olMail) Then Set objItem = ActiveExplorer.Selection.Item(1) End If End If On Error GoTo 0 If objItem Is Nothing Then ' no email was displayed and no email was selected from the explorer window, ' cannot set reference to anything MsgBox "I was not able to create a task. Please run this code ONLY " & _ "under one of the following conditions:" & vbCr & vbCr & _ "-- You are viewing an email message." & vbCr & _ "-- You are in your Inbox and have exactly one message selected.", _ vbInformation GoTo ExitProc End If Set objTask = Outlook.CreateItem(olTaskItem) ' ask for days input NumOfDays = InputBox("How many business days until reminder?") ' get date of next business day using function below DayToRemind = NextBusinessDay(Format(Now, "M/D/YYYY"), NumOfDays) With objTask .StartDate = DayToRemind .Subject = "Reminder For Followup: " & objItem.Subject .Status = olTaskInProgress .Importance = objItem.Importance .DueDate = DayToRemind .ReminderSet = True ' embed original email in the task ' ' first, save message copy objItem.SaveAs attPath & objItem.EntryID ' then, embed message copy objTask.Attachments.Add attPath & objItem.EntryID, olEmbeddeditem, , "Original Message" ' last, delete saved copy Kill (attPath & objItem.EntryID) .Save End With End If ExitProc: Set objTask = Nothing Set objItem = Nothing Set objNS = Nothing End Sub Function NextBusinessDay(dteDate As Date, intAhead As Integer) As Date Dim dteNextDate As Date dteNextDate = DateAdd("d", intAhead, dteDate) Select Case Weekday(dteNextDate) ' if Sunday, add 1 day to make it next business day (Monday) Case 1 dteNextDate = dteNextDate + 1 ' if Saturday, add 2 days to make it next business day (Monday) Case 7 dteNextDate = dteNextDate + 2 End Select NextBusinessDay = dteNextDate End Function

Lunch Special

A routine (that works in Excel as well) that pops up a MsgBox with a random msg. In this case, it a fun app that helps me choose what to eat for lunch. I can see many other uses for this code. I use the same code in the Application_Startup event to pop up a random msg when Outlook starts.

Sub PickLunchForMe() Dim X As Integer Randomize X = Int((5 - 1) * Rnd + 1) Select Case X Case 1 MsgBox "Deli" Case 2 MsgBox "Spanish food" Case 3 MsgBox "Chinese food" Case 4 MsgBox "Diner (American food)" Case 5 MsgBox "Tex Mex" Case Else End Select End Sub

I attach this code to a toolbar button to run it on demand. If you have a different number of options, simply change the "5" in the code to whatever number you want. For example, if you had 10 options, the code would read X = Int((10 - 1) * Rnd + 1). Then you would need to add additional "Case" statements as appropriate. Hopefully your meal choices are better than mine.

Create Excel Workbook (From Outlook)

Sub CreateXLWorkbook() Dim xlApp As Excel.Application Dim xlWkb As Excel.Workbook Set xlApp = New Excel.Application Set xlWkb = xlApp.Workbooks.Add xlApp.Visible = True Set xlApp = Nothing Set xlWkb = Nothing End Sub

Automate Outlook, open Excel and run Macro on .xls file attachment

Oftentimes I find it extremely useful to completely automate some macro process; to make a procedure completely hands-off. I can leave Outlook running 24/7 and then use a procedure like the one below to run an Excel macro from Outlook.

This code runs as an event, checking each incoming email for certain characteristics. If an email matches the profile, it opens the attachment (by saving it first), runs a pre-written macro, then cleans up and moves the now-processed email out of the Inbox to another folder.

You could easily adapt this code to many other purposes, for example, set up an automated file request system in your office. Users would email you with specific words in the subject, and, in response, your code could run a macro or attach a specific file to a blank email and send it back to them.

First thing you will need to do is declare a new class by putting this line at the top of your ThisOutlookSession module:

Private WithEvents Items As Outlook.Items

ThisOutlookSession is a built-in class module, so I usually put all my event/class code here to avoid confusion.

Then, in the Application_Startup() event, place the following code to instantiate the Items class:

Dim objNS As Outlook.NameSpace Dim X As Integer Set objNS = GetNamespace("MAPI") Set Items = objNS.GetDefaultFolder(olFolderInbox).Items

If you don't already have a Startup event, simply add Private Sub Application_Startup() to the top of the above code, and End Sub to the bottom. This will tell Outlook that there will be some events associated with the Items collection.

Once you paste in the code above, you will be able to choose the Items class from the dropdown boxes at the top of the VBE code window. The dropdown box on the right will show you the possible events you can monitor from the Items collection.

Outlook VBE

Finally, here is where the real work gets done. The code monitors the default Inbox for any new items added. If they are mail messages, it checks the sender, subject and number of attachments. We have already pre-determined where the email will come from, the subject line and how many attachments. The code will open the attached workbook, run a pre-written macro on it, then move the email to our storage folder, all without any user input needed.

Private Sub Items_ItemAdd(ByVal Item As Object) Dim objNS As Outlook.NameSpace Set objNS = GetNamespace("MAPI") If TypeOf Item Is Outlook.MailItem Then Dim Msg As Outlook.MailItem Set Msg = Item If (Msg.SenderName = "My Favorite Sender") And (Msg.Subject = "Email I Need to Open") And (Msg.Attachments.Count = 1) Then ' open wkbk and run import macro Dim olDestFldr As Outlook.MAPIFolder Dim myAttachments As Outlook.Attachments Dim XLApp As Excel.Application Dim XlWK As Excel.Workbook Dim Att As String Const attPath As String = "C:\" Set olDestFldr = objNS.Folders("Mailbox - My Personal PST Box").Folders("Inbox").Folders("Messages") Set XLApp = New Excel.Application ' save attachment Set myAttachments = Item.Attachments Att = myAttachments.Item(1).DisplayName myAttachments.Item(1).SaveAsFile attPath & Att ' open personal.xls where macro is stored, just in case it doesn't open on its own On Error Resume Next XLApp.Workbooks.Open ("C:\Documents and Settings\username\Application Data\Microsoft\Excel\XLSTART\PERSONAL.XLS") On Error GoTo 0 ' open workbook and run macro XLApp.Workbooks.Open (attPath & Att) XLApp.Run ("PERSONAL.XLS!MacroName") XLApp.Workbooks.Close Kill attPath & Att XLApp.Quit ' mark as read and move to msgs folder Msg.UnRead = False Msg.Move olDestFldr End If Set myAttachments = Nothing Set XLApp = Nothing Set olDestFldr = Nothing Set Msg = Nothing Set objNS = Nothing End If End Sub

And don't forget to check out the Excel code samples while you are here.