Printing Mulitple Calendars

[Jackie Orona]

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

Set Application.ActiveExplorer.CurrentFolder = objCalendar
DoEvents

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
CopyAppttoPrint

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

Next
' 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]

Because of where it errors, I'm assuming it is this:
if the calendars are only opened as calendars, you many need to resolve the calendar using this code:
http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#shared