Another day, another macro in my "The Lazy Programmer Series", where I take existing code samples and tweak them to do other, similar things.

This code base, like many others I use, comes from Michael Bauer's VBOffice site and began life as Calendar: Delete the reminder of a meeting request.

This macro runs when Outlook starts and watches for new appointment items to be saved. When it finds one, it checks to see if it's an All Day Event, and if so, you are asked if you want to keep the reminder. While the tweaks here work with reminders, it can be tweaked to do almost anything when a new appointment or event is saved.

Step 1

To use these ItemAdd macros on this page, you need to add this code to the top of ThisOutlookSession:

Open the VB Editor by pressing Alt+F11. Expand the Project to display ThisOutlookSession and paste the following code into the editor. To test this macro without closing and restarting Outlook, click in the Application_Startup sub and click the Run button on the toolbar. Repeat this step after making modifications to the code.

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace

  Set Ns = Application.GetNamespace("MAPI")
  Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items
End Sub

Step 2

Paste one of the ItemAdd macros below into ThisOutlookSession, just after the End Sub of the Application_StartUp macro above.

Remove Reminders on All Day Events | Remove Default 18 Hour Reminders |

Remove Reminders on All Day Events

Private Sub Items_ItemAdd(ByVal Item As Object)
  On Error Resume Next
  Dim Appt As Outlook.AppointmentItem

  If TypeOf Item Is Outlook.AppointmentItem Then

    Set Appt = Item

'Checks to see if all day and if it has a reminder set to true
     If Appt.AllDayEvent = True And Appt.ReminderSet = True Then

'msgbox block - 3 lines
    If MsgBox("Do you want to remove the reminder?", vbYesNo) = vbNo Then
      Exit Sub
    End If

'appt.reminderset block - 2 lines
     Appt.ReminderSet = False
     Appt.Save

    End If
    End If
End Sub

Customize the Code

This code sample has a lot of potential - you can use it to change almost any field in appointments and events (timed appointments or all day events). It applies to all new appointment items, including those created by Outlook when you enter a contact's birthday. To get you started, I've included some ideas below.

Keep all except 18 hour reminders

Would you prefer removing all 18 hour reminders but want to keep reminders if you select a different reminder time? Remove the If Msgbox... End If block and replace the Appt.Reminderset block with the following code.

Private Sub Items_ItemAdd(ByVal Item As Object)
  On Error Resume Next
  Dim Appt As Outlook.AppointmentItem
 
  If TypeOf Item Is Outlook.AppointmentItem Then
 
    Set Appt = Item
 
' Checks the start time
 If Appt.ReminderMinutesBeforeStart = 1080 Then
     Appt.ReminderSet = False
     Appt.Save
    End If

End If

End Sub

Set a different "default" reminder

To change the default reminder from 18 hours to another value, remove the If Msgbox... End If block and replace the Appt.Reminderset block with the following lines. This sample sets the reminder to 6 hours before the start, or 6PM.

Private Sub Items_ItemAdd(ByVal Item As Object)
  On Error Resume Next
  Dim Appt As Outlook.AppointmentItem
 
  If TypeOf Item Is Outlook.AppointmentItem Then
    Set Appt = Item
If Appt.ReminderMinutesBeforeStart = 1080 Then
     Appt.ReminderMinutesBeforeStart = 360
Appt.Save

End If
End If
End Sub

Keep reminders based on subject

To leave the reminder for appointments beginning with a specific keyword or character, replace the If Msgbox... End If code with the following code. This sample checks the first character for a ! and if found, the reminder is left on. You can check more characters by changing the number and phrase in Left(Appt.Subject, 1) = "!".

For example, an all day event with the subject !Training Classes would keep the 18 hour reminder, while Working downtown would not have a reminder.

If Left(Appt.Subject, 1) = "!" Then
 Exit Sub
 End If

Set longer reminders for birthdays

To set a reminder more than 18 hours before for Birthdays, remove the msgbox block and replace the appt.reminderset code with the following. This will set a reminder for 7.5 days on all birthdays, including those created when you add new contacts to Outlook and enter a birth date. We're also adding the Birthday category.

