Outlook 2013 Printing Mulitple Calendars

Jackie Orona

New Member
Outlook version
Outlook 2013 32 bit
Email Account
Exchange Server
Hello Diane,

I have been tasked with finding a way to print our Conference Room calendars in Outlook 2013. I have been successful getting your SelectCalendars code to work. I am able to select all of the calendars in my ConfRms calendar group. Although it still selects my main calendar too.

When I try to run your following code it errors on the CopyAppttoPrint sub at Set calItems = CalFolder.Items.

Sub PrintCalendarsAsOne()
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 printCal = objCalendar.Folders("Print")
Set printCal = objCalendar.Folders.Add("Print")

Set Application.ActiveExplorer.CurrentFolder = objCalendar

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

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

Sub CopyAppttoPrint()

Dim calItems As Outlook.Items
Dim ResItems As Outlook.Items
Dim sFilter As String
Dim iNumRestricted As Integer
Dim itm, newAppt As Object

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

calName = CalFolder.Parent.Name
' to use category named for account & calendar name
' calName = CalFolder.Parent.Name & "-" & CalFolder.Name

'create the filter - this copies appointments today to 3 days from now
sFilter = "[Start] >= '" & Date & "'" & " And [Start] < '" & Date + 3 & "'"

' Apply the filter
Set ResItems = calItems.Restrict(sFilter)

iNumRestricted = 0

'Loop through the items in the collection.
For Each itm In ResItems
iNumRestricted = iNumRestricted + 1

Set newAppt = itm.Copy
newAppt.Categories = calName

newAppt.Move printCal

' Display the actual number of appointments created
Debug.Print calName & " " & (iNumRestricted & " appointments were created")

Set itm = Nothing
Set newAppt = Nothing
Set ResItems = Nothing
Set calItems = Nothing
Set CalFolder = Nothing

End Sub

Any help would be appreciated.

Diane Poremsky

Senior Member
Outlook version
Outlook 2016 32 bit
Email Account
Office 365 Exchange