Outlook default reminder for sent mails

Since most of the time, I need to follow up my mails send out to make sure the expected actions are taken, I do add a reminder on my send email. So I can verify in a couple of days if I did get a reaction or the expected action has been taken in the meantime.

In order to automate this, I added the outlook macro shown below. It’s based on the nice example provided by Diane Poremsky. I just improved it a bit to set the default reminder at 10am in 5 days (moving some days forward whenever the 5 days would end in the weekend). After sending an email, a little popup will show up indicating the reminder would be created for within 5 business days. The number of days can quickly be changed or the reminder can fully be discared using the ‘Cancel’ on the pop-up. After some days of usage, I’m very satisfied with the result. The popup will appear after sending the message, so the email will always be sent and won’t be blocked if the pop-up wouldn’t be noticed.

Of course this is only useful when you often need a follow-up on your sent mails…

'Instructions:    
'myT 04/2016, http://myTselection.blogspot.com
  'Default reminder for sent mails: add a default reminder for every sent mail, default 5 working days with popup to cancel or confirm (and set number of days)
  'Instructions:
  'Open Outlook and press [ALT+F11] to open the VBS developer editor
  'Navigate to 'Project 1 VbaProject.OTM' > Microsoft Outlook Objects > ThisOutlookSession
  'Copy and Paste the macro below and close the VBS editor
  'Make sure the line 'Private WithEvents olSentItems as Items' is saved at the top of the file
  Private WithEvents olSentItems As Items
  Attribute olSentItems.VB_VarHelpID = -1
  Private Declare PtrSafe Function ShellExecute _
  Lib "shell32.dll" Alias "ShellExecuteA" ( _
  ByVal hWnd As Long, _
  ByVal Operation As String, _
  ByVal Filename As String, _
  Optional ByVal Parameters As String, _
  Optional ByVal Directory As String, _
  Optional ByVal WindowStyle As Long = vbMinimizedFocus _
  ) As Long
  'Original source: http://www.slipstick.com/developer/code-samples/set-flag-follow-up-using-vba/
  Private Sub Application_Startup()
  'MsgBox ("test startup")
  Dim objNS As NameSpace
  Set objNS = Application.Session
  ' instantiate objects declared WithEvents
  Set olSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
  Set objNS = Nothing
  End Sub
  Private Sub olSentItems_ItemAdd(ByVal Item As Object)
  'On Error Resume Next
  Dim prompt As String
  Dim dtmTemp As Date
  Dim businessDays As String
  Dim reminderTime As String
  Dim dueDateDays As Integer
  'MsgBox ("test item sent")
  If TypeName(Item) = "MailItem" Then
          businessDays = 5
      dueDateDays = 14
      reminderTime = "10:00:00 AM"
            'Reminder in 5 days, 10 AM
        dtmTemp = DateValue(Now + businessDays) & " " & TimeValue(reminderTime)
        'skip days if reminder would result in weekend
        Do While IsWeekend(dtmTemp)
            dtmTemp = dtmTemp + 1
        Loop
                    'InputBox(prompt[, title] [, default] )
        businessDays = InputBox("Do you want to add a reminder for the email sent? " & vbCrLf & vbCrLf _
        & " Subject: " & Item.Subject & vbCrLf _
        & " To: " & Item.To & vbCrLf & vbCrLf & vbCrLf _
        & "Set # business days for the reminder" & vbCrLf _
        & " Default " & businessDays & " business days: " & WeekdayName(Weekday(dtmTemp), True, vbSunday) & " " & dtmTemp, _
        "Add a reminder for the email sent?", businessDays)
              'Exit sub if user press Cancel button or does not enter any text in the Input field.
        If businessDays = vbNullString Then Exit Sub
              dtmTemp = DateValue(Now + CInt(businessDays)) & " " & TimeValue(reminderTime)
        'skip days if reminder would result in weekend
        Do While IsWeekend(dtmTemp)
            dtmTemp = dtmTemp + 1
        Loop
                           With Item
            .MarkAsTask olMarkThisWeek
              ' sets a due date in 14 days
            .TaskDueDate = Now + dueDateDays
            .ReminderSet = True
            .reminderTime = dtmTemp
            .Save
        End With
    End If
  End Sub

Update 27/06/2016: added check on item type to make sure no error occur when responding to an meeting request.