Copying appointments from public to personal calendar

  • Thread starter Thread starter Seamus Conlon
  • Start date Start date
S

Seamus Conlon

I am interested to find out if anyone has written code that will copy items
in a public calendar to a personal calendar. I guess it could be done as
they are entered into the public calendar.

Many thanks,
Seamus Conlon
 
If you wanted it to be done automatically, your best bet is to create an
Exchange Event Sink. However, you could do it manually with this macro:

Sub CopyAppointmentsToDefaultCalendar()
Dim objMyCal As Outlook.MAPIFolder, objSourceCal As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objItem As Outlook.AppointmentItem, objNewItem As
Outlook.AppointmentItem

Set objNS = Application.GetNamespace("MAPI")

'Select source Calendar to copy items from
Set objSourceCal = objNS.PickFolder
If objSourceCal.DefaultItemType <> olAppointmentItem Then
MsgBox "You must choose a Calendar folder.", vbOKOnly +
vbExclamation, "Invalid Folder"
Exit Sub
End If

Set objMyCal = objNS.GetDefaultFolder(olFolderCalendar)
For Each objItem In objSourceCal.Items
Set objNewItem = objItem.Copy
objNewItem.Move objMyCal
Next
End Sub
 
I tried the macro approach and it does work ok. However, if the macro is
run twice then two copies of each item appears in the target calendar.
Is there an easy way to avoid this, i.e. check if the item exists before
copying?

Thanks,
Seamus
 
In order to determine if a duplicate exists, you'd have to loop through the
Items collection for the destination Calendar folder and retrieve individual
AppointmentItem objects. Then compare all of the relevant AppointmentItem
property values against the AppointmentItem you retrieved from the existing
loop of the Items collection for the source Calendar folder and see if all of
the properties match.

You might be able to get away with just comparing the Subject, Start and End
properties, but there's no guarantee that it'll be unique.

--
Eric Legault - B.A, MCP, MCSD, Outlook MVP
--------------------------------------------------
{Private e-mails ignored}
Job: http://www.imaginets.com
Blog: http://blogs.officezealot.com/legault/
 
Back
Top