Outlook 2007 Macro to Copy Appointments from iCloud Calendar to Default Calendar - vba

Question

I use Outlook 2007 on Windows 7. I have recently installed iCloud have unfortunately realised that Google Calendar Sync will only sync the default calendar. I was wondering if someone could help me out with a simple VBA macro that would
Empty the default calendar of all appointments
Copy all appointments from the iCloud Calendar to the default calendar
Many thanks!

Answer 1

Health warning
Everything in this answer was discovered by experimentation. I started with VB Help, used F2 to access the object model and experimented until I found what worked. I did buy a highly recommended reference book but it contained nothing important I had not discovered and omitted much that I had discovered.
I suspect that a key feature of the knowledge I have gained is that it is based on many different installations. Some of the problems encountered may have been the result of installation mistakes which would explain why reference book authors did not know of them.
The code below has been tested with Outlook 2003. I have tested similar code with Outlook 2007.
Output selected properties of appointments within default Calendar to Immediate window
You reported that the first version of this routine gave an error: "Runtime error '-2147467259 (80004005)': You must enter a positive duration."
According to the websites I found with Google, error 80004005 means a system file is corrupt.
An appointment has three related items: Start (type Date), End (type Date) and Duration (type Long). I assume either End or Duration is derived at runtime. My guess is that either Duration is negative or End is before Start. I notice in the list of appointments created by this macro on my system that some all day events have property AllDayEvent = False. I seem to recall I once discovered that creating an appointment and later switching AllDayEvent on or off created an inconsistency.
I have added code which attempts to detect this problem but I cannot test it because I have no appointments that give this error on my system. This macro was only intended to get you started with a list of your current appointments so let us not worry to much if you cannot get it working.
Sub ReviewCalendar()
Dim DateTimeEnd As Date
Dim DateTimeStart As Date
Dim Duration As Long
Dim ItemMine As Object
Dim ItemMineClass As Long
Dim FolderTgt As MAPIFolder
Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
' I use this macro to list selected properties from the test calendar.
' Add a quote to the statement above and remove the quote from the next
' statement to do the same.
'Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").Folders("Test Folders"). _
Folders("Calendar")
For Each ItemMine In FolderTgt.Items
With ItemMine
' Occasionally I get syncronisation
' errors. This code avoids them.
ItemMineClass = 0
On Error Resume Next
ItemMineClass = .Class
On Error GoTo 0
If ItemMineClass = olAppointment Then
Debug.Print "** Subject: " & .Subject
Debug.Print " Created: " & _
Format(.CreationTime, "d mmm yy hh:mm:ss")
Debug.Print " Updated: " & _
Format(.LastModificationTime, "d mmm yy hh:mm:ss")
Debug.Print " Time: ";
DateTimeStart = .Start
If .AllDayEvent Then
Debug.Print "All day " & Format(.Start, "d mmm yy")
Else
On Error Resume Next
DateTimeEnd = .End
Duration = .Duration
On Error GoTo 0
If Duration <= 0 Then
Debug.Print " ##### Invalid duration #####"
End If
Debug.Print Format(.Start, "h:mm") & " to " & _
Format(.End, "h:mm") & "(" & .Duration & _
" minutes) on " & Format(.Start, "d mmm yy")
End If
' If you remove the quote from the following statement
' it will delete the appointment.
' .Delete ' Delete appointment
End If
End With
Next
End Sub
Preparing to test copying of appointments
I suggest you create a test folder so you can test macros without effecting anything important.
From the Toolbar, select File, New, Outlook Data File, Office Outlook Personal Folders File (.pst).
A window appears listing your existing PST files. On my system these are: archive.pst, Outlook.pst and Test.pst.
At the bottom the default file name is selected. Enter "Test" or other name of your choice.
Another window appears so you can (1) select the name used for the new personal folder in the Outlook Explorer window and (2) select the level of encryption. Enter "Test" or other name of your choice. (Outlook will add " Folders" to your name.) I do not encrypt or password protect message on my system but that is a choice for you.
From the toolbar, select Go, Folder List. The folder list will appear in place of the Output Explorer window.
Right click folder "Calendar" then select New Folder. The New Folder window appears.
Enter the name as "Calendar" and select Test Folders as its location.
Now, when you select Calendar, you will be offered "Calendar in Test Folders" as an additional choice.
Copy appointments from default Calendar to test Calendar
This macro creates a copy in the test Calendar of every appointment in the default Calendar.
Run it once then select Calandar and tick both the default and the test Calendar. The two calendars should be identical.
Warning: If you run the macro again, you will end with two copies of each appointment.
Sub CopyCalendar()
Dim FolderDest As MAPIFolder
Dim ItemCopy As AppointmentItem
Dim ItemMine As Object
Dim ItemMineClass As Long
Dim NameSpaceMine As NameSpace
Dim FolderSrc As MAPIFolder
Set NameSpaceMine = _
CreateObject("Outlook.Application").GetNamespace("MAPI")
With NameSpaceMine
Set FolderSrc = .GetDefaultFolder(olFolderCalendar)
Set FolderDest = .Folders("Test Folders").Folders("Calendar")
End With
Debug.Print FolderSrc.Items.Count
Debug.Print FolderDest.Items.Count
For Each ItemMine In FolderSrc.Items
With ItemMine
' Occasionally I get syncronisation
' errors. This code avoids them.
ItemMineClass = 0
On Error Resume Next
ItemMineClass = .Class
On Error GoTo 0
' I have never found anything but appointments in
' Calendar but test just in case
If ItemMineClass = olAppointment Then
Set ItemCopy = .Copy
ItemCopy.Move FolderDest
End If
End With
Next
End Sub
Next steps
The Set FolderDest statement shows how to select a partcular folder by working down its hierarchy. There are other, more general, techniques but this should be sufficient for your requirements if you can access the iClound Calendar in this way.
Set NameSpaceMine = _
CreateObject("Outlook.Application").GetNamespace("MAPI")
With NameSpaceMine
Set FolderDest = .Folders("Test Folders").Folders("Calendar")
End With
The first macro includes the code to delete every appointment in a calendar and the second copies appointments from one calendar to another.
Combining and adapting this code would give you a one-way synchronisation. That is, it would make Calendar 2 a copy of Calendar 1. Is this adequate? Would overwriting the iCloud Calendar with the default Calendar be adequate? Two-way synchronisation is more complicated. I have experienced several "enterprise" synchronisation routines and none were fool-proof. If you are of the "enterprise means over priced, poor quality sofware" school, you will not be surprised. Otherwise you may agree that two-way synchronisation is difficult or that both statements are true.
The issues are:
Non-identifying properties in either calendar may be changed.
An appointment may be added to or deleted from either calendar.
Identifying properties in either calendar may be changed. Typically subject and or start time are identifying properties but the subject may be changed and the appointment may be moved.
On my system, CreationTime and LastModificationTime are copied unchanged so there are options around using them as identifiers. I have no means of testing the effect on CreationTime and LastModificationTime of a calendar being updated because of meeting request.
I leave you to consider these issues and decide how you wish to take this matter forward.