Copy new appointments from one Outlook calendar to another Outlook calendar using VBA

January 11, 2017 / Kannan / 0 Comments

This post talks about a code which can copy new appointnments and meetings from one Microsoft Outlook calendar to another Microsoft Outlook calendar.
The code is capable of adding new, updating existing and deleting existing items.

One of the issues I was facing while working with my clients was, they had their own email system and they used to send appointment/meeting requests in those accounts for which I had a separate mail ID. For me it was becoming difficult to track all of them. So I was thinking about a way where all the calendar appointments/meetings across multiple clients get added to my own calendar.

While researching on this, came across a superb post Copy New Appointments to Another Calendar using VBA – Slipstick Systems and made use of it.

The code in the post works as is except for 2 things which I have listed below.

1. The post uses default calendar as source and I wanted multiple calendar. For this instead of using “GetDefaultFolder” I used “GetFolderPath”. Do note that each instance of calendar required specific functions to be repeated. (I am planning to optimise this code so that the functions remain same but we can use multiple folders.)
2. The post’s delete functionality was not working due to an issue where the delete function was comparing the GUID with starting character as “[“, which I had to comment out.

Following is the final code which worked for me.
Full credit goes to Diane Poremsky

'Macro to copy calendar items from current default calendar to another calendar
'Source: https://www.slipstick.com/developer/copy-new-appointments-to-another-calendar-using-vba/
Dim WithEvents curCal As Items
Dim WithEvents DeletedItems As Items
Dim newCalFolder As Outlook.folder

Private Sub Application_Startup()
	Dim NS As Outlook.NameSpace
	Set NS = Application.GetNamespace("MAPI")
	' calendar to watch for new items
	Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items 'If you need to use a specific folder then use "NS.GetFolderPath("data-file-name\calendar").Items" and generally "data-file-name" is "user@domain.com"
	' watch deleted folder
	Set DeletedItems = NS.GetDefaultFolder(olFolderDeletedItems).Items 'If you need to use a specific folder then use "NS.GetFolderPath("data-file-name\Deleted Items").Items" and generally "data-file-name" is "user@domain.com"
	' calendar moving copy to
	Set newCalFolder = GetFolderPath("data-file-name\calendar")
	Set NS = Nothing
End Sub

Private Sub curCal_ItemAdd(ByVal Item As Object)
	Dim cAppt As AppointmentItem
	Dim moveCal As AppointmentItem

	' On Error Resume Next

	'remove to make a copy of all items
	If Item.BusyStatus = olBusy Then

		Item.Body = Item.Body & "[" & GetGUID & "]"
		Item.Save

		Set cAppt = Application.CreateItem(olAppointmentItem)

		With cAppt
			.Subject = "Copied: " & Item.Subject
			.Start = Item.Start
			.Duration = Item.Duration
			.Location = Item.Location
			.Body = Item.Body
		End With

		' set the category after it's moved to force EAS to sync changes
		Set moveCal = cAppt.Move(newCalFolder)
		moveCal.Categories = "moved"
		moveCal.Save

	End If
End Sub


Private Sub curCal_ItemChange(ByVal Item As Object)
	Dim cAppt As AppointmentItem
	Dim objAppointment As AppointmentItem

	On Error Resume Next

	' use 2 + the length of the GUID
	strBody = Right(Item.Body, 38)

	For Each objAppointment In newCalFolder.Items
		If InStr(1, objAppointment.Body, strBody) Then
			Set cAppt = objAppointment
		End If
	Next


	With cAppt
		.Subject = "Copied: " & Item.Subject
		.Start = Item.Start
		.Duration = Item.Duration
		.Location = Item.Location
		.Body = Item.Body
		.Save
	End With

End Sub


Private Sub DeletedItems_ItemAdd(ByVal Item As Object)
	' only apply to appointments
	If Item.MessageClass <> "IPM.Appointment" Then Exit Sub
	' if using a category on copied items, this may speed it up.
	If Item.Categories = "moved" Then Exit Sub

	Dim cAppt As AppointmentItem
	Dim objAppointment As AppointmentItem
	Dim strBody As String

	On Error Resume Next

	' use 2 + the length of the GUID
	strBody = Right(Item.Body, 38)
	'If Left(strBody, 1) <> "[" Then Exit Sub 'This particular line didn't work for me

	For Each objAppointment In newCalFolder.Items
		If InStr(1, objAppointment.Body, strBody) Then
			Set cAppt = objAppointment
			cAppt.Delete
		End If
	Next

End Sub


Public Function GetGUID() As String
	GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function


Function GetFolderPath(ByVal FolderPath As String) As Outlook.folder
	Dim oFolder As Outlook.folder
	Dim FoldersArray As Variant
	Dim i As Integer

	On Error GoTo GetFolderPath_Error
	If Left(FolderPath, 2) = "\\" Then
		FolderPath = Right(FolderPath, Len(FolderPath) - 2)
	End If
	'Convert folderpath to array
	FoldersArray = Split(FolderPath, "\")
	Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
	If Not oFolder Is Nothing Then
		For i = 1 To UBound(FoldersArray, 1)
			Dim SubFolders As Outlook.Folders
			Set SubFolders = oFolder.Folders
			Set oFolder = SubFolders.Item(FoldersArray(i))
			If oFolder Is Nothing Then
				Set GetFolderPath = Nothing
			End If
		Next
	End If
	'Return the oFolder
	Set GetFolderPath = oFolder
	Exit Function

	GetFolderPath_Error:
		Set GetFolderPath = Nothing
		Exit Function
End Function