Solution to disturbing default reminder for Outlook all-day events

Outlook users can define default reminder time for new calendar event. However this applies to normal events with a start hour, not to all-day events. For those events, there is a default value of 18 hours, which sets the reminder at 6am the previous morning. Most people don’t want to be reminded so early.

So I built a solution with a few lines of code to add to Outlook.

This code verifies the reminder hour when a calendar item is saved. If it is set before a minimum hour (default 9am) or after a maximum hour (default 8pm), an alert proposes a new reminder time. The user can accept or deny the proposed value or cancel the closing in case he wants to set another value manually.

Installation

The following instructions are based on a french version of Outlook 2002, from which I try to translate for this english post. You may have some differences.

• From Outlook, open the Visual Basic Editor: menu Tools | Macro | Visual Basic Editor
• In the project pane, open Microsoft Outlook Objects then ThisOutlookSession
• In the script window, paste the following code (or adapt if you already have something)

Public WithEvents objCalendar As Outlook.Items

'The following in the Application_Startup
Public Sub Application_Startup()
   On Error GoTo ProcError
   Dim strProcName As String
   strProcName = "Application_Startup"

   ' Reference the items collection of the Calendar folder
   ' Because the objCalendar is dimensioned "WithEvents" (in Declararations section)
   ' the ItemAdd, Change and Remove events for this folder will fire and can be used for custom events.
   Set objCalendar = Outlook.Session.GetDefaultFolder(olFolderCalendar).Items

ProcExit:
   Exit Sub

ProcError:
   MsgBox "Unanticipated error " & Err.Number & " " & Err.Description & " In Procedure: " & strProcName
   'Stop
   Resume ProcExit
End Sub

Private Sub objCalendar_ItemAdd(ByVal Item As Object)
    verifyReminder Item
End Sub

Private Sub objCalendar_ItemChange(ByVal Item As Object)
    verifyReminder Item
End Sub

' Verify if reminder is set for sleep time and warn the user if necessary
' (c) Pierre Rossel http://www.prossel.com
Sub verifyReminder(ByVal Item As Object)
    On Error GoTo ProcError
    Dim strProcName As String
    strProcName = "verifyReminder"

    reminderMaxHour = 20
    reminderMinHour = 9

    Dim appitm As Outlook.AppointmentItem
    Set appitm = Item

    If appitm.ReminderSet Then
        Dim reminderDate As Date
        reminderDate = appitm.Start - appitm.ReminderMinutesBeforeStart / (24 * 60)
        reminderHour = (reminderDate - Int(reminderDate)) * 24

        tolerance = 0.01 ' avoid floating point small diffs (little bit less than a min)

        If reminderHour < reminderMinHour - tolerance Or reminderHour > reminderMaxHour + tolerance Then
            ' best guess, first try to advance to next minHour
            reminderDateSuggestion = reminderDate + (reminderMinHour - reminderHour) / 24
            ' verify if first guess is valid
            If reminderHour < reminderMinHour - tolerance And reminderDateSuggestion <= appitm.Start Then
                ' OK, first guess is valid, keep it
            ElseIf reminderHour > reminderMaxHour Then
                ' go back to max hour (same day)
                reminderDateSuggestion = reminderDate - (reminderHour - reminderMaxHour) / 24
            Else
                ' go back to max hour (previous day)
                reminderDateSuggestion = reminderDate - (reminderHour + 24 - reminderMaxHour) / 24
            End If

            rep = MsgBox("Le rappel est défini actuellement à une heure en dehors de la plage de confort. Voulez vous remplacer l'heure de rappel ?" & vbCrLf & vbCrLf & _
                         vbTab & reminderDateSuggestion & vbCrLf & _
                         "au lieu de " & vbCrLf & _
                         vbTab & reminderDate, vbQuestion + vbYesNoCancel)

            If rep = vbCancel Then
                appitm.Display
            ElseIf rep = vbYes Then
                appitm.ReminderMinutesBeforeStart = (appitm.Start - reminderDateSuggestion) * 24 * 60
                appitm.Save
            End If

        End If
    End If

ProcExit:
    Exit Sub

ProcError:
    MsgBox "Unanticipated error " & Err.Number & " " & Err.Description & vbCrLf & "In procedure: " & strProcName
    GoTo ProcExit
End Sub

• Search for the following lines and modify the min and max hours you accept to be reminded

reminderMaxHour = 20
reminderMinHour = 9

• Save and restart Outlook
• create or edit a appointment in the calendar and save it
• try with different reminder values and see how the alert fixes the reminder when you save