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 and change appointments. This is a slight variation on the macros below - the original and target calendar are set in the Startup macro.
- 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). 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. For example, the path shown in the screenshot is "New PST\Test Cal".
- 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.
Dim WithEvents curCal As Items 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 Set NS = Nothing End Sub Private Sub curCal_ItemAdd(ByVal Item As Object) Dim cAppt As AppointmentItem Dim moveCal as AppointmentItem Dim newCalFolder As Folder ' On Error Resume Next 'calendar to copy the appt to Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Test") If Item.BusyStatus = olBusy Then 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 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
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 gets the subject and start date/time when you edit an appointment and looks for a match on the second calendar. When you save changes, the matching event is also updated.
Using this code, you can't change the subject or start time. To be able to change the start time or date, add a random code or GUID at the end of the Notes field to both appointments to identify the matching appointment (a sample follows this macro).
Private Sub curCal_ItemChange(ByVal Item As Object) Dim newCalFolder As Outlook.Folder Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem Dim strStart, strSubject As String On Error Resume Next 'calendar to copy the appt to Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Test") strSubject = "Copied: " & Item.Subject strStart = Item.Start For Each objAppointment In newCalFolder.Items If objAppointment.Subject = strSubject And objAppointment.Start = strStart 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
If you need to be able to change the start date or time, you'll need another way to identify the matching appointment. One way is by adding a GUID at the end of the body. Because the GUID list fairly long, there is a high certainty that the code is unique.
Use this code in the ItemAdd macro:
If Item.BusyStatus = olBusy Then Item.Body = Item.Body & "[" & GetGUID & "]" Item.Save Set cAppt = Application.CreateItem(olAppointmentItem)
Use this in the ItemChange macro:
' 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
And this function to generate the code:
Public Function GetGUID() As String GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36) End Function
If you prefer to use a random alphanumeric code, use the last code sample at Create sequential numbers or random character keywords for the necessary VBA code.