Useful Outlook Macros

A few Outlook 2007 macros that I’m putting together during my lunch breaks in an attempt to make it easier to manage my e-mail in an effective fashion.

To use these, paste them into your macro editor and hang them off the Actions menu (if you only use a few) or create an “&X”¹ menu (to be invoked using Alt+X) and group them all there.

To enable macros, visit Tools – Macro – Macro Security, change the default settings and restart Outlook.

Sub Archive()
  Dim item As MailItem
   
  fileFolderName = "Archive"
  'First locate the actual folder and get its handle
  Set myolApp = CreateObject("Outlook.Application")
  Set myNamespace = myolApp.GetNamespace("MAPI")
  Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
  Set rootFolder = myInbox.Parent
  Set subFolders = rootFolder.Folders
  Set subFolder = subFolders.GetFirst
  Do While Not subFolder Is Nothing
    If subFolder.Name = fileFolderName Then
      fileEntryID = subFolder.EntryID
      Set fileFolder = myNamespace.GetFolderFromID(fileEntryID)
      Exit Do
    End If
    Set subFolder = subFolders.GetNext
  Loop
  'Now move all selected items there
  For Each item In Outlook.Application.ActiveExplorer.Selection
    item.Move fileFolder
  Next
End Sub

¹ As usual in Windows, the ampersand denotes the accelerator key bound to the menu.

The following script (that you can save to a .vbs file) generates a bare-bones HTML report from your current Tasks folder and prepares it for sending:

'Globals
Dim oOutlook
Dim oNamespace
Dim oFolder
Dim aItems
Dim oTask
Dim szBuffer
Dim aPriority 
Dim aStatus
Dim aPriorityColors
Dim aStatusColors

aPriority = Array("Low", "Medium", "High")
aStatus = Array("Not Started", "In Progress", "Completed", "Waiting on someone else", "Deferred")
aPriorityColors = Array("none", "yellow", "red")
aStatusColors = Array("red", "green", "green", "yellow", "blue")

'Constants
Const olMailItem = 0
Const olTaskItem = 3
Const olFolderTasks = 13


'Create Outlook, Namespace, Folder Objects and Task Item
Set oOutlook = CreateObject("Outlook.application")
Set oNamespace = oOutlook.GetNameSpace("MAPI")
Set oFolder = oNamespace.GetDefaultFolder(olFolderTasks)
Set aItems = oFolder.Items

szBuffer = "<table border=""1"" style=""font-family: Calibri"">" & vbCrLf &"<tr><th>Project</th><th>Task</th><th>Priority</th><th>Status</th><th>Due Date</th><th>Status</th><th>Notes</th></tr>" & vbCrLf 

'Build Table
nCount = 0
For Each oTask in aItems
  'oTask has the following properties - http://msdn2.microsoft.com/en-us/library/aa211067(office.11).aspx
  If oTask.Sensitivity=0 Then 'only non-private tasks
    szBuffer = szBuffer & "<tr>"
    szBuffer = szBuffer & "<td>" & oTask.BillingInformation & "</td>"
    szBuffer = szBuffer & "<td>" & oTask.Subject & "</td>"
    szBuffer = szBuffer & "<td>" & aPriority(oTask.Importance) & "</td>"
    szBuffer = szBuffer & "<td style=""background-color: " & aStatusColors(oTask.Status) &  """>" & aStatus(oTask.Status) & "</td>"
    if oTask.DueDate = "1/1/4501" Then 'Outlook stupidity
      szBuffer = szBuffer & "<td>None</td>" 
    else
      szBuffer = szBuffer & "<td>" & oTask.DueDate & "</td>"
    end if
    szBuffer = szBuffer & "<td>" & oTask.PercentComplete & "</td>"
    szBuffer = szBuffer & "<td>" & oTask.Body & "</td>"
    szBuffer = szBuffer & "</tr>"
  End If
Next

Set oMsg =  oOutlook.CreateItem(olMailItem)
oMsg.To = "Big Brother" 
oMsg.Subject = "Status Report - " & Date()
oMsg.Display
szBuffer = replace(szBuffer,vbCrLF,"<br>")
oMsg.HTMLBody = szBuffer

'Clean up
Set oFolder = Nothing
Set oNamespace = Nothing
set oOutlook = Nothing
set oMsg = Nothing