Create Printout from Multiple Shared Calendars

[Jeanne Goodman]

Hi Diane,

I've been reading your articles for the past few days and I find you to be brilliant.

I have a problem in my company...

We have about 30 shared conference room calendars.
I need to be able to create a print out of all of the events on a particular day filtered by location.

From your articles it looks as though my best bet might be to copy all of the entries for the day from each calendar to a calendar designed for exporting to a CSV file. Then I can use a mail merge to print the results.

We use Office 365 Exchange Online as our server.

I can't seem to figure out how to specify the folder that I'm copying the events from especially since the "owner" of each of the shared calendars is the same.


Dim NS As Outlook.NameSpace
Dim objOwner As Outlook.Recipient
Set NS = Application.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("maryc")
objOwner.Resolve
If objOwner.Resolved Then
'MsgBox objOwner.Name
Set newCalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
End If

Can you advise?

Jeanne (I am not worthy) Goodman

 

[Diane Poremsky]

Are the calendars all in one mailbox? The "owner" refers to the mailbox alias, not other users who are listed as owners. You need to get the mailbox name then it's calendar.

Depending on how they are in the profile, this might work as is - Combine and Print Multiple Outlook Calendars - i don't have code handy that uses the shared folder code.

 

[Jeanne Goodman]

You amaze me!

This is the line that triggers the OnError for shared folders.

calName = CalFolder.Parent.Name

How can I determine the parent when it's a shared folder?

Best,

Jeanne (Humbled by your help) Goodman

 

[Jeanne Goodman]

Hi again,

I figured it out! Our mailbox names are Replace(objNavFolder," ","-") so using that it just WORKS!

Onto figuring out the macro to export. I'm so close I can taste it.

Jeanne

 

[Diane Poremsky]

This is the line that triggers the OnError for shared folders.

calName = CalFolder.Parent.Name

How can I determine the parent when it's a shared folder?

That is in the CopyAppttoPrint macro? That sets the category name - you don't need to use it.

 

[Diane Poremsky]

This is my version that works with the default calendar in mailboxes, shared mailboxes or shared calendars (but not secondary calendars in a mailbox) . It uses the folder name as the category (and in the case of mailboxes, adds the parent display name).

Dim CalFolder As Outlook.Folder
Dim printCal As Outlook.Folder
Dim nameFolder

' Run this macro
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
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

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


Private 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

Debug.Print "3: " & nameFolder

On Error Resume Next
StrName = " - " & CalFolder.Parent.Name

calName = nameFolder & StrName
' 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 - 2 & "'" & " 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 = printCal.Items.Add(olAppointmentItem)
With newAppt
.Subject = itm.Subject
.Start = itm.Start
.End = itm.End
.ReminderSet = False
.Categories = calName
.Save
End With

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

 

[Diane Poremsky]

Here is a macro for Exporting to excel - Macro to Export Outlook Fields to Excel - it uses email fields but that is a small matter to change.

 

[Jeanne Goodman]

Hi Diane,

I'm so close. I really tried to figure it out on my own, but I'm having problems with one final part... I'm having trouble figuring out how to tell Outlook to only copy values from the "Print" folder.

' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection

Set olItem = obj​

I saw your article: Working with VBA and non-default Outlook Folders but when I tried:

Set oNamespace = Application.GetNamespace("MAPI")
Set Items = Session.GetDefaultFolder(olFolderCalendar).Folders("Print").Items
Set Selection = Items
...​

Everything comes up empty.

Jeanne (Feeling Incompetent) Goodman

 

[Diane Poremsky]

this works with the selected items -

Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
  For Each obj In Selection

    Set olItem = obj

to change it to work with all items in the folder we'll swipe code from Working with All Items in a Folder or Selected Items

    Set objFolder = Session.GetDefaultFolder(olFolderCalendar).Folders("Print")
    Set objItems = objFolder.Items
    For Each olItem In objItems
 
' code to copy to excel