Search Calendars for Appointments

A user had a number of calendars, both in his own mailboxes plus a handful of shared calendars. While Outlook can search all of the calendars, he wanted an easy way to restrict the searches to specific calendars and also see which calendar the appointment was on.

The solution: a macro. We used the macro at Combine and Print Multiple Outlook Calendars as the base and tweaked it to list the appointments in a message box.

The macro will search all selected calendars for appointments upcoming in the next 30 days that contain the keyword.

Note: This macro will filter out recurring events that do not fall within the date range but the Notes (Body) field filter doesn't work when you include recurring events.

To use, select the calendars you want to search then run the macro. Enter the keyword when asked. In this screenshot, I'm searching four calendars.

A list of matching appointments will display in a message box.

Dim CalFolder As Outlook.Folder
Dim nameFolder
Dim strKeyword As String
Dim strResults As String

' Run this macro
 Sub SearchinSharedCalendars()
 Dim objPane As Outlook.NavigationPane
 Dim objModule As Outlook.CalendarModule
 Dim objGroup As Outlook.NavigationGroup
 Dim objNavFolder As Outlook.NavigationFolder
 Dim objCalendar As Folder
 Dim objFolder As Folder

 Dim i As Integer
 Dim g As Integer
 On Error Resume Next

 Set objCalendar = Session.GetDefaultFolder(olFolderCalendar)

 Set Application.ActiveExplorer.CurrentFolder = objCalendar
 DoEvents
 
strKeyword = InputBox("Search subject and body", "Search Shared Calendars")

 Set objPane = Application.ActiveExplorer.NavigationPane
 Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)

 With objModule.NavigationGroups

 For g = 1 To .Count

 Set objGroup = .Item(g)

 For i = 1 To objGroup.NavigationFolders.Count
 Set objNavFolder = objGroup.NavigationFolders.Item(i)

 If objNavFolder.IsSelected = True Then

 Set CalFolder = objNavFolder.Folder
 Set nameFolder = objNavFolder

 Dim NS As Outlook.NameSpace
 Dim objOwner As Outlook.Recipient
 Set NS = Application.GetNamespace("MAPI")
 Set objOwner = NS.CreateRecipient(nameFolder)
 objOwner.Resolve
 If objOwner.Resolved Then
 Set CalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
 End If

SearchSharedCalendar

txtSearchResults = strResults & vbCrLf & txtSearchResults
 
 End If
 Next i
 Next g
 End With
 
MsgBox txtSearchResults

 Set objPane = Nothing
 Set objModule = Nothing
 Set objGroup = Nothing
 Set objNavFolder = Nothing
 Set objCalendar = Nothing
 Set objFolder = Nothing
 End Sub

 Private Sub SearchSharedCalendar()

 Dim CalItems As Outlook.Items
 Dim ResItems As Outlook.Items
 Dim oFinalItems As Outlook.Items
 Dim sFilter As String
 Dim iNumRestricted As Integer
 Dim itm As Object
 Dim strAppt As String
 Dim dStart1 As Date, dStart2 As Date
 
 Set CalItems = CalFolder.Items

 If CalFolder = printCal Then
 Exit Sub
 End If

 ' Sort all of the appointments based on the start time
 CalItems.Sort "[Start]"
 
 ' body key word doesn't work if including recurring
 CalItems.IncludeRecurrences = True

 On Error Resume Next
 ' if you arent search subfolders, you only need parent name
 strName = CalFolder.Parent.Name & " - " & CalFolder.Name

' set dates
dStart1 = Date
dStart2 = Date + 30

' fileer by date first
sFilter = "[Start] >= '" & dStart1 & "'" & " And [Start] < '" & dStart2 & "'"
Debug.Print sFilter

'Restrict the Items collection for the 30-day date range
 Set ResItems = CalItems.Restrict(sFilter)

' Filter the results by keyword
' filter for Subject containing strKeyword '0x0037001E
' body is 0x1000001f
    Const PropTag  As String = "http://schemas.microsoft.com/mapi/proptag/"
    sFilter = "@SQL=(" & Chr(34) & PropTag _
        & "0x0037001E" & Chr(34) & " like '%" & strKeyword & "%' OR " & Chr(34) & PropTag _
        & "0x1000001f" & Chr(34) & " like '%" & strKeyword & "%')"
Debug.Print sFilter
'Restrict the last set of filtered items for the subject
Set oFinalItems = ResItems.Restrict(sFilter)

'Sort and collect final results
oFinalItems.Sort "[Start]"
 iNumRestricted = 0
For Each oAppt In oFinalItems
If oAppt.Start >= dStart1 And oAppt.Start <= dStart2 Then
 iNumRestricted = iNumRestricted + 1
  strAppt = oAppt.Start & " " & oAppt.Subject & vbCrLf & strAppt
End If
Next
 
 strResults = iNumRestricted & " matching Appointment found in " & strName & vbCrLf & strAppt
 
 Set itm = Nothing
 Set newAppt = Nothing
 Set ResItems = Nothing
 Set CalItems = Nothing
 Set CalFolder = Nothing

 End Sub

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.

The macros on this page should be placed in a module.

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.

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