Outlook 365 Searching all shared calendars


New Member
Outlook version
Outlook 2016 64 bit
Email Account
Office 365 Exchange
I understand from my research that outlook will not search shared calendars. It will only search for an appointment etc with the current folder.

I have a scenario where I have 3 engineers who have appointments and a client rings up and says "I believe I have made an appointment my address is....., can you check please."

Under the current system I have to do a postcode search in each engineers calendar to see if an appointment has been made. This is time consuming and we are soon going to have 5 engineers.

Is there a way that you can create a macro that will run a search in each shared calendar automatically and produce reports?

Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange
This is probably messy code (since I put several macros together) but it should work - and might need tweaked a bit more. It asks for a keyword to search for then searches for recent appointments containing that word in the body or subject.

Like the print calendar I used as the base, you need to select calendar you want to search. if it finds a match on a calendar, a dialog box says which calendar then go to the next calendar.

 Dim CalFolder As Outlook.Folder
 Dim nameFolder
Dim strKeyword
 ' 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
strKeyword = InputBox("Search subject and body for", "Search Shard 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

 'run macro to copy appt
 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)
 If objOwner.Resolved Then
 Set CalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
 End If


 End If
 Next i
 Next g
 End With

 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 sFilter As String
 Dim iNumRestricted As Integer
 Dim itm, newAppt As Object
Dim oFinalItems As Outlook.Items

 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]"
 CalItems.IncludeRecurrences = True

 On Error Resume Next
 strName = CalFolder.Parent.Name

' searches next 10 days
sFilter = "[Start] >= '" & Date & "'" & " And [Start] < '" & Date + 10 & "'"
Debug.Print sFilter

  'Restrict the Items collection for the 30-day date range
 Set ResItems = CalItems.Restrict(sFilter)
    'Construct filter for Subject containing strKeyword '0x0037001E
    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 print final results
oFinalItems.Sort "[Start]"
 iNumRestricted = 0
For Each oAppt In oFinalItems
 iNumRestricted = iNumRestricted + 1
    Debug.Print oAppt.Start, oAppt.Subject, strName
 If iNumRestricted > 0 Then
 MsgBox iNumRestricted & " Matching Appointment found in " & strName
 End If
 Set itm = Nothing
 Set newAppt = Nothing
 Set ResItems = Nothing
 Set CalItems = Nothing
 Set CalFolder = Nothing

 End Sub
Outlook version
Outlook 2016 for Mac
Email Account
Outlook.com (as MS Exchange)
It should be interesting to be able to search in different shared calendars in Outlook 2016. It could be useful for schools and educational centers that need to find the same event (named in the same way, normally by the name of the student) in different calendars.
I use it in my work essayedge review very often

Similar threads