This macro "watches" for a new appointment to be added to the calendar and copies it to a second calendar. This is useful if you are sharing a calendar or syncing one calendar with a smartphone.
The code contains and If - Then statement (If Item.BusyStatus = olBusy Then) and copies only items that are marked busy. You can use use Categories or keywords in the subject as the filter or copy all items by removing the If.. and Then lines. You can remove or change the "Copied" tag added to the subject line.
This code, as written, assumes the second calendar is in another data file in the profile. It can easily be changed to work with a folder in the current data file. See Working with VBA and non-default Outlook Folders for more information.
- Enable macros in the Trust Center. In Outlook 2010/2013, this is at File, Options, Trust Center, Macros. In Outlook 2007, go to Tools, Trust Center. Use either warn or no security for now. Once you are happy with it, you can sign it with a self-certificate and set macros to signed-only.
- Open the VB Editor by pressing Alt+F11 on your keyboard.
- Expand Project1 to display ThisOutlookSession and double click to open it to the right side.
- Paste the code below into ThisOutlookSession. I have a text file with the macros here: Text file containing the macros to copy, change, and delete appointments.
- Change the folder path ("display name in folder list\Calendar") to the display name you see in the Folder List (this is usually the email address in Outlook 2010 and 2013). For example, the path shown in these screenshots is "New PST\Test Cal".
You can see the parent path in the Folder List (Ctrl+6) or right-click on the Calendar folder and choose Properties when in the Calendar module. The path can be copied from the Properties page, which can be helpful for nested folders or long names.
- Place the mouse in the Application_StartUp macro and press the Run button or F5.
- Create an appointment in your calendar and see if it was copied to the other calendar.
May 17 2019: Replaced code that searched on GUID to use GetDATETIME function instead as the GUID function is blocked due to security updates.
If you prefer to use a random alphanumeric code instead of the GUID, use the last code sample at Create sequential numbers or random character keywords for the necessary VBA code and update the macro accordingly.
September 22 2017: changed the code to copy all appointments except those marked Free. It previously only copied Busy appt.)
Dim WithEvents curCal 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 ' 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 ' copy all but appt marked Free ' remove to make a copy of all items If Item.BusyStatus <> olFee Then Item.Body = Item.Body & "[" & GetDATETIME & "]" 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 Public Function GetDATETIME() As String GetDATETIME = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss") 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
This code was submitted by Anshu Nahar, He made some changes to ItemAdd and ItemChange; so now this works for recurring items as well, including all exceptions.
Private Sub curCal_ItemAdd(ByVal Item As Object) Dim cAppt As AppointmentItem Dim movecal As AppointmentItem On Error Resume Next Item.Mileage = "$NCDTH1$" & GetUniqueId Item.Save Set cAppt = Item.Copy cAppt.Categories = "Copied" cAppt.Move newCalFolder End Sub Private Sub curCal_ItemChange(ByVal Item As Object) Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem Dim targetItems As Outlook.Items On Error Resume Next strMileage = Item.Mileage Set targetItems = newCalFolder.Items targetItems.Sort (Mileage) For Each objAppointment In targetItems If objAppointment.Mileage = strMileage Then Set cAppt = objAppointment cAppt.Delete Set cAppt = Item.Copy cAppt.Categories = "Copied" cAppt.Move newCalFolder End If Next End Sub
Copy to a Shared Exchange Calendar
When the calendar you want to copy to or from is in a shared Exchange mailbox, you need to resolve the owner's name or alias and pass it to GetSharedDefaultFolder. You can use the alias, default SMTP address, or display name. I recommend using the alias or email address.
Replace the Application_Startup macro in this text file with the version here.
Private Sub Application_Startup() Dim NS As Outlook.NameSpace Dim CalendarFolder As Outlook.Folder Dim objOwner As Outlook.Recipient Set NS = Application.GetNamespace("MAPI") ' default calendar Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items 'calendar you are copying to Set objOwner = NS.CreateRecipient("maryc") objOwner.Resolve If objOwner.Resolved Then 'MsgBox objOwner.Name Set newCalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar) Set Items = newCalFolder.Items End If End Sub
Update copied appointment
If you want to update appointments on the second calendar, add this code sample to the module. This code looks for an appointment with the same GUID. When you save changes, the matching event is also updated.
Because this code looks for the GUID, you can change the subject or start time.
This code is written to work with the ItemAdd macros above and gets the newCalFolder name from the application_startup macro.
Private Sub curCal_ItemChange(ByVal Item As Object) Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem Dim strBody As String On Error Resume Next ' use 2 + the length of GetDATETIME string strBody = Right(Item.Body, 21) 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
Delete the copied appointment
When you delete the original appointment, the following code will delete the copy as well. Thanks to Adrian for this!
This code watches the deleted items folder for deleted appointments. It gets the newCalFolder name from the application_startup macro.
You'll need to add lines to the top of ThisOutlookSession and Application_Startup.
Updated January 26 2016 to watch the deleted items folder for deleted appointments instead of using the Remove event.
'At top of ThisOutlookSession: Dim WithEvents DeletedItems As Items 'In Application_Start macro: Set DeletedItems = NS.GetDefaultFolder(olFolderDeletedItems).Items 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 GetDATETIME string strBody = Right(Item.Body, 21) If Left(strBody, 1) <> "[" Then Exit Sub For Each objAppointment In newCalFolder.Items If InStr(1, objAppointment.Body, strBody) Then Set cAppt = objAppointment cAppt.Delete End If Next End Sub