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
DoEvents
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)
objOwner.Resolve
If objOwner.Resolved Then
Set CalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
End If
SearchSharedCalendar
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
Next
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