Private Sub Items_ItemAdd(ByVal Item As Object)
  On Error Resume Next
  Dim Appt As Outlook.AppointmentItem
 
  If TypeOf Item Is Outlook.AppointmentItem Then
 
    Set Appt = Item
 
' Checks the start time
If Right(Appt.Subject, 8) = "Birthday" Then
Appt.ReminderMinutesBeforeStart = 10800
Appt.Categories = "Birthday"
Appt.Save

End If

End If

End Sub

Set longer reminders for the first appointment after lunch

To set longer reminders for appointments that occur at certain times of the day, you need to check the start time. When only the time is entered, it applies to that time, any date.

Private Sub Items_ItemAdd(ByVal Item As Object)
  On Error Resume Next
  Dim Appt As Outlook.AppointmentItem
 
  If TypeOf Item Is Outlook.AppointmentItem Then
 
    Set Appt = Item
 
' Checks the start time
If Appt.Start = "#1:00:00 PM#" Then

' appt.reminderset block - 2 lines
 With Appt
     .ReminderSet = True
     .ReminderMinutesBeforeStart = 75
     .Save
End With

End If
End If

End Sub

Set Free/Busy to Busy

This macro sets Free/Busy status to Busy when a new All Day Event is added to the calendar.

Note: when you are creating the All Day Event, the Free/Busy status will be Free. The macro changes it to Busy on Save.

Private Sub Items_ItemAdd(ByVal Item As Object)
  On Error Resume Next
  Dim Appt As Outlook.AppointmentItem
 
  If TypeOf Item Is Outlook.AppointmentItem Then
 
    Set Appt = Item
 
'Checks to see if all day and if it has a reminder set to true
     If Appt.AllDayEvent = True And Appt.BusyStatus = olFree Then
 
    Appt.BusyStatus = olBusy

'appt.reminderset block - 2 lines
     Appt.ReminderSet = True
     Appt.Save
 
    End If
  End If

End Sub

Run the Macro Manually on Selected Appointments

If you want to run the macro on selected appointments, you need to remove the startup macro and change the itemadd macro to run on demand.

Private Sub ChangeReminderSelected()
Dim Item As Object
For Each Item In ActiveExplorer.Selection
  On Error Resume Next
  If TypeOf Item Is Outlook.AppointmentItem Then

Dim Appt As Outlook.AppointmentItem
 
Set Appt = Item
 
'Checks to see if all day and if it has a reminder set to true
     If Appt.AllDayEvent = True And Appt.ReminderSet = True Then
 
 'appt.reminderset block - 2 lines
     Appt.ReminderSet = False
     Appt.Save
 
    End If
    End If
Next
End Sub

Run on upcoming events

This macro filters for events with a start date yesterday and 30 days in the future and changes the values. This speeds it up if you have a lot of all days events in the future (such as holidays or birthdays). You could filter to only apply it to items in certain categories or locations instead of going by date.

Because this is a manual macro, you need to run it on a regular basis, or use another macro to run it when a reminder fires. See Running Outlook Macros on a Schedule for more information.

Sub RemoveAllDayReminders()

  Dim objOutlook As Outlook.Application
  Dim objNamespace As Outlook.NameSpace
  Dim objSourceFolder As Outlook.MAPIFolder
  Dim fCount As Integer
  
  Dim CalItems As Outlook.Items
  Dim ResItems As Outlook.Items
  Dim sFilter As String
  Dim iNumRestricted As Integer
  Dim iChanged As Integer
  Dim itm As Object
  Dim tStart As Date
  Dim tEnd As Date
 
Dim Appt As Outlook.AppointmentItem

  Set objOutlook = Application
  Set objNamespace = objOutlook.GetNamespace("MAPI")
  Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
  
  ' Get all of the appointments in the folder
  Set CalItems = objSourceFolder.Items
 
   ' Sort all of the appointments based on the start time
   CalItems.Sort "[Start]"
 
   CalItems.IncludeRecurrences = False
    
  ' 1 day ago
    tStart = Format(Now - 1, "Short Date")
    
  ' 30 days ahead to speed it up
    tEnd = Format(Now + 30, "Short Date")
    
   'create the Restrict filter
