Create Followup Task Reminders with VBA
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 "My Bookshelf" section of the bookstore) 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.
Make sure you copy both code blocks.
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")
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
ExitProc:
End Sub
'
' 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")
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
ExitProc:
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
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
If you want a function that returns the next *working* day (i.e. minus holidays), check out my blog post Calculate Working Days Minus Holidays in VBA.
