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
I am getting a Run-time error '214...' (see attached picture). Also, how can I get this code to copy to a SharePoint calendar? I have Outlook configured to show the SharePoint calendar.
Do you know which line is triggering the error? As long as the sharepoint calendar is writable, you can use the getfolderpath function and enter the name of the data file and calendar:
Set newCalFolder = GetFolderPath("sharepoint lists\calendar")
Not able to use the GetGuid as OLE32.dll is not accesible as a reference (Online research it is probably disabled do to recent Microsoft patches). Tried an alternative function, but the results are the same as they also depend on OLE32.DLL availability. I am running Windows 7 X64 with Office 2010 X32.
Yeah, that's what I suspected but hadn't had time to check up on. Thanks. Someone earlier used the date - i'll look at the code and see if there is a better way (like using find and restrict).
I found an alternative function for generating GUIDS. Private Type GUID PartOne As Long PartTwo As Integer PartThree As Integer PartFour(7) As Byte End Type Private Declare Function CoCreateGuid Lib "OLE32.DLL" (ptrGuid As GUID) As Long Dim WithEvents curCal As Items Dim WithEvents DeletedItems As Items Dim newCalFolder As Outlook.Folder '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' 9/27/2017. ' Adrian Hernandez. ' ' Code is an adaptation from http://www.freevbcode.com/ShowCode.asp?ID=21 Public Function GUID() As String On Error GoTo errorhandler Dim lRetVal As Long Dim udtGuid As GUID Dim sPartOne As String Dim sPartTwo As String Dim sPartThree As String Dim sPartFour As String Dim iDataLen As Integer Dim iStrLen As Integer Dim iCtr As Integer Dim sAns As String sAns = "" lRetVal = CoCreateGuid(udtGuid) If lRetVal = 0 Then 'First 8 chars sPartOne = Hex$(udtGuid.PartOne) iStrLen = Len(sPartOne) iDataLen = Len(udtGuid.PartOne) sPartOne = String((iDataLen * 2) - iStrLen, "0") _ & Trim$(sPartOne) 'Next 4 Chars sPartTwo = Hex$(udtGuid.PartTwo) iStrLen = Len(sPartTwo) iDataLen = Len(udtGuid.PartTwo) sPartTwo = String((iDataLen * 2) - iStrLen, "0") _ & Trim$(sPartTwo) 'Next 4 Chars sPartThree = Hex$(udtGuid.PartThree) iStrLen = Len(sPartThree) iDataLen = Len(udtGuid.PartThree) sPartThree = String((iDataLen * 2) - iStrLen, "0") _ & Trim$(sPartThree) 'Next 2 bytes (4 hex digits) 'Final… Read more »
I was just coming here to post a version from Chip Pearson.
http://www.cpearson.com/excel/CreateGUID.aspx (It works in Outlook as written, I changed the GetGuid line to GetGUID = CreateGUID() and added Chip's code to the page rather than replacing the current function with his.
His code formats it as [8F64A5857F6E43D297546347F482C4DC]
I have this error now, how did you solved it? I know the comments on this same post may be the key, but I dont really understand, sorry to ask.
thanks in advance
I believe that error is caused by the GUID function - it's apparently not supported in windows anymore. (I haven't had time redo this in a better way yet.)
If you comment out or delete these lines, does it work?
Item.Body = Item.Body & "[" & GetGUID & "]"
For ~6 months this code has worked well for me. I am creating/deleting from a personal outlook email calendar to a shared Office 365 calendar (SharePoint). Recently, it has stopped working and is giving "Run-time error '-2147024891 (80070005)': You don't have permission to perform this operation" on the macro lin: GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
I changed my access to full control of the Office 365 (SharePoint) calendar, but it didn't solve the issue.
Any ideas on how to fix this?
Does it work if you comment out that line?
I ended up replacing the GUID with a Date/Time stamp. It works again. Thanks!
Public Function GetDATETIME() As String
GetDATETIME = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss")
Thanks for the update. I hadn't yet had a chance to test the guid code to see if an update broke it or something else was going on.
Has anyone found a solution to the run time error "You do not have the appropriate permissions..." yet? I need it urgently for an assignment. When I debug, it points to GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
That is an issue with the newest builds of office and windows - the scriptlet is not available or is blocked. There is a different method in the comments and I'm working on using search to find the messages rather than the GUID, except it has some limitations on what can be changed.
I pinned the relevant comment to the top of the comments.
Could anyone help me with the delete function, i have the code setup and it works briliiantly for copying, ammending but it wont delete the copy.
The delete code is kind of buggy - the problem is having a sure-fire way to identify the duplicate and delete the right one. I'll take a look and see if it can be improved using other methods.
Hi, I made some changes to this code and having an issue with update event if there are more than 1 event in same day.
If i made changes to event 1 it will delete the event 2 and update the event 1 details. The event 2 details should not be deleted as I just update the event 2.
Please help me to resolver this.
Hi, I am having an issue if the calendar is having more than one meeting in same day. It will only copied the last updated meeting to another calendar.
Thanks for this Script!
Some Question, i Try to Change it, so that one Calender Sync there Appointments to two other shared calendars.
Could Someone Help me?
Thanks a Lot!
Very inspirational code and running for me already.
However there is this tricky issue always haunting me:
Am I the only one having this trouble, and is there any work around, please?
I have attached the image of my calendar structure.
Thanks for the solution. But I have a question.
My Calendar structure is shown below. My default email id is firstname.lastname@example.org. I am trying to copy an event from email@example.com to firstname.lastname@example.org. When I tried to do that, the event is copied in the same email where I have created.
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 you are copying to
Set newCalFolder = GetFolderPath("\\email@example.com")
it should be like "firstname.lastname@example.org\Calendar"
basically get rid of the \\ and add \Calendar
Thanks for the script. I wrote something similar. Do you plan to enhance the scrip to include recurring meeting? My has but it is not so elegant, especially those that got re-schedule more than once. Hence I wonder how would you handle those.
Just to let you know I use GlobalAppointmentID instead of GUID or GetDATETIME.. I store the information in a .UserProperties("GlobalAppointmentIDLink"). Also, I use .Restrict(strSearch) to limit the search to a defined range.
Coincidentally, I am also trying to improve on the enumeration speed and also thinking of the .Restrict method, but do you use starting date as filter or?
Meanwhile the "GlobalAppointmentID" also sounds intriguing, do you write it into .UserProperties("GlobalAppointmentIDLink")?
The way posted here cannot handle "clicking Accecpt leading to a new appointment" issue.
Would love to see some code snippet if possible.