'If you want to filter by subject, location, or category:
   '& """urn:schemas:httpmail:subject""" & " LIKE '%subject%' OR " _
   '& """urn:schemas:calendar:location""" & " LIKE '%location%' OR " _
   '& """urn:schemas-microsoft-com:office:office#Keywords""" &  "LIKE '%category name%'"
   '"urn:schemas:calendar:alldayevent" = 1
'To apply to all except in a specific category:
   '& """urn:schemas-microsoft-com:office:office#Keywords""" &  "<> 'category name'"
   
sFilter = "@SQL= (" & """urn:schemas:calendar:dtstart""" & " >= '" & tStart & "' AND" _
& """urn:schemas:calendar:dtend""" & " <= '" & tEnd & "' AND (" _
& """urn:schemas:calendar:alldayevent""" & "=1))"
 
   Debug.Print sFilter
   ' Apply the filter to the collection
   Set ResItems = CalItems.Restrict(sFilter)
 
   iNumRestricted = 0
   
   fCount = ResItems.Count
 Debug.Print ResItems.Count
   'Loop through the items in the collection.
   
   For counter = fCount To 1 Step -1
   
Set itm = ResItems.Item(counter)
   
   iNumRestricted = iNumRestricted + 1

Debug.Print itm.Subject, itm.Start
Set Appt = itm
If Appt.AllDayEvent = True And Appt.ReminderSet = True Then
 
 'appt.reminderset block - 2 lines
     Appt.ReminderSet = False
     Appt.Save
     iChanged = iChanged + 1
End If
   Next counter

Debug.Print (iNumRestricted & " " & strSubject & " events were found; " & iChanged & " needed changed.")

MsgBox (iNumRestricted & " " & strSubject & " events were found; " & iChanged & " needed changed.")

Set objSourceFolder = Nothing

End Sub

Use other calendar folders

If you want to use the macro on other calendar folders, you have two options: apply the macro to all Calendar folders or only to a specific folder.

To remove reminders from all day events in folders that are not the default calendar folder, you need to change the Application_Startup code to look in a different calendar folder.

If the folder is is a subfolder under the default Calendar folder (#1 in screenshot), replace

Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items

with:

Set Items = Ns.GetDefaultFolder(olFolderCalendar).Folders("SharedCal").Items

When the folder in your default data file or mailbox at the same level as the Calendar (and Inbox folder) (#2 in screenshot) use:

Set Items = Ns.GetDefaultFolder(olFolderCalendar).Parent.Folders("SharedCal").Items

To run the macro on all Calendar folders, use

Set Items = Application.ActiveExplorer.CurrentFolder.Items

If the folder is in another mailbox or data file, you need to use a function to find the folder path and call the function in the Startup procedure.

To use a Calendar folder called "Test Cal" in a pst file named "New PST", replace Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items with:

Set Items = GetFolders("New PST\Test Cal").Items

Then get the function from Working with VBA and non-default Outlook Folders

How to use the macros on this page

First: You need to have macro security set to the lowest setting, Enable all macros during testing. The macros will not work with the top two options that disable all macros or unsigned macros. You could choose the option Notification for all macros, then accept it each time you restart Outlook, however, because it's somewhat hard to sneak macros into Outlook (unlike in Word and Excel), allowing all macros is safe, especially during the testing phase. You can sign the macro when it is finished and change the macro security to notify.

To check your macro security in Outlook 2010 and newer, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, look at Tools, Macro Security.

After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.

Macros that run when Outlook starts or automatically need to be in ThisOutlookSession, all other macros should be put in a module, but most will also work if placed in ThisOutlookSession. (It's generally recommended to keep only the automatic macros in ThisOutlookSession and use modules for all other macros.) The instructions are below.

Open the VBA Editor by pressing Alt+F11 on your keyboard.

To put the code in a module:

1. Right click on Project1 and choose Insert > Module
2. Copy and paste the macro into the new module.

To put the macro code in ThisOutlookSession:

1. Expand Project1 and double click on ThisOutlookSession.
2. Copy then paste the macro into ThisOutlookSession. (Click within the code, Select All using Ctrl+A, Ctrl+C to copy, Ctrl+V to paste.)

More information as well as screenshots are at How to use the VBA Editor