Flag an Email for Follow-up

For Outlook 2007 and higher

Do you also have your rules for flagging e-mails for follow-up? For instance, less urgent items for 'this evening'; see whether or not the customer has answered yet for 'next week', etc. This VBA sample helps you save some time by determining a date and time for certain cases.

The main piece is the following procedure. Pass to it the number of days for when the task should be due (0 for today, 1 for tomorrow, etc.). Optionally you can also pass a time, and a subject for the task. See also some samples below for calling the procedure.

Either paste the code into the existing module 'ThisOutlookSession', or add a new 'Module' and paste the code there.

  How to add macros to Outlook

Public Sub MarkItemAsTask(ByVal AddDays As Long, _
  Optional TimeOfDay As String = "08:00", _
  Optional Subject As String, _
  Optional Mail As Outlook.MailItem _
)
  Dim Items As VBA.Collection
  Dim obj As Object
  Dim i As Long
  Dim dt As Date
  Dim tm As String
  Dim Icon As OlMarkInterval
  
  dt = DateAdd("d", AddDays, Date)
  tm = CStr(dt) & " " & TimeOfDay
  
  If AddDays < 1 Then
    Icon = olMarkToday
  ElseIf AddDays = 1 Then
    Icon = olMarkTomorrow
  ElseIf Weekday(Date, vbUseSystemDayOfWeek) + AddDays < 8 Then
    Icon = olMarkThisWeek
  Else
    Icon = olMarkNextWeek
  End If
  
  If Mail Is Nothing Then
    Set Items = GetCurrentItems
  Else
    Set Items = New VBA.Collection
    Items.Add Mail
  End If
  
  For Each obj In Items
    If TypeOf obj Is Outlook.MailItem Then
      Set Mail = obj
      Mail.MarkAsTask Icon
      Mail.TaskStartDate = tm
      Mail.TaskDueDate = tm
      If Len(Subject) Then
        Mail.TaskSubject = Subject
        Mail.FlagRequest = Subject
      End If
      Mail.ReminderTime = tm
      Mail.ReminderSet = true
      Mail.Save
    End If
  Next
End Sub

Private Function GetCurrentItems() As VBA.Collection
  Dim c As VBA.Collection
  Dim Sel As Outlook.Selection
  Dim obj As Object
  Dim i&
  
  Set c = New VBA.Collection
  
  If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
    c.Add Application.ActiveInspector.CurrentItem
  Else
    Set Sel = Application.ActiveExplorer.Selection
    If Not Sel Is Nothing Then
      For i = 1 To Sel.Count
        c.Add Sel(i)
      Next
    End If
  End If
  Set GetCurrentItems = c
End Function

Here come two samples for how to call the function. The first one creates a task due tomorrow, and the task will get the subject of the email. The second one creates a task due the day after tomorrow with the subject 'Send reply'. Rename the functions to suit your needs, for instance, 'DueTomorrow' instead of 'Sample_1'.

If a folder is the active window in Outlook when you call this functions, then all selected emails will be flagged. Instead, if an open email is the active window, then only that one will be flagged.

Another way would be to trigger the flagging from another macro. For instance, you could trigger the creation of a task item by assigning a category to the email. See also Trigger Actions with Categories.

Public Sub Sample_1()
  'due: tomorrow, 8 o´clock
  MarkItemAsTask 1
End Sub

Public Sub Sample_2()
  'due: the day after tomorrow, 11 o´clock
  MarkItemAsTask 2, "11:00", "Send reply"
End Sub

Outlook 2003 and older

Before Outlook 2007 there was no Todo bar. This old sample for Outlook 2003 is different from the one above but serves it's purpose, too.

Public Enum FlagWhatEnum
  flNextWeek = 0
  flThisEvening = 1
  flTomorrow = 2
End Enum

Public Sub FlagNextWeek()
  FlagItem flNextWeek
End Sub

Public Sub FlagThisEvening()
  FlagItem flThisEvening
End Sub

Public Sub FlagTomorrow()
  FlagItem flTomorrow
End Sub

Private Sub FlagItem(FlagWhat As FlagWhatEnum)
  Dim Mail As Outlook.MailItem
  Dim obj As Object
  Dim Sel As Outlook.Selection
  Dim i&
  Dim dt As Date
  Dim tm As String
  Dim Icon As OlFlagIcon

  Select Case FlagWhat
  Case flNextWeek
    dt = DateAdd("d", 7, Date)
    tm = CStr(dt) & " 08:00"
    Icon = olOrangeFlagIcon
  Case flThisEvening
    dt = Date
    tm = CStr(dt) & " 19:00"
    Icon = olYellowFlagIcon
  Case flTomorrow
    dt = DateAdd("d", 1, Date)
    tm = CStr(dt) & " 08:00"
    Icon = olYellowFlagIcon
  End Select

  Set obj = Application.ActiveWindow
  If TypeOf obj Is Outlook.Explorer Then
    Set Sel = obj.Selection
    For i = 1 To Sel.Count
      Set obj = Sel(i)
      If TypeOf obj Is Outlook.MailItem Then
        Set Mail = obj
        Mail.FlagDueBy = tm
        Mail.FlagIcon = Icon
        Mail.Save
      End If
    Next
  Else
    Set obj = obj.CurrentItem
    If TypeOf obj Is Outlook.MailItem Then
      Set Mail = obj
      Mail.FlagDueBy = tm
      Mail.FlagIcon = Icon
      Mail.Save
    End If
  End If
End Sub