Last reviewed on June 28, 2015   —  280 Comments

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.

To use:

1. 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.
2. Open the VB Editor by pressing Alt+F11 on your keyboard.
3. Expand Project1 to display ThisOutlookSession and double click to open it to the right side.
4. 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.
5. 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".
6. Place the mouse in the Application_StartUp macro and press the Run button or F5.
7. Create an appointment in your calendar and see if it was copied to the other calendar.

Tip: The path can be copied from the Properties page, which can be helpful for long paths. Right-click on the calendar, choose Properties to see this dialog.

February 11 2015. Updated the macros to use a GUID. This is better (IMHO) because it allows you to change the time or subject... and works with the delete macro. I'm also setting the move-to-folder as a global variable so you only need to change the path once (in the application_startup macro).

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.

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

'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

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  ## 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 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  ## 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 is written to work with the ItemAdd macros above and gets the newCalFolder name from the application_startup macro. Private Sub curCal_ItemRemove() 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) For Each objAppointment In newCalFolder.Items If InStr(1, objAppointment.Body, strBody) Then Set cAppt = objAppointment cAppt.Delete End If Next End Sub  ### Comments 1. Norethel says What if I want to propagate new item through other, non-default calendar folders? I have got followind problem: Two exchange accounts. ItemAdd event arrives on that default one, but is not fired for that second. Exchange for my second e-mail account is in 2003 version. I am using outlook 2010. Could you explain what reasons could be for that situation with not fired ItemAdd event for my second account? 2. Mahmoud says Thanks Diane, this VB code is working like charm. I have one comment about how to identify the calendar folder path, because it was not clear in your article. I used copy calendar to find the path of my calendar, it there any other way to get it because the left pane on outlook is not displaying path required for the code • Diane Poremsky says Are you using the Calendar navigation pane? Yeah, that won't show the parents. You can right click on the calendar and choose properties to see the parent path: \\alias@domain.com\Calendar in the case of a subfolder calendar. Thanks for bringing it to my attention. 3. Rafael says Thanks. This works for new appointments only but, not for changes to an appointment (i.e. adding/changing content like the appointment name, moving the time by dragging the appointment, etc.). Is there a way to make this possible for all calendar changes and updates, including invites, proposed time changes, etc., not just new appointments? • Diane Poremsky says It can be made to work with updates - you need to trap a different event. I'll put something together. • Clint says Hi Dianne - Any luck on the update code for this code Thanks Clint • Diane Poremsky says Nothing that actually works - and I'm on vacation (or supposed to be :)) so I won't have time to work on it for at least a few days. 4. Aziz says Can I know event which start to work when i open the new coming letter in outlook(vba). Thank you! • Diane Poremsky says If i understand the question correctly, you need the open event. Public WithEvents Item As Outlook.MailItem   Sub Initialize_handler() Set Item = Application.Session.GetDefaultFolder(olFolderInbox).Items(1) Item.Display End Sub  Private Sub Item_Open(Cancel As Boolean) 'do whatever End Sub  5. Chris says This made thousands of copies of each and every (existing) calendar item when I just started Outlook. So,it worked, it was just a little too good at its job. Not sure what I did wrong, I followed the steps verbatim. At first it didn't seem to work, then it ran wild next time I ran Outlook. Now I just have to figure out how to delete 1,000,000+ calendar items. • Diane Poremsky says Did you edit it in any way? Is this with an exchange account and/or do you sync with a smartphone? It should only make copies when you add new items to the folder. If you added "copied" to the subject, you can search on that in the subject and delete them. If you didn't 'mark' copied items, you can switch to a list view and add the Modified field to the view then sort by it. If the appointments were all copied at the same time, they will have the same modified date. 6. Chris says It's mostly because I'm uniquely skilled at breaking things. As an engineer, it's kind of a curse. I am not too skilled (read: have always been terrible) with VB or Macros in general. What I was trying to do was have it automatically copy appointments from a non-default AS (outlook.com) account to the local 'default' calendar (I use gmail, so the calendar doesn't sync). Primarily because I wanted to have my email, calendar and tasks all appear on the Today screen, and still be able to sync my calendar with my other computer. I filled in the path to the local calendar in the macro. A little while after that, I ended up finding another post on your site about how to change the default calendar and contacts without changing the default mail. So I set the default storage to the Outlook one, keeping Gmail as the default mail. This ended up being exactly what I wanted. Thank you! But for some reason changing the default storage changed the name of my Gmail account in the Nav bar, from 'Work Email' to a misspelling of my work email address (I told you I can break things). In my infinite wisdom, I deleted the PST files and forgot to disable the macro. And the rest, as they say, is history. • Diane Poremsky says LOL I know what you mean - my son is an engineer, husband was. The macro should have errored out - I'll have to fix that so others won't run into the same problem. 7. Cory Hug says I'm interested in this too. Also, will this update calendar items both directions, or only one? Basically I'm looking for a "sync" between one calendar and another within the same Outlook profile, like a local PST and an Exchange account. • Diane Poremsky says This macro is one direction only. if you want two-way sync, try CodeTwo's FolderSync. 8. derek christensen says I have two calendars in the same profile. I added this VB code and it copies from Calendar 1 (default) to Calendar 2. How can I modify the macro to copy from Calendar 2 to Calendar 1? I tried putting the GetFolderPath as Calendar 1, and it started copying from Calendar 1 to Calendar 1 in an infinite loop (similar to what happened to Chris above, I believe). I was able to delete them using the list view - thanks for that tip. I then tried to modify the Application_Startup() Set newCal to use GetFolderPath, but got an error. • Diane Poremsky says I did not test this, so I could be over looking something - but this should work if you are adding a new item to Calendar 2. Dim WithEvents newCal As Items  Private Sub Application_Startup() Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") Set newCal = Application.ActiveExplorer.CurrentFolder.Items Set NS = Nothing End Sub Private Sub newCal_ItemAdd(ByVal Item As Object) Dim cAppt As AppointmentItem Set CalFolder = Ns.GetDefaultFolder(olFolderCalendar) 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 cAppt.Move CalFolder   End If End Sub 9. Joe Lehman Jr. says Thanks Diane Works great. 10. Hiral Parikh says Hi Diane, Please let me know if you could help me with update macro which also sync modification in existing calendar item. Currently if I change meeting timings in outlook, it does not reflect in the hotmail calendar. Thank you • Diane Poremsky says Actually updating the copies will requiring finding the match and deleting it or updating. It might be easier to create a new updated appointment using an item change or property change event. I'll see what I can come up with. 11. Zoheb Siddiqui says Hi, Thank you for this script. You saved me a lot of headache. One question = Suppose I wanted to copy entries having category "Blue", how would I change the If condition? Thank you for your help. I've never worked with macros before! Zoheb • Diane Poremsky says as you discovered before I could answer :) use If Item.Categories = "Blue" Then 12. Zoheb Siddiqui says I figured out the other query myself :) However, even after a lot of googling, I couldn't figure out another query My collegue shared a calender with me and gave me Editor access. However, when i right click>properties to find out location, the location field is empty. It's under the Shared Calendars folder in my PC. How do I find the location? • Diane Poremsky says Try using "calendar owner\Calendar" - "Calendar owner" will be the name as seen in the navigation pane in 2010 and 2013. You'll need to have permission to write to the calendar (which I apparently don't, and ended up with a lot duplicates in my own calendar when I tried it until I stopped the macro) 13. Zoheb Siddiqui says No Luck :( This is what I'm trying to achieve : My colleague created a calendar called "ABCD" and shared it with me (giving me write permissions). Whenever one of us creates a calender entry with a "Blue" category, it copies to the calendar "ABCD" with the subject line "Busy". Thanks to your wonderful script, I was able to make this work on her PC. But in my PC, I cant figure out what location to use. I tried using "calendar owner\calendar name" but it just created a copy in my own calendar. Thanks for your help. Any other suggestion? • Diane Poremsky says If the mailbox is opened as a secondary mailbox in the profile (Account settings, double click on account, More Settings, Advanced, open mailbox), it works. If ABCD is a subfolder, the mailbox is opened as a secondary mailbox. Set CalFolder = GetFolderPath("display name\Calendar\ABCD") should work as long as you have the right permissions. If you can double lcick on the calendar and create an appt instead of a meeting request, the permissions *should* be ok - I tested it with owner permission on the folder. If it's opened as a shared folder (file, open, other users folder), you need to use GetSharedDefaultfolder: Private Sub newCal_ItemAdd(ByVal Item As Object) Dim myRecipient As Outlook.Recipient Dim CalFolder As Outlook.MAPIFolder Dim cAppt As AppointmentItem Set myRecipient = Session.CreateRecipient("Catherine Smith") myRecipient.Resolve Set CalFolder = Session.GetSharedDefaultFolder(myRecipient, olFolderCalendar) If Item.BusyStatus = olBusy Then Set cAppt = Application.CreateItem(olAppointmentItem) 14. madams says Thanks so much for creating this. I'm also not a programmer as such (linux bash scripting) but like others I find that if you delete an appointment from the default outlook calendar it cannot delete from the secondary calendar. I've noticed that you have indicated that you might make a subroutine to do that. I would be very grateful if you are able to do that. I think with this great script you have created that I'm almost able to get a bit of a kludge working with hotmail that will allow calendar updates/deletions/changes to a phone. We don't have exchange and by using Hotmail I've got it all working except for if the user deletes from his calendar. • Diane Poremsky says I'm going to attempt to do it. :) 15. Zoheb Siddiqui says Thank you for your reply. I appreciate your help very much. I'm a non programmer so I'm a bit lost. It is a shared folder, but not my colleagues primary calendar. It's a calendar shes made called "ABCD". I tried searching for the calendar under (file,open,other uses folder) but it just opens an empty calendar with "no connection" written. Also, where do I paste this code. I'm sorry for all these questions - im a total n00b and thank you for your help so far • Diane Poremsky says Subfolder can't be opened using File, Open, Other user's folders. You need to add it to your profile. In Outlook 2010/2013, File, Account Settings, double click on your account, then More Settings - add the mailbox on the second tab. You'll only see the folders you have permission to see. See View shared subfolders for more information. 16. Gary says Diane, did you ever create the trap so that this will work with changes to an appointment also? Plus how would I alter the code, I want it to grab meetings only with the category Out of Town on it. • Diane Poremsky says No, i haven't been able to get it to work and haven't had a lot of free time to figure out what i am doing wrong. Checking for categories is easy - add it to the If statement: If Item.BusyStatus = olBusy AND Item.categories = "Out of Town" Then if you don't need the busy filter, remove that part. 17. Gary says Thanks for your help. Hopefully you get a little free time to get that trap working for update/moved meetings, that would be great. 18. Marco says Diane, I tried to make it work but i do something wrong. I want to copy from the default calendar to the hotmail calendar (also in outlook). so I changed the line: Set Items = GetFolderPath("xxx.xxxxx@live.nl\Agenda van M").Items But it doesn't work. What do i wrong? • Diane Poremsky says Do you get any error messages? Which version of Outlook? At the moment, moving to the Hotmail calendar works, not copy. (Copy used to work, not move.) 19. Vaibhav Rajeshirke says Hi Diane, I am having issues running this macro. I am using Outlook 2013 on Windows 8 Pro. I have changed trust center macro settis to "Notification for all macros" and click 'enable macros' at every startup on outlook. Macro runs fine and when I create new appointment or receive meeting request in my default imap account, it copies appointment/meeting with all details to my hotmail account. But it gives runtime error -2147221233 "The message you specified cannot be found". When I click 'Debug' button it takes me to line after following code: With cAppt .Subject = "Copied: " & Item.Subject Macro stops working after that and I have to restart outlook in order to keep macro ready for next appointment. Do you have any suggestion what might be wrong here? • Diane Poremsky says I need to test this - when Microsoft changed over the new calendar format, the ability to copy to the calendar was broken. You can test adding a save to the code and see if it helps - this will make it a real "Move". .Body = Item.Body .Save End With 20. Vaibhav Rajeshirke says Diane, I appreciate your quick response. I tried adding .Save but still have the same problem. • Diane Poremsky says It looks like they fixed the move/copy stuff over the weekend and it works with or without save. You are still getting the same 'message can't be found error'? Are you accepting the meeting from the inbox or calendar? I can't repro it either way. :( Are you using a non-English version? The only part that should be affected by localization is the folder path so i don't think that is the problem. The error seems to say it can't find the message, which is set in the application_startup code and the Dim WithEvent line. Oh, and you don't need to restart outlook to test - click in the application_startup macro and press Run. 21. Jakob Riis says Hi I'm trying to use your great VB script but I fail pretty fast. I'm trying to copy to another users calendar but it says that it isn't possible to move the appointment. It debugs at: .Move CalFolder. It makes the copy just fine but won't move it. I hope you can find time to help me. • Diane Poremsky says This is an Exchange server account? What permission does your account have on the shared calendar folder? 22. Babak says Hello Diane, I have two calendars: one is local and the other is an EAS. I have been using this macro and have not had success. 1. I tried it with your original code and there was no error code or action. 2. I tried it with the modifications as listed in your March 22 post - Set newCal = Application.ActiveExplorer.CurrentFolder.Items 'Set newCal = NS.GetDefaultFolder(olFolderCalendar).Items and Set CalFolder = NS.GetDefaultFolder(olFolderCalendar) 'Set CalFolder = GetFolderPath("B CALENDAR\Calendar (This computer only)") and '.Move CalFolder End With cAppt.Move CalFolder In the sub "Private Sub newCal_ItemAdd(ByVal Item As Object)" and I still get no response or error code. Of course, I run Private Sub Application_Startup() each time and turn Outlook on and off prior to adding a new calendar appointment. Thank you, Babak • Diane Poremsky says What is the error message? 23. Babak says Hello Diane, Thank you for your quick response. I found my error. 1. In the Application_Startup macro the correct code for my situation (Outlook 2013 on Win 7 home): 'Set newCal = NS.GetDefaultFolder(olFolderCalendar).Items Set newCal = Application.ActiveExplorer.CurrentFolder.Items and 2. Set CalFolder = GetFolderPath("\\babak.x@hotmail.com\Calendar") The outlook is setup with an EAS (Hotmail), an IMAP e-mail ("B CALENDAR\Calendar (This computer only)"), and others. I wanted that an appointment made in my EAS each time a new appointment would be made in B Calendar. Correction #1 now sets Application.ActiveExplorer.CurrentFolder.Items as B Calendar folder, IF and only if this folder is active. That is, if I run this macro with F5 AND this folder is active the new appointment is correctly copied to the EAS folder. Upon startup, however, this folder, which is not the active folder, is not set as newCal. Please assist with the following: 1. How can I modify Set newCal = Application.ActiveExplorer.CurrentFolder.Items to be set newCal as ("B CALENDAR\Calendar (This computer only)") I have tried the code: Set newCal = NS.GetFolderFromID("B CALENDAR\Calendar (This computer only)").Items which gives me the error: Run-time error '-2147024809 (80070057)': Sorry, something went wrong. You may want to try again. 2. The code works well to copy new appointment under the conditions as stated above. How can I modify the code to update the appointment if changed. That is, upon creation the appointment copies from the B Calendar folder to the EAS folder. However if I make a change, for example, if I change the location or time the copied item does not change. How can I modify the code to change the copied item as well. Again, I thank you for your response and expertise • Diane Poremsky says The problem could be this: GetFolderPath("\\me@hotmail.com\Calendar") don't use the \ - it should be this; GetFolderPath("me@hotmail.com\Calendar") If that fixes it, you don't need to read the rest of this. :) This is for the default calendar: 'Set newCal = NS.GetDefaultFolder(olFolderCalendar).Items This is for the selected calendar: Set newCal = Application.ActiveExplorer.CurrentFolder.Items Is the either calendar you are copying to or from your default calendar? if not, you need to use something like this: From calendar: Set CalFrom = GetFolderPath("me@hotmail.com\Calendar") To calendar Set CalFolder = GetFolderPath("B CALENDAR\Calendar (This computer only)") 24. Diane Poremsky says Oh, and updating is harder - my plan is to get the entryid of the copy and add it to the original when the copy is created then use the entry id to delete the copy and replace it - but i haven't had time to work on it. I'm getting the entryid for tasks - so I'm halfway there as soon as i get the time. 25. Babak says Diane, Thank you for your guidance. These are the changes to the code that fixed it: 1. I changed the first line from newCal to CalFrom: Dim WithEvents CalFrom As Items 2. I set the CalFrom fodler path as Set CalFrom = GetFolderPath("B CALENDAR\Calendar (This computer only)\B (local)").Items The section "B CALENDAR\Calendar (This computer only)" is from the Location path in the General tab of the Properties box. The section "\B (local)" is from the first description box in the General tab of the Properties box. 3. I changed the name of the sub newCal_ItemAdd to CalFrom_ItemAdd. 4. I changed CalFolder to CalFolderTo: Set CalFolderTo = GetFolderPath("babak.x @hotmail.com\Calendar") Thank you for your answers. I will wait for your update to the entryId tutorial. Babak 26. Travis Smith says When I use If Item.BusyStatus = olBusy Then it throws an error (http://screencast.com/t/ugMoLJa5bCPu). While I don't need Item.BusyStatus, I do need Item.Location, which throws the same error. Setup: Outlook 2013, Windows 7 64bit 27. BAbak says Diane, The procedure works correctly to copy new appointments to the Hotmail calendar (EAS), however the calendar in Outlook.com DOES NOT update with the copied calendar entries. If I drag and drop the new appointment to the EAS calendar, the calendar in Outlook.com DOES update with the copied appointment. How do you suggest that I troubleshoot this? Babak • Diane Poremsky says Do the copied ones update to outlook.com if you add a category (in the outlook.com calendar in outlook) ? I 28. Maurits says Diane, Procedure works as a charm. Just like Rafael mentioned this works for new appointments only but, not for changes to an appointment (i.e. adding/changing content like the appointment name, moving the time by dragging the appointment, etc.). Could you update the code in order to work with the other traps? • Diane Poremsky says Yeah, it's on my list, along with a 40 hour day. :) I'll try and get to it this week end ad i think i have all the "parts" I need, i just need to put it together. 29. Jim Fekete says Hi Diane: I came here after you answered a question about calendar syncing (or lack thereof) on the answers.microsoft.com forum for Outlook. I installed the vba procedure per the instructions above. The procedure works except for the fact that after an appointment is copied, the program crashes with "Run-time error '2147221241 (80040107) The operation failed. The debugger highlights the "If Item.BusyStatus = olBusy Then" statement. Otherwise it works great. Is there a simple fix? Thanks, Jim • Diane Poremsky says I don't know - i need to investigate it. Is the folder path correct? That could be one source of the error. 30. Babak says Diane, Terrific! The category trick worked on manual category selection. I then modified the code: With cAppt .Subject = subj & calAppt.Subject .Start = calAppt.Start .Duration = calAppt.Duration .Location = calAppt.Location .Body = calAppt.Body .Save .Move CalFolderTo End With to this: With cAppt .Subject = subj & calAppt.Subject .Start = calAppt.Start .Duration = calAppt.Duration .Location = calAppt.Location .Body = calAppt.Body .Categories = "Blue Category" .Save .Move CalFolderTo End With The code (.Categories = "Blue Category") does change the copied calendar entry to the "Blue Category" in the Outlook 2013 EAS, however it then does not update in Outlook.com. I then manually changed the category to "Green Category" and hit F9. This did update in Outlook.com. Kindly suggest a code improvement to mine. Thank you, Babak • Diane Poremsky says EAS is goofy. :( Try setting the category after its moved - With cAppt .subject = "Copied: " & Item.subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body .Save End With Dim moveCal as object Set moveCal = cAppt.Move(CalFolder) moveCal.Categories = "moved" moveCal.Save 31. Diane Poremsky says For all you who want to replace the copy when you edit an event, test this please - http://www.slipstick.com/files/link-outlook-com.txt - it doesn't do exactly what you want (still working on that) but it does link to the copy so you can open it. My goal is to use the entry id to find and delete the match then copy a new one on save. I want to make sure the entryid doesn't change during all the syncs. • Daniel says Diane, Has there been any progress on the update/delete functionality? Thanks! • Diane Poremsky says I haven't had a chance to work on it a lot lately - I have it down to using the entry id to link to the two appointments but it wasn't working good and I had to put it aside to do some important projects. (I know... this is important too. :)) 32. Babak says Terrific. That worked. Thank you, Babak 33. Daniel Schunk says Hello, Diane, while using the code in Outlook 2003, I get an compiling error message in this row: Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder Outlook says, the user defined type isn't defined :-/ Any ideas? Kind regards, Daniel • Diane Poremsky says Is the folder name / path correct? That shouldn't cause the not defined error - that means you are referring to an object in an object library that wasn't referenced, but everything should be referenced since its pure Outlook VBA. Did you try copying the code again? 34. Orlando says Hi, Unfortunately I was unable to get this to work. I have multiple .pst folders, all on the same profile of outlook 2010, and an additional hotmail account used to sync my contacts and calendar items to my windows 8 phone. I want to be able to add items to my default outlook calendar that will copy to the hotmail (MAPI) calendar (which is connected to my phone) When I right click the calendar properties I get; the default location is \\orlando the MAPI location is \\orlando@myemailaddress.com however that makes the target calendar \\orlando@myemailaddress.com\orlando's calendar so logic should dictate, Set CalFolder = GetFolderPath("orlando@myemailaddress.com\orlando's calendar") so when i place a item in my default calendar it should copy right away to my MAPI calendar. However this does not work. So obviously I am missing something... tried to get my head round the http://www.slipstick.com/outlook-developer/working-vba-nondefault-outlook-folders/ part, but the logic of it doesn't make sense to me, so make its hard to fit it in the existing code, as all that's being set is another default location when that's not the issue, its the target calendar I want it copied too. Do you have a youtube/video tutorial that we could view instead? • Diane Poremsky says I don't think i have a youtube for this (I have so many, i forget what's there :)) - I will try to get one made, but I'm traveling this week and don't think I'll be able to do it this week. right click on Orlando's calendar and choose properties - the calendar name will be listed. That is the name you need to use. Only one calendar is the default, the other calendar is not. Which calendar is the one you are creating the appointment in? If the Outlook.com/Hotmail data file is set as the default data file, you'll use Set CalFolder = NS.GetDefaultFolder(olFolderCalendar) as the move to calendar and use getfolderpath line to identify the calendar you are watching. 35. Jacob Mulberry says Diane, When I run this script after every time I create a event it works but I get a error stating Run-Time error '-2147221241 (80040107)': The operation failed. Any ideas? Thanks in advance! • Diane Poremsky says Which line does it stop on? • Jacob Mulberry says If Item.BusyStatus = olBusy Then This happens on Outlook 2010 and 2013. • Diane Poremsky says Sorry for taking so long to look at this - between vacation and a business trip, I didn't have a chance to look at it. Try deleting the '= olbusy then' part and retyping - and test with olfree. • Jacob Mulberry says I tried this to no avail. Still get the error. :/ Not sure what the difference is or what I need to do. • Diane Poremsky says Are you selecting Busy? Don't let outlook choose it. For whatever reason, letting outlook set the busy state causes it to fail here (in outlook 2013). • Jacob Mulberry says Diane, That didn't work for me. However. Maybe this will help you help me solve this problem :). I put in the code " On Error Resume Next ''' " before the olbusy and it works. The only problem is that sometimes it creates 2 appointments one is right and the other is the next 15 min mark in the current day so it pops up with a reminder saying I have a appointment in 15 mins. Hope this helps. Thanks for your continued work. :) • Diane Poremsky says The problem is definitely with that line... Are you opening all day events and unchecking the all day box? Does it work if you select something else then Busy in the Free/Busy selector? (That is making a difference here - its probably what i did last night when i tested it.) 36. Jacob Mulberry says Diane, It stops on the line "If Item.BusyStatus = olBusy Then" I am running Outlook 2013 if that makes a difference. Thanks, 37. Jim Fekete says FWIW, this is the same error I reported above, running Outlook 2010. I've poked around in the code, but can't diagnose. Jim • Diane Poremsky says I assume you mean the Busy error? That is the weirdest error - I got the same error in my first test, then changed it to olFree - no errors (when copying a Free item). I changed it back to olBusy and it worked. If it had quotes, I'd say it was a problem caused by copying code, but that isn't the problem with this. (I deleted "= olBusy Then" and retyped it, first with OlFree, then again with olBusy.) If Item.busyStatus = olBusy Then 38. Jim Fekete says I agree, weird error. It successfully runs once, but after the item is copied, the run time error pops up. if I reset and rerun, it again copies one item, but then comes the runtime error. Very consistent. Could it be the fact that my folder path has an apostrophe in it? ("Jim's calendar"). I'd just try it, but I don't know how to change that path without losing the calendar. • Diane Poremsky says Can you tell comments are sorted new to old? LOL In thinking about this more, if it's not failing on the Busy line, maybe it is something with the apostrophe. I tested it extensively with both outlook 2013 and 2010 when i wrote it but its possible an update is causing problems. • Jim Fekete says It failing on the busy line, but since that line is an if...then line, the problem could be anywhere between that line and the End If, right? And the only thing I can think of that is weird in there is the folder path call not playing nice with the apostrophe in that path. although I'm also going to try Jacob's Iferr line above to see if I get the same response. • Diane Poremsky says I'm pretty sure it's a bug in Outlook where Busy is not properly set when Outlook changes Free to Busy when you change all day events to timed events. 39. Jim Fekete says I agree, weird error. The error occurs after the item is copied, so it runs once, but then nees to be reset and re-run. Could it be that I have an apostrophe in my folder path? ("\\feketejim@hotmail.com\Jim's calendar") That's the only weird thing I can see. • Diane Poremsky says I don't think that is it - BTW, you don't need the \\ in the path although if it works, then it obviously doesn't matter. :) How are you opening the appointments? I think the problem is a bug in Outlook related to how the Busy value is set. • Jacob Mulberry says Diane, Would there be a way for if the appointment is out of office copy it over and then change it to busy? Thanks, Jacob • Diane Poremsky says Yes, you need to change olbusy to olOutOfOffice in the if line (and select OOF in the show time as field). On the new appt, where oyu copy the fields over, add busystatus - With cAppt .Subject = "Copied: " & Item.Subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body .BusyStatus = olBusy .Save End With 40. Carolina Giraldo Correa says Hi Diana, I'm not a developer but I'm writing a code in outlook which creates an appointment using a not default calendar. The part of the code that creates the appointment is ok but I cannot get VBA to select the correct calendar. This is the code: Dim Ns As Outlook.NameSpace Set Ns = Application.GetNamespace("MAPI") Set Items = Session.GetDefaultFolder(olFolderCalendar).Folders("Staff/Calendar") I've tried everything but it doesn't work, I get an error "An object could be found" but I followed the instructions you gave earlier to get the name of the calendar and I'm sure that this is the correct name. Please help me because I've spent so much time in this and don't find any solution • Carolina Giraldo Correa says Hi Diana, Thanks for replying so quick. Yes you were right I needed the getfolderpath function, now it recognizes the calendar but it doesn't use it to create the appointment, I know this because I used the Step Into option and it runs smoothly among the whole code but at the end it creates the appointment in the default calendar. I'm really sorry for being a pain. Regards • Diane Poremsky says I'll test the code this afternoon - in glancing over it, it looks like it should use the correct calendar, but I could be missing something that I'll notice when its in the VB editor. 41. Carolina Giraldo Correa says if helps this is the full code: 'In ThisOutlookSession 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 Private Sub CommandButton1_Click() Set Items = GetFolderPath("Staff\Calendar").Items Dim eventTitle As String Dim myItem As Object Dim myRequiredAttendee, myOptionalAttendee As Outlook.recipient Set myItem = Application.CreateItem(olAppointmentItem) myItem.MeetingStatus = olMeeting myItem.BusyStatus = olOutOfOffice myItem.AllDayEvent = True myItem.ReminderSet = False myItem.End = Me.DTPicker2.Value myItem.Start = Me.DTPicker1.Value Set myRequiredAttendee = myItem.Recipients.Add(ComboBox1.Value) myRequiredAttendee.Type = olRequired 'Set myOptionalAttendee = myItem.Recipients.Add("Claudia Hernandez") 'myOptionalAttendee.Type = olOptional myItem.Subject = Label5.Caption & " days" & " of " & Label8.Caption myItem.BusyStatus = olOutOfOffice myItem.Send MsgBox "You are taking " & Label5.Caption & " days of leaving" Dim today As Date today = Format(Date, "dd-mmmm-yyyy") OptionButton1.Value = False OptionButton2.Value = False TextBox1.Value = "" Label5.Caption = "" Me.DTPicker1.Value = today Me.DTPicker2.Value = today ComboBox1.Value = "" End Sub Private Sub CommandButton2_Click() Dim today As Date today = Format(Date, "dd-mmmm-yyyy") OptionButton1.Value = False OptionButton2.Value = False TextBox1.Value = "" Label5.Caption = "" Me.DTPicker1.Value = today Me.DTPicker2.Value = today ComboBox1.Value = "" End Sub Private Sub CommandButton3_Click() Unload UserForm1 End Sub Private Sub DTPicker1_Change() Dim sDate As Date Dim eDate As Date Dim days As Integer sDate = Me.DTPicker1.Value eDate = Me.DTPicker2.Value Dim WholeWeeks As Variant Dim DateCnt As Variant Dim EndDays As Integer Dim EndDate As Date Dim begdate As Date Dim workdays As String begdate = sDate EndDate = eDate WholeWeeks = DateDiff("w", begdate, EndDate) DateCnt = DateAdd("ww", WholeWeeks, begdate) EndDays = 0 Do While DateCnt <= EndDate If Format(DateCnt, "ddd") "Sun" And _ Format(DateCnt, "ddd") "Sat" Then EndDays = EndDays + 1 End If DateCnt = DateAdd("d", 1, DateCnt) Loop workdays = WholeWeeks * 5 + EndDays Label5.Caption = workdays End Sub Private Sub DTPicker2_Change() If Me.DTPicker1.Value = Me.DTPicker2.Value Then MsgBox "Leave must be at least one day" End If Dim sDate As Date Dim eDate As Date Dim days As Integer sDate = Me.DTPicker1.Value eDate = Me.DTPicker2.Value Dim WholeWeeks As Variant Dim DateCnt As Variant Dim EndDays As Integer Dim EndDate As Date Dim begdate As Date Dim workdays As String begdate = sDate EndDate = eDate WholeWeeks = DateDiff("w", begdate, EndDate) DateCnt = DateAdd("ww", WholeWeeks, begdate) EndDays = 0 Do While DateCnt <= EndDate If Format(DateCnt, "ddd") "Sun" And _ Format(DateCnt, "ddd") "Sat" Then EndDays = EndDays + 1 End If DateCnt = DateAdd("d", 1, DateCnt) Loop workdays = WholeWeeks * 5 + EndDays Label5.Caption = workdays End Sub Private Sub OptionButton1_change() If OptionButton1.Value = True Then Label8.Caption = "Annual Leave" Else If OptionButton2.Value = True Then Label8.Caption = TextBox1.Value End If End If End Sub Private Sub OptionButton2_Change() If OptionButton2.Value = True Then TextBox1.Visible = True Else If OptionButton2.Value = False Then TextBox1.Visible = False End If End If End Sub Private Sub TextBox1_Change() If OptionButton1.Value = True Then Label8.Caption = "Annual Leave" Else If OptionButton2.Value = True Then Label8.Caption = TextBox1.Value End If End If End Sub Private Sub UserForm_Initialize() Dim today As Date today = Format(Date, "dd-mmmm-yyyy") Me.DTPicker1.Value = today Me.DTPicker2.Value = today With ComboBox1 .AddItem "" .AddItem "1" .AddItem "2" End With End Sub 42. Carolina Giraldo Correa says Thank you very much Diana, I would really appreciate it. 43. GR8iTUD says Diane, I recommend adding an and qualifier that looks for "Copied" in the subject to the if statement with your BusyStatus check. I had this run away too, because I commented out the three lines that move the appointment since I am having a permissions issue with the move command (I think my IT group has locked me out of that function). • Diane Poremsky says Good idea - If Item.BusyStatus = olBusy And Left(Item.Subject, 6) = "Copied" Then I don't think they can lock out move by itself. They can block all macros though. They can remove your ability to create items in mailboxes you don't own, but if you are an owner, they can block it. Do you get any error messages? 44. Todd Hunter says Hi Diane, I am also having a problem with the error 2147221233 The message you specified cannot be found. I am using OL 2010 and Win7. It does copy the appointment but throws the error. Reading through the comments above it was unclear if there was a resolution. My folder path is GetFolderPath("SharePoint Lists\SmarterMail_Calendar") Thanks, • Diane Poremsky says I'm still looking into this error. • Todd says Hi Diane, wondering if you had a chance to look into this. I have been using the script but i get the error every time I add an appointment. Todd • Diane Poremsky says You and Paul were getting the same error - i thought i solved it, but i don't see anything in the comments. I'll look over it again and look for my notes. 45. Paul says Hi Diane, First off, thanks for your macro! When I run the macro I get a run-time error '-2147221233'. I watch the value of the variables within the newCal_ItemAdd sub in debug mode, and I see pretty much all the members of Item object have a value of ''. What could be happening? Thank you again! • Diane Poremsky says Does this happen with all appointments or just some? 46. Paul says Sorry, the quoted value got removed when I posted the message, probably because of the angle brackets in it. Here goes again: [...] and I see pretty much all the members of the Item object have a value of 'The operation failed.' (wrapped with angle brackets). 47. Paul says Hi Diane, I posted a comment on Aug 29 on this article to thank you about this great macro! Also posted a question, but it never appeared. Any idea what could happened? I think my post is still to be moderated? Thanks! Paul • Diane Poremsky says It may have gotten flagged as spam, I get so many comments that I don't usually have time to look for false positives in that folder. Or it just got missed. I'll see if i can find it. 48. Todd Hunter says Thanks =) 49. Paul says All of them. I just tried putting a breakpoint before that part of the code and if I go step by step the values get populated. If I let it run freely, the values are not set. Pretty odd, eh? • Diane Poremsky says It is odd. I'll try and repro it. 50. Paul says Hi Diane, any luck with that? :-) Thanks again! • Diane Poremsky says It has me stumped. On my test setup (copy to a SharePoint calendar) I get the error on .Start = Item.Start but the appt is created and moved if i click end instead of Debug. I added On Error Resume Next after the last DIM statement to eliminate the error. I don't get the error if i step into it. I used debug.print to see the values: .Start = Item.Start Debug.Print Item.Start Debug.Print .Start Debug.Print "-----" .Duration = Item.Duration Debug.Print Item.Duration Debug.Print .Duration Debug.Print "-----" and it looks like the code is running a second time, when its saved to the second calendar. Using Set newCal = GetFolderPath("myalias@domain.com\Calendar").Items eliminates the problem (which shouldn't exist to begin with). 51. Dimitris Bantileskas says Hi Diane: I am trying to copy my shared calendar into my personal calendar and copied your code into my outlook session. I edited the following Set newCal = NS.GetDefaultFolder(olFolderCalendar).Items into this Set newCal = Session.GetDefaultFolder(olFolderCalendar).Parent.Folders("\\Public Folders - alias@domain.com\All Public Folders\Litigation Support - Forensic Accounting Calendar").Items to identify the public calendar I also edited the following: Set CalFolder = GetFolderPath("display name in folder list\Calendar\Test") into this Set CalFolder = GetFolderPath("alias@domain.com\Calendar\Dimitris Team") to identify my personal calendar. When I place the mouse in teh Application_Startup macro and press the Run button, Outlook shows this error message: Run-time error "-2147221233 (8004010f)': The attempted operation dailed. An object could not be found. Could you please help with this? Thanks in advace, Dimitris • Diane Poremsky says You get that error immediately? Your PF path is wrong. Set newCal = Session.GetDefaultFolder(olFolderCalendar).Parent.Folders("\\Public Folders - alias@domain.com\All Public Folders\Litigation Support - Forensic Accounting Calendar").Items Not sure it will work but try the following. Set newCal = GetFolderPath("Public Folders - alias@domain.com\All Public Folders\Litigation Support - Forensic Accounting Calendar") • Diane Poremsky says This format worked in my test with an Exchange 2013 public folder mailbox: Set newCal = GetFolderPath("Public Folders - alias@domain.com\All Public Folders\Accounting Calendar") • Dimitris Bantileskas says Hi Dianne: I made the changes you suggested but now I'm getting the following error message: "Run time error '13": type mismatch" Do you know what this means? Thanks, Dimitris • Diane Poremsky says It means it is expecting one type of something and you are using another type. Like if you are trying to move mail to a calendar or an appointment to a mail folder. What line do you receive the error message on? • Diane Poremsky says I can't believe it took me so long to see the problem. Sheesh. Five missing characters at the end of the public folder line: .items Because you are using getfolderpath, this is all you need in app start up - but you do need .Items at the end: Private Sub Application_Startup() Set newCal = GetFolderPath("Public Folders - diane@slipstick.com\All Public Folders\Company Files\Company Calendar\Litigation Support - Forensic Accounting Calendar").Items End Sub 52. Dimitris says Hi Dianne: I made the edits as you suggested. Here is how I changed it: Set newCal = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar") However, now I receive this error message: "Run-time error '13': Type mismatch" Do you know what that means? I appreciate your help, Dimitris 53. Dimitris Bantileskas says Hi Dianne: I receive the error message on the following line: Set newCal = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar") Provided below I have copied the entire code for your reference: Dim WithEvents newCal As Items Private Sub Application_Startup() Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") Set newCal = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar") Set NS = Nothing End Sub Private Sub newCal_ItemAdd(ByVal Item As Object) Dim cAppt As AppointmentItem Dim moveCal As AppointmentItem Set CalFolder = GetFolderPath("dbantileskas@nsllpcpa.com\Calendar\Dimitris Team") 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 .Save End With ' set the category after it's moved to force EAS to sync changes Set moveCal = cAppt.Move(CalFolder) moveCal.Categories = "moved" moveCal.Save End If End Sub 54. Callie Daum says I am trying to copy from my default calendar to another calendar in Outlook. It is in the same .pst under the default calendar. I have copied your code and made adjustments but it is not working. I am very green with VBA so any help you can provide would be spectacular ;) Sub Application_Startup() Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") Set Items = Session.GetDefaultFolder(olFolderCalendar).Folders("Haymarket Hospital Build").Items Set NS = Nothing End Sub Sub newCal_ItemAdd(ByVal Item As Object) Dim cAppt As AppointmentItem Dim moveCal As AppointmentItem On Error Resume Next Set CalFolder = GetFolderPath("display name in folder list crichey@novanthealth.org\Calendar\Haymarket Hospital Build") If Item.Category = "HAMC" Then Set cAppt = Application.CreateItem(olAppointmentItem) With cAppt .Subject = Item.Subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body .Save End With ' set the category after it's moved to force EAS to sync changes Set moveCal = cAppt.Move(CalFolder) moveCal.Categories = "HAMC" 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 • Diane Poremsky says Which line does it fail on? • Diane Poremsky says To copy from google, This line in the Application startup code: Set newCal = NS.GetDefaultFolder(olFolderCalendar).Items This is the folder outlook watches for itemAdd. It needs to be Set newCal = GetFolderPath("display name of google calendar in folder list\Calendar").Items and this line is the folder that the item is moved to Set CalFolder = GetFolderPath("display name in folder list\Calendar\Test") it need needs to be this if you are moving to your default calendar Set CalFolder = NS.GetDefaultFolder(olFolderCalendar) 55. Callie daum says When I run the script I don't get any errors or failures in the script. But the appointment never copies to the new calendar. Nothing happens. 56. Callie Daum says I can't tell where it is failing because when I run it in VB, it runs. Nothing happens though - the appointment is not copied over. VB does not indicate any errors. • Diane Poremsky says If you are using error checking, like on error resume next, delete it for now. We want it to show where the error is. Use the command to step into the macro then watch it - you'll be able to see what it is skipping. 57. Dimitris Bantileskas says Hi Dianne: The edits worked perfectly. I apprciate all your help. However, I have another quetion/challenge for you. What do we need to do in order to copy appointments that are listed from 4pm to 6:30pm from the Shared Calendar to my personal calendar? Is there a way for your code to filter such period? Thanks again, Dimitris • Diane Poremsky says You would add the time field to the If statement - If Item.BusyStatus = olBusy Then If TimeValue(Item.Start) > TimeValue("4:00:00 PM") And TimeValue(Item.Start) < TimeValue("6:30:00 PM") Then ' code end if end if 58. Callie Daum says Hi Diane! Thank you for your willingness to help! When I run the script I don't get any errors or failures in the script. But the appointment never copies to the new calendar. Nothing happens. Any ideas? • Diane Poremsky says Remove or comment out the On Error Resume Next line and see where it errors. 59. Dimitris Bantileskas says Hi Diane: You have been amazing! Thank you so much. It worked perfectly. It is my understanding from prior posts that you are in the process of developing a code that will update and/or delete appointments from the public to the personal calendar. I wanted to ask whether you have succeeded in this task. If so, can you please help me and send me a copy of your code? Thanks again, Dimitris • Diane Poremsky says No, I have not succeeded in doing it. My plan was to save the entry id of the copy but it wasn't working with outlook.com accounts. That method should work with mailbox and public folders though. I'll see if I can find the code and dust it off. 60. Isaac Wyatt (@IsaacWyatt) says Thanks - I'll try that out. Best, Isaac 61. James Mears says Hi Diane, I would also be interested in seeing the code for updating and deleting appointments. I have modified your original code a bit so that an internet calender subscription's items (ical) are copied into a users main exchange calendar... but any updates in the internet calendar trigger a new item to be copied to the main calendar as well as leaving the original copy in place. Deleting items when they are removed from the internet calendar would also be great. • Diane Poremsky says I worked on it for a bit but ran into a problem tracking the copy - that failed (no good place to store the entry id) - leaving a search query as the other option. I haven't had a lot of free time to work on it from this angle yet. 62. Kevin Minkoff says Hi Diane: I've go the same issue. I made the substitutions as you listed above. However, when running I get an error and: Set moveCal = cAppt.Move(CalFolder) is highlighted. What should I do? • Diane Poremsky says Is the path in this line: Set CalFolder = GetFolderPath("display name in folder list\Calendar\Test") correct? If so, what does the error message say? 63. patrik quick says Hi Diane I have run this macro succesfully with a google calendar. The new appointment is succesfully in my google calendar but when VBA runs "moveCal.Save" i dont have the permission to do this. So i stop the macro from runing and the appointment is moved. Is their a way to logg on to the internet calendar? to get the right access? • Diane Poremsky says How is the google calendar added to Outlook? If the calendar is in Outlook as an internet calendar, it's read only. If you can't create a new appointment in it "manually", the macro won't work either. 64. Sean says Hi Diane, I can't seem to get this working. I am trying to copy new appointments made in my default calendar to my live calendar (within outlook) so that it will sync to my phone. I believe I am using the correct path: GetFolderPath("xxxx@gmail.com\Work Calendar") this should be the target calendar in which we are trying to copy appointments from our default calendar to, correct? Whenever I create a new appointment in my default calendar it starts making copies of the appointment into the same default calendar in an infinite loop. I have not edited any of the code. Please help, I'm going crazy. Thanks! • Diane Poremsky says Is this a google apps account? Right click on the calendar folder and choose Properties - its near the bottom. In the location field is something like \\alias@domain.com - copy it (but not the \\). If the folder is a subfolder, the full path will be there. The calendar name is in the field about it - copy that and put it together with the location. 65. Dimitrs Bantileskas says Diane: You have been great and your code works when I add an appointment from the public calendar to the personal calendar. I am still interesred in updating the personal calendar when changes are made in the public calendar. I undertand that the answer to this request is not simple and I wanted to ask you whether we can build a code that will conduct the following: STEP 1: Delete all appointments listed on the personal calendar for the next 30 days from the current date. STEP 2: Export all appointments listed on the public calendar for the next 30 days from the current date in .ics file onto the desktop. Please note that the .ics file will be overwritten every time that I export the file. STEP 3: Import the saved .ics file into the personal calendar. I am currently following the above steps manually at the end of each work day. It takes about a minute to do the above. I wanted to know whether I can run a VBA code that will conduct all the above. Please note that I am not looking for the code to run automatically when appointments change during the work day. I am interested in running the code at the end of the day. Your help is greatly appreciated. Thanks, Dimitris • Diane Poremsky says That should be doable... I think. I'll have to check. 66. Sean says No, it is a hotmail/windows live account. I did what you stated above previously per the original instructions. 67. Anthony says Hi Diane Thank you for your work on this, you are very generous. I have been looking for code like this to transfer appointments to my outlook.com calendar. But I can not seem to get it to do this, although the code works fine for local calendars on my computer. The program crashes in the GetFolderPath function, on the line that says "Set oFolder = olApp.Session.Folders.Item(FoldersArray(0))" and returns an error number -2147221233 I am running windows 8, outlook 2010. I have read the previous posts and tried some of the suggestions without success. I have not been able to set the outlook.com calendar as the default calendar either, as under data file settings says "not available" Do you have any suggestions? Thanks Anthony --------------- Here is the code I have been trying, based on yours (as well the application startup sub and getfolder path function, which are unchanged from yours). Sub newCal_ItemAdd() Dim calfolder As Outlook.Folder Dim cAppt As AppointmentItem Dim moveCal As AppointmentItem On Error Resume Next Set calfolder = GetFolderPath("anthonyxxxxxxxx@outlook.com\Calendar") Set cAppt = olApp.CreateItem(olAppointmentItem) With cAppt .Subject = "test" .Start = #12/7/2013 10:30:00 PM# .End = #12/7/2013 11:30:00 PM# .Save End With ' set the category after it's moved to force EAS to sync changes Set moveCal = cAppt.Move(calfolder) moveCal.Categories = "moved" moveCal.Save End Sub 68. Shawn says Diane, Thank you this solves a lot of my issues on multiple calendars, I have got the code to work if I create a new appointment, but when I accept a invite for an appointment it does not copy. Is there something I need to add or change to be able to copy an invited event. Shawn 69. Alex says Diane, Thank you very much. It`s a very useful code. Did you manage to add update/delete functionality? • Diane Poremsky says No, I haven't gotten it working. I initially tried using the message id, but need to search for it instead. 70. Diane Poremsky says Finally... working code to update the copy when you edit the original. 71. gmichael7 says Hi Diane, Thank you for this code. I've only used Macros a couple of times, so a little daunting, but I really need to get this working. My issue is that I want to go from a secondary Outlook calendar one-way to the default or primary calendar. In the 5th line of your code, I see: Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items This appears to be where it's looking for the 1st appointment, then it looks like this line tells it where to duplicate the appointment: Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Test") I want to go from 'primary@email.com\Calendar\Subcalendar' to 'primary@email.com\Calendar' Can you tell me how to write this in? And if it works, where can I send a donation!? Thanks, • Diane Poremsky says This is the calendar where the appointment is created: Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items Moved to this calendar: Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Test") It looks like you are moving from the same data file or mailbox, so you would use these: Set curCal = NS.GetDefaultFolder(olFolderCalendar).Folders("Subcalendar").Items Set newCalFolder = NS.GetDefaultFolder(olFolderCalendar) if I'm misreading and they are in a non-default data file, you'll use these lines: Set curCal = GetFolderPath("primary@email.com\Calendar\Subcalendar").Items Set newCalFolder = GetFolderPath("primary@email.com\Calendar") (donations are always welcome - paypal address is drcp@cdolive.com) 72. gmichael7 says Thank you very much Diane. I'm going to try this with my client's Outlook 2010, but I tried in my 2007, and when I pull up the macro editor, it starts in VBAProject.otm , and I tried a few different things but got an error related to the 'WithEvents' saying 'Compile Error: Only Valid in Object Module'. I'll try with my client to see if I get something similar. • Diane Poremsky says Most of it needs to be in ThisOutlookSession - the function can be in a module. In fact, I like to use 1 module for functions since they can be used by other macros. WithEvents line and application startup need to be in thisoutlooksession for sure. 73. rharrison75 says This code is great. Thanks for all of the hard work you must have put in. I have one question. What needs to be added so that deleted appointments are also deleted from the secondary calendar? Thanks in advance Richard • Diane Poremsky says You'd use the BeforeDelete event, with pretty much the same code that is used the itemchange event macro. 74. Trent says The first copy code works perfectly for me. Very nice. However, when I put in the "updating" code in to handle changes, it's copying the event to the calendar right away, before the event changes from "tentative" (default Outlook uses) to busy which actually adds a new event. Once I accept it it adds yet another event so I end up with 3 calendar entries. What have I done wrong? • Diane Poremsky says It sounds like its not finding the copy on the second calendar. It should find the copy and change the values. I'll see if i can repro it and figure out where its going wrong. 75. Steve Smith says Hi Diane, this looks like exactly what I need, but I've tried to use this in Outlook 2003, and when I hit "run", it highlights this line : Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder and brings up a dialog saying "Compile error : User-defined type not defined". Can you help? Many thanks, Steve Smith. • Diane Poremsky says Try changing Outlook.Folder to Outlook.MapiFolder - 76. Steve Smith says That's brilliant, thank you. It's solved the problem that I've had for ages of not being able to see my work calendar on my phone. Is there a similar macro that will pick up deletions / changes to events in the main calendar and copy them across? Thanks, Steve. • Diane Poremsky says The item change code sample should pick up changes - I didn't do one for deletions, but yes, it would be possible. 77. Dimitris Bantileskas says Diane: I have inserted your code in my outlook. The code works great when I add appointments but unfortunately it does not when I update appointments. Please see the following code and let me know what needs to be fixed. Thank you in advance. Dim WithEvents newCal As Items Private Sub Application_Startup() Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") Set newCal = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar").Items Set NS = Nothing End Sub Private Sub newCal_ItemAdd(ByVal Item As Object) Dim cAppt As AppointmentItem Dim moveCal As AppointmentItem Set CalFolder = GetFolderPath("dbantileskas@nsllpcpa.com\Calendar\Dimitris Team") If Item.BusyStatus = olBusy Then Set cAppt = Application.CreateItem(olAppointmentItem) With cAppt .Subject = Item.Subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body .Save End With ' set the category after it's moved to force EAS to sync changes Set moveCal = cAppt.Move(CalFolder) 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 Private Sub curCal_ItemChange(ByVal Item As Object) Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem Dim strStart, strSubject As String On Error Resume Next Set newCal = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar").Items strSubject = 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 = Item.Subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body .Save End With End Sub • Diane Poremsky says you changed the macro name to Private Sub newCal_ItemAdd(ByVal Item As Object) - newcal = the new calendar folder. The change macro is using Private Sub curCal_ItemChange(ByVal Item As Object) - it should use newcal too. 78. Dimitris Bantileskas says Diane, I changed the macro name and it worked only for a minute. I can still add appointments but cannot make edits. Below I have the updated code. Please let me know what I'm doing wrong. Thanks. Dim WithEvents newCal As Items Private Sub Application_Startup() Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") Set newCal = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar").Items Set NS = Nothing End Sub Private Sub newCal_ItemAdd(ByVal Item As Object) Dim cAppt As AppointmentItem Dim moveCal As AppointmentItem Set CalFolder = GetFolderPath("dbantileskas@nsllpcpa.com\Calendar\Dimitris Team") If Item.BusyStatus = olBusy Then Set cAppt = Application.CreateItem(olAppointmentItem) With cAppt .Subject = Item.Subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body .Save End With ' set the category after it's moved to force EAS to sync changes Set moveCal = cAppt.Move(CalFolder) 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 Private Sub newCal_ItemChange(ByVal Item As Object) Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem Dim strStart, strSubject As String On Error Resume Next Set newCal = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar").Items strSubject = 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 = Item.Subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body .Save End With End Sub • Diane Poremsky says add an aprosphe in front of on error resume next and see if it errors. In the ItemChange Calendar, you are setting this: Set newCal = GetFolderPath("Public Folders - dianep@outlookmvp.com\All Public Folders\OutlookMVP\Litigation Support - Forensic Accounting Calendar").Items but it is set in the startup folder. You need to use newCalfolder Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Test") Because later, it uses newCalFolder: For Each objAppointment In newCalFolder.Items Also, this is the calendar you are copying appointments to. The original calendar is set in the startup, this entry is the new calendar. You can't use newCal for both the original and new calendars. When you change the names of objects in a macro, you need to make sure all entries are changed and you need to make sure they are unique. • Dimtiris Bantileskas says Diane: I added the apostrophe and changed the newcal to newcalfolder. However, Outlook seems to loop through the macro when I edit an appointment and I have force quit the program. Please see the updated code. Thank you again. Private Sub newCal_ItemChange(ByVal Item As Object) Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem Dim strStart, strSubject As String 'On Error Resume Next Set newCalFolder = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar") strSubject = 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 = Item.Subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body .Save End With End Sub • Diane Poremsky says It loops because you are setting newCal (in the startup macro) to the same folder as newcalfolder in the itemchange macro. This is the original/master calendar:Set newCal = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar").Items This is the copy: Set newCalFolder = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar") 79. Dimitris Bantileskas says Diane: I believe I understand what you mean and I changed the newcalfolder to the calendar I am copying appointments to. However, this time I get an the following error message: Run time error '91': Object Variable or With Block Variable Not Set When I click on debug, the following is highlighted "Subject = Item.Subject" Provided below I have copied the updated code: Private Sub newCal_ItemChange(ByVal Item As Object) Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem Dim strStart, strSubject As String 'On Error Resume Next Set newCalFolder = GetFolderPath("dbantileskas@nsllpcpa.com\Calendar\Dimitris Team") strSubject = 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 = Item.Subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body .Save End With End Sub Thank you again. • Diane Poremsky says 91 means there is a coding error - the syntax is wrong somewhere. It could mean the "Item" (the appointment you're editing) wasn't detected. But that makes no sense unless you edited the startup macro. 80. Andreas says Hey Diane, first of all thanks for this amazing work. It works lika a charm with all of my edits, but I do have one problem: I need to start the macro by hand, it does not start automatically. Trust Center is at no security. Any idea? • Diane Poremsky says This macro: Private Sub Application_Startup() should start it when Outlook is started. Do you get any error messages when outlook starts? Add this line: msgbox "Startup called" as the last line of the startup macro then restart Outlook. A box should come up telling you the macro started. 81. Andreas says No error messages at startup, no msgbox either. I'll go and asked my admninistrator if there is any restriction to start a macro at startup of outlook in our network. If not, I'll check back, thanks for your help! • Diane Poremsky says If macro security is set to none and the VB Editor opens, it *should* work. 82. John says Hi Diane, Thank you for this script. It works wonderfully with one small exception I'm hoping you can help me with. When I add an appointment manually from the outlook calendar this macro works with no issues. However, I have a small console application written in C# that I use to programmatically create the appointment and also fills out the subject and location fields. My problem is that when I use the console app the appointment never gets copied to the public calendar as it would if I created the appointment manually. Any thoughts on how I could get around this? • Diane Poremsky says Offhand, no, I don't know what you could do to trigger it - it's an itemadd macro, so it should pick up anything that is added to the calendar. One option is to run a macro every so often that checks the public calendar for a match and create one if a match does not exist. You'd use something like this snippet - and could trigger it with a reminder. For Each objAppointment In newCalFolder.Items If objAppointment.Subject = strSubject And objAppointment.Start = strStart Then else Set cAppt = Application.CreateItem(olAppointmentItem) With cAppt .Subject = 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 Next 83. Dimitris Bantileskas says Diane: I decided to start from the beginning again and copied your itemadd and itemchange codes into my Outlook. The only changes I made were in setting curCal and NewCalFolder. Provided below I have summarized my changes: Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items changed to Set curCal = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar").Items and Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Test") changed to Set newCalFolder = GetFolderPath(""dbantileskas@nsllpcpa.com\Calendar\Dimitris Team") As you know the code works perfectly when I add an appointment. However, now I receive the following error message when I update an appointment: "Run-time error '91': Object variable or with block variable not set" When I click on the Debug button the following code line if highlighted: "For Each objAppointment In newCalFolder.Items" I am looking forward to your help. For your reference, I have copied the entire updated code as follows: Dim WithEvents curCal As Items Private Sub Application_Startup() Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") Set curCal = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar").Items 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 Set newCalFolder = GetFolderPath(""dbantileskas@nsllpcpa.com\Calendar\Dimitris Team") 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 Private Sub curCal_ItemChange(ByVal Item As Object) Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem Dim strStart, strSubject As String ‘On Error Resume Next Set newCalFolder = GetFolderPath("dbantileskas@nsllpcpa.com\Calendar\Dimitris Team ") 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 Thank you again, Dimitris • Diane Poremsky says Typo, two double quotes: Set newCalFolder = GetFolderPath(""dbantileskas@nsllpcpa.com\Calendar\Dimitris Team") 84. Andreas says I checked with our administrators and I was missing a permission, network wise, to start vba at outlook startup. Now everything works like it should. Thanks again! 85. Dimitris Bantileskas says Diane, I checked and fixed the typo errors. Unfortunately I receive the same error message. Please advise. Thanks. • Diane Poremsky says That error says an object does not exist - try adding Dim newCalFolder As Outlook.Folder to the macro. 86. Dimitris Bantileskas says Diane: I feel sorry but unfortunately I still receive the same error message. I don't understanf why Outlook says that an object doesn't exist since the ItemAdd macro is adding the appointment with no problem. Thank you again. • Diane Poremsky says it's not saying the appointment doesn't exist, its saying the object that it uses to access the appointment doesn't exist. Did you add the dim line to the top of the change macro? Dim newCalFolder As Outlook.Folder - that fixed it here. I think i was testing it by creating the appointment then editing it immediately so the object existed in memory, but the object doesn't exist when I go back later to edit it. 87. Dimitris Bantileskas says Diane, I added the dim line as you suggested but I still receive the same error message. Please see the entire code included itemadd and item change: Dim WithEvents curCal As Items Private Sub Application_Startup() Dim NS As Outlook.NameSpace Set NS = Application.GetNamespace("MAPI") Set curCal = GetFolderPath("Public Folders - dbantileskas@nsllpcpa.com\All Public Folders\Litigation Support - Forensic Accounting Calendar").Items 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 Set newCalFolder = GetFolderPath("dbantileskas@nsllpcpa.com\Calendar\Dimitris Team") If Item.BusyStatus = olBusy Then Set cAppt = Application.CreateItem(olAppointmentItem) With cAppt .Subject = 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 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 Set newCalFolder = GetFolderPath("dbantileskas@nsllpcpa.com\Calendar\Dimitris Team") strSubject = 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 = Item.Subject .Start = Item.Start .Duration = Item.Duration .Location = Item.Location .Body = Item.Body .Save End With End Sub • Diane Poremsky says It works here - http://www.screencast.com/t/TjqTOBZ94bUQ (using your code, with the mailbox named changed to my test mailbox) - but keep in mind you can't edit the subject and time or outlook won't be able to find it because this line looks for a match in those two fields: If objAppointment.Subject = strSubject And objAppointment.Start = strStart Then if you need to be able to change those fields, you'll have to add a GUID or code to the appointment body then search on it. 88. Dimitris Bantileskas says Diane, thank you so much for your help. You have been generous and kind with me. The video was amazing from which I realized that my code was not operational as I was making edits on the subject. I added the GUID codes add it finally worked. Thank you • Diane Poremsky says I totally forgot about it not working if the subject is changed, until i went to record the video and changed a subject and it failed. I wish I had remembered it sooner. 89. Dave Woyciesjes says Diane --- Thanks for the code. Through trial, error, and searching; I was able to modify this code so when I create an event with a specified category (Personal), it will copy to another calendar folder on my Exchange account. I also added the code to make updates for location & other info copy over. What I'm trying to figure out (with no formal VBA training, just basic scripting knowledge) is how to add code so that when I open an uncategorized event, then set it to the Personal category - it will then copy to the second calendar... • Diane Poremsky says You need to use a change or an open event. If you want to change all uncategorized appt to personal, use an open even to check the category and change it. if you only want to check the category on save, use a item change event. Sample code to detect changes is included in this article. 90. David Moore says everyone should try CodeTwo Sync for iCloud. its$20 but works wonderfully.

91. Dave Woyciesjes says

What I did so far, was to copy the code from the ItemAdd sub, and paste in to the ItemChange routine. Of course, with just that; anytime the item on the main calendar is changed, a new event is created on the second.
What I need to figure out, is how to get an "if does not exist" type of condition (in addition to the item copy code) stuck in the ItemChange sub.

• Diane Poremsky says

you'll need to do something like this -
If instr(objAppointment.categories,"Personal") > 0 Then
exit sub
else
' do whatever

end if

92. Lauren says

Hi Diane, I am very new to VBA, and am having difficulty incorporating your code into outlook. I am trying to copy calendar items from a shared public calendar to my personal default calendar, both within MS outlook. I also tried to incorporate your modifications to eliminate the If/Then "Busy" status criteria, and allow for the updated calendar item to be changed on my calendar, using the GUID code. When I try to run it, nothing seems to happen. I do not get any error messages. Surgery\Vascular\VASC Research is the public calendar where the events will originate from. The destination calendar is the default for lmharvey@ufl.edu.

Lauren

Dim WithEvents curCal As Items

Private Sub Application_Startup()
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
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
Set newCalFolder = GetFolderPath("Surgery\Vascular\VASC Research")

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

Item.Body = Item.Body & "[" & GetGUID & "]"
Item.Save
Set cAppt = Application.CreateItem(olAppointmentItem)

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

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
Set newCalFolder = GetFolderPath("Surgery\Vascular\VASC Research")

' 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

Public Function GetGUID() As String
GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36) End Function • Diane Poremsky says You have the calendars switched - this: Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items is the original calendar and if i read your comment correctly, its the shared calendar. This is the copy to calendar: Set newCalFolder = GetFolderPath("Surgery\Vascular\VASC Research"). Switch the two folders and it should work. Set curCal = GetFolderPath("Surgery\Vascular\VASC Research").Items Set newCalFolder = NS.GetDefaultFolder(olFolderCalendar) You'll need to move Dim NS As Outlook.NameSpace & Set NS = Application.GetNamespace("MAPI") to the itemadd macro. Also move Set NS = Nothing to the end of the item add macro. • Lauren says I made the recommended changes, but keep getting a 91 error. Is there some other problem I am missing? Dim WithEvents curCal As Items Private Sub Application_Startup() Set curCal = GetFolderPath("Surgery\Vascular\VASC Research").Items End Sub Public Function GetGUID() As String GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function

Private Sub curCal_ItemAdd(ByVal Item As Object)
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
Dim cAppt As AppointmentItem
Dim moveCal As AppointmentItem
Dim newCalFolder As Outlook.Folder
' On Error Resume Next
Set newCalFolder = NS.GetDefaultFolder(olFolderCalendar)
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
Item.Body = Item.Body & "[" & GetGUID & "]"
Item.Save
Set cAppt = Application.CreateItem(olAppointmentItem)
Set NS = Nothing
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
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
Set newCalFolder = NS.GetDefaultFolder(olFolderCalendar)
' 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

• Diane Poremsky says

The only time I could generate that error when I tested your code with my folder names was when I mistyped a folder name. Does the mailbox show up in your folder list with the name "Surgery"?

• Lauren says

HI Diane,

I was able to track down the complete folder/path name for the initial calendar. The code is working for the most part. It creates the GUID, and copies the full event over to my default calendar. I cannot get it to update though. I was hoping to do this with only the GUID, and not use the Busy status. What are you thoughts?

Dim WithEvents curCal As Items
Private Sub Application_Startup()
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
Set curCal = GetFolderPath("\\Public Folders - lmharvey@ufl.edu\All Public Folders\Surgery\Vascular\VASC Research").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
Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Test")
Item.Body = Item.Body & Chr(13) & Chr(10) & "[" & GetGUID & "]"
Item.Save
Set cAppt = Application.CreateItem(olAppointmentItem)
With cAppt
.Subject = 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 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

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
Set newCalFolder = NS.GetDefaultFolder(olFolderCalendar)
' 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 = Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
.Save
End With
End Sub

Public Function GetGUID() As String
GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36) End Function • Diane Poremsky says Using the GUID should work. I'll see if i can repro it. Oh. Is this the parent calendar? This is the calendar you're watching for new items: Set curCal = GetFolderPath("\\Public Folders - lmharvey@ufl.edu\All Public Folders\Surgery\Vascular\VASC Research").Items The initial copy calendar is Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Test") And the changed calendar is Set newCalFolder = NS.GetDefaultFolder(olFolderCalendar) The copy/change calendar need to be the same calendar 93. Lauren says Now I am getting a "91" error. Did I place Set NS = Nothing in the wrong location? Dim WithEvents curCal As Items Private Sub Application_Startup() Set curCal = GetFolderPath("Surgery\Vascular\VASC Research").Items End Sub Private Sub curCal_ItemAdd(ByVal Item As Object) Set NS = Application.GetNamespace("MAPI") Dim cAppt As AppointmentItem Dim moveCal As AppointmentItem Dim newCalFolder As Folder Dim NS As Outlook.NameSpace ' On Error Resume Next Set newCalFolder = NS.GetDefaultFolder(olFolderCalendar) 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 Item.Body = Item.Body & "[" & GetGUID & "]" Item.Save Set cAppt = Application.CreateItem(olAppointmentItem) Set NS = Nothing 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 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 Set newCalFolder = NS.GetDefaultFolder(olFolderCalendar) ' 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 Public Function GetGUID() As String GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function

• Diane Poremsky says

NS = nothing should be right before the end sub line, but where its at shouldn't cause the error. It looks ok, but I'll check it out better in the morning.

• shawn says

Thank you, that is what I suspected since I have never had a problem before. To answer your question, the IMAP is my work email as we do not have an exchange server. I use the outlook so I have a mobile current calendar. I send out multiple calendar invites from the IMAP (work) account and do not want the outlook email is were my appointments are coming from. unlike email, I cannot choose which account to send from. I can drag it over to the outlook calendar, the automatic copy was very handy.
Shawn

• Diane Poremsky says

Did you create an outlook.com email address? Try using your work address as a microsoft account - in my tests a few days ago, the meetings were sent using my address (used as a microsoft account), not a guid@hotmail address.

94. Alex says

Hello Diane,
I am trying to just have appointments that are sent to outlook from my excel pop up tool go to the shared calendar and appointments that are created on outlook go to a personal calendar. I have an if then statement but it works backwards and I cannot reverse it. Any help would be greatly appreciated.

Private Sub newCal_ItemAdd(ByVal Item As Object)

If AppointmentItem = "" Then

Set calfolder = GetFolderPath("\\Ops.Svc.Shared.Calendar@cfins.com\Calendar")
Item.Move calfolder

Else

Set calfolder = GetFolderPath("mapi")
Item.Move calfolder

End If

End Sub

95. shawn.hippen@jcep.info says

Diane,

I have used this in the past with great success, I just got a new computer and have set up my email in IMAP, I cannot make this work now. does something need to change being it is an IMAP? please advise...
Thanx
Shawn

• Diane Poremsky says

No, it should work - you just need two calendars. Do you get any error messages?

96. shawn says

Thank you,
I too have the error in the ( If Item.BusyStatus = olBusy Then ) line, This worked on my W8, 2013 computer not using IMAP, this new work computer is W7, 2013. Here is the error code and the code I have installed.
Thank you Shawn
Run-time error '2147221233 (8004010f)':

Dim WithEvents curCal As Items

Private Sub Application_Startup()
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
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
Set newCalFolder = GetFolderPath("t.s.hippen@outlook.com\Calendar")

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

• Diane Poremsky says

You are copying from an imap calendar to outlook.com? The code looks good, the error often means a permissions issue but that shouldn't be a problem here.

• shawn says

Yes thank you. It is a pop account running in IMAP settings. It will error and copy the event. Then I have to shut down outlook and restart to copy again. Where would I dig for checking permissions? I am the admin on this computer. Thank you again.
Shawn

• Diane Poremsky says

Permissions wouldn't be a problem with non-Microsoft accounts. I'll see if i can repro with the same account set up.

• Diane Poremsky says

Looks like its because its an imap calendar. Start and other fields fail too.

Is there a reason you are copying from imap to an Outlook.com calendar? I usually recommend setting the Outlook.com data file as the default data file then deleting the imap ost and letting outlook recreate it without the special folders. Just make sure you move the calendar, contacts, and tasks out before deleting it.

Diane,
I appreciate all the work you do to help us out here but I have tried the steps above and it almost works. It seems that it continually copies the same event from my local calendar to my outlook.com calendar. I'm using Outlook 2013. Any ideas what could be wrong?

• Diane Poremsky says

It sounds like it's reusing the same appointment. I'm not sure why it would do that.... I'll see if i can repro.

• Diane Poremsky says

I can't repro problems - I don't know if this will help - but the macro in this file create and change an events on a second calendar sets the calendar you are watching and the target calendar in the start up macro so you only have one place to edit. I know some people had problems getting the calendar paths correct and maybe it will help. I'm not sure that is your problem though.

98. Jakob Jørgensen says

Thank you for providing this tool. I am also experiencing the issue that multiple copies are added to the second calendar, one new copy on each send/receive. I am trying to copy from an internet calendar (imported into outlook by "subscription" from google calendar) into my main outlook calendar in Outlook 2010. I am using the code you provide in the text file, with calendar paths changed, and I also tried to comment out the "updating" part, as in the comment by Trent above, but I still get multiple copies.

Also, it seems that all-day events are not copied, including all-day events spanning multiple days. Events spanning multiple days, with specified start and end time, on the hand, are indeed copied.

Thanks,
Jakob

• Diane Poremsky says

This line: If Item.BusyStatus = olBusy Then is basically telling it to skip all day events as most all day events are not marked busy. you can remove that line and the last end if, if you want to copy all.

Duplicates usually happen when the copy to calendar is the same as the original - a copy is added to the calendar, and the copy is copied (because outlook sees it as new), and so on. I'll test it once again and see if i can repro duplicates.

• Jakob Jørgensen says

Is there a way to copy only events today or later, but not ones in the past? I am still having the problem that multiple instances of events are created, and with a long history of past events, this quickly turns into thousands of events, which take more than a few minutes to handle deletion and get rid of reminders. With only future events, this number would be much smaller. Thanks, Jakob

• Diane Poremsky says

Yes, you can add a filter to start today. Use this for appointments created for today or later.
If Item.BusyStatus = olBusy And Item.Start >= Date Then

You can also use
If Item.BusyStatus = olBusy And left(item.subject,6) <> "Copied" Then

to skip any that have copied in the subject.

• Jakob Jørgensen says

Great, Item.Start >= Date does the trick. Thank you!

I don't understand the second part with "Copied". I am copying from an internet calender with event names without "copied" in them to an outlook calendar and adding "Copied" to the created events in outlook. So I don't need to skip any with "Copied" in subject, since there are none. Or did I misunderstand your suggestion?

• Diane Poremsky says

No, I may have misunderstood your problem. If outlook repeatedly copies them in the one calendar and you end up with "Copied: Copied: Copied: real subject" you'd check the subject and stop if copied is there already.

• Jakob Jørgensen says

OK, I see your point for that case. What happens for me is different. Identical copies are created in outlook, ie even though the event "Copied: real subject" is already there, a new instance of the same event "Copied: real subject" is created on the next sync, for example when starting outlook, and so it continues with an arbitrarily large number of copies of identical events (each with a single "Copied") until I close outlook again or switch off macros.

My workaround is to use outlook with macros switched off normally, and then every now and then do a sync by deleting all events in the outlook calendar with "Copied" in the subject, followed by restarting outlook with macros enabled to let your macro copy all events from the internet calendar to the outlook calendar, and finally restart outlook again (if I need to use it) with macros disabled. But I would be very happy with a simpler solution without duplicated events. Jakob

• Diane Poremsky says

Ah, ok. What is the source calendar?

One way to stop duplicates (or triplicates, which sometimes occur with Exchange accounts in cached mode) is to assign a category to the original then only create items if that category is not assigned.

You could also search for matches and only create it if the match doesn't exist (using the code from the update calendar). I'm not sure how that would work with a large calendar though - it might slow outlook down during the initial sync. If a match is found, you'd exit the macro and move on to the next appt.

• Jakob Jørgensen says

The source calendar is a google calendar that I am having 1-way synced into a calendar in outlook. What I use your code for is to copy events from that calendar into my main outlook calendar, that I share with others. I want to only add and edit events in my google calendar, while automatically syncing to my outlook calendar.

• Diane Poremsky says

Ah. Yeah, subscribed calendars are difficult. I'm either getting multiple copies or nothing. I recommend using a sync utility like companionlink nstead - you'll be able to add and edit events in outlook and sync to google calendar.

99. Jakob Jørgensen says

Thank you. Removing the line of BusyStatus seems to do the trick.

I'm also hoping that you will be able to reproduce and solve the duplicate problem. Please let me know, if you have any questions about my setup.

100. Sebastian says

Hi Diane,

I am really impressed by the effort you have already put into putting this together!

Unfortunately, the code does not seem to work for me, nothing happens when running the macro (no errors, but also no copying of the calendar entry).

I have linked an internet calendar from my school's intranet (using BlackBoard) using an iCal URL in Outlook.
I pasted the code from the .txt file you provided and updated the folder paths. I already tried applying the changes you proposed to Isaac and Jakob, but still nothing happens.

Do you have an idea what could cause the problem?

Thanks,
Sebastian

• Diane Poremsky says

The internet calendar is probably the problem. I'll have to test it to see if the code can look for changes there (so it could be a source calendar) - it is read only so it can't be the calendar you copy to.

101. Daniel Schunk says

Hello Diane,

I'm in trouble with allday events. If I create a new allday event in my calendar, it will not be copied in the other calendar.

Then, I added a line ".AllDayEvent = True" into the "With cAppt" clause. But now, every copied appointment item is an allday event.

Do you have a hint for me?

Regards, Daniel

• Diane Poremsky says

You need to do something like .alldayevent = oAppt.alldayevent

102. Trent says

Hi Diane. Very helpful and working for us, except when a recurring event is created. Even if we create the calendar entry on our own calendar, when there is a recurrence, it doesn't copy it over to the real calendar. Any thoughts?
Thanks

• Diane Poremsky says

The code needs updated to check for recurrence and copy the recurrence settings. It might not copy exceptions (well, at least not without a lot of code) - but its a fairly simple change. I'll try to update it tonight.

• Trent says

Hi Diane. Have you had any chance to look at being able to copy meetings with recurrences? Thanks. Trent

• Diane Poremsky says

I looked but haven't had a lot of free time to fine tune it (aka make it work correctly).

• mdkarp says

This is fantastic code. Thank you so much. I wanted to see if you ever got recurring appointments to copy - most of the appointments on the calendar I'd like to copy are recurring unfortunately.

• Diane Poremsky says

Try this after the end with and before the lines that move the appt to the new calendar. i did a quickie test on it and it worked. It will be more complicated to recurrences that have exceptions - so while you can use this with the new and changed macros, it's not going to handle exceptions.

if item.IsRecurring Then
Dim itemPattern As RecurrencePattern
Dim cApptPattern As RecurrencePattern

Set itemPattern = item.GetRecurrencePattern
Set cApptPattern = cAppt.GetRecurrencePattern

With cApptPattern
.RecurrenceType = itemPattern.RecurrenceType
.Occurrences = itemPattern.Occurrences
.Duration = itemPattern .Duration
.PatternStartDate = itemPattern.PatternStartDate
.StartTime = itemPattern.StartTime
.EndTime = itemPattern.EndTime
End With
end if

103. Seb says

Hi Diane,

appreciate your effort! I have a question. The macro seems to work fine if I keep the "Copied:" text before the appointments. However, when I remove this prefix, the appointments don't update anymore. Do you have an idea why this is the case? I am using my default outlook calendar and iCloud.

Please find below the code I used:
Thanks!
Seb

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("iCloud\Calendar")

Set cAppt = Application.CreateItem(olAppointmentItem)

With cAppt
.Subject = 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

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("iCloud\Calendar")

strSubject = 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 = Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
.Save
End With

End Sub

• Diane Poremsky says

it's looking for the subject and start time - If objAppointment.Subject = strSubject And objAppointment.Start = strStart Then - and should work without adding copy. Is it making a duplicate when you have copied in the subject?

• Seb says

Hi Diane,
thanks for your reply. The calendar entries are duplicating initially. The only thing that is not working is the updates of existing entries. I.e. if I change the subject or time of a Test entry in the default calendar, the duplicate stays as it was...

• Seb2 says

Hi Diane,
it does initially create the duplicate in the second calendar, but the new entries are not updated using the code above

Furthermore, I would also like the macro to work both ways, i.e. I want both calendars to be exact copies of each other. Is this possible using your code?

Thanks again,
Sebastian

• Diane Poremsky says

Working both ways is probably well above my pay grade (aka skills) but I will see if i can figure out why its not updating. (I'll also look at either side updating the other - it might be easier than I think.)

104. Dana Stodgel (@DanaStodgel) says

Diane: Thank you so much for your efforts on this! I think your page was one of the first search results I found that was thorough and got me 99% of the way there. Here is my code I am happy with and testing for myself before sharing with co-workers. I modified it to handle deleting appointments using BeforeItemMove as well as putting a warning message about the GUIDs to help keep things in sync. That meant adjusting the method of checking strbody's value, but it is still pretty simple. You'll notice I left a few of my debugging MsgBox lines in there, but they are commented out. Again, thanks!

Dana

Dim WithEvents curCalendar As Outlook.Folder
Dim WithEvents curCalendarItems As Outlook.Items
Dim newCalFolder As Outlook.Folder
Dim WithEvents objDelFolder As Outlook.Folder

Private Sub Application_Startup()
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")

' default calendar
Set curCalendar = Outlook.Session.GetDefaultFolder(olFolderCalendar)
Set curCalendarItems = curCalendar.Items

'calendar you are copying to
Set newCalFolder = GetFolderPath("YOUR SECONDARY ACCOUNT\Calendar")
Set NS = Nothing

'deleted items folder
Set objDelFolder = Application.Session.GetDefaultFolder(olFolderDeletedItems)

End Sub

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

If Item.BusyStatus = olBusy Then
Item.Body = Item.Body & vbNewLine & vbNewLine & vbNewLine & "DO NOT DELETE GUID below to maintain calendar sync." & vbNewLine & "[" & GetGUID & "]"
Item.Save

Set cAppt = Application.CreateItem(olAppointmentItem)

Set cAppt = Application.CreateItem(olAppointmentItem)

With cAppt
.Subject = "Sync: " & Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
.ReminderSet = False
End With

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

End If
End Sub

Private Sub curCalendarItems_ItemChange(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim objAppointment As AppointmentItem
Dim strStart, strSubject As String

On Error Resume Next

strSubject = "Sync: " & Item.Subject
strStart = Item.Start

' find the left bracket and then use 2 + the length of the GUID
'strbody = Right(Item.Body, 38)
strbody = Mid(Item.Body, InStr(Item.Body, "["), 38)

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

For Each objAppointment In newCalFolder.Items
If objAppointment.Subject = strSubject And objAppointment.Start = strStart Then
Set cAppt = objAppointment
End If
Next

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

End Sub

Private Sub curCalendar_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)
Dim cAppt As AppointmentItem
Dim objAppointment As AppointmentItem
Dim strStart, strSubject As String

On Error Resume Next

'MsgBox "BeforeItemMove sub"

For Each objAppointment In newCalFolder.Items
If MoveTo Is Nothing Then
'Debug.Print Item.Subject & " was hard deleted"
'MsgBox "Hard deleted."
strSubject = "Sync: " & Item.Subject
strStart = Item.Start

' find the left bracket and then use 2 + the length of the GUID
strbody = Mid(Item.Body, InStr(Item.Body, "["), 38)

If InStr(1, objAppointment.Body, strbody) Then
Set cAppt = objAppointment

ElseIf objAppointment.Subject = strSubject And objAppointment.Start = strStart Then
Set cAppt = objAppointment
End If

With cAppt
.Subject = "Cancelled: " & Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
.BusyStatus = olFree
.Save

.Delete
End With

ElseIf MoveTo = objDelFolder Then
'MsgBox "Moved to deleted folder."
strSubject = "Sync: " & Item.Subject
strStart = Item.Start

' find the left bracket and then use 2 + the length of the GUID
strbody = Mid(Item.Body, InStr(Item.Body, "["), 38)

'MsgBox strbody

If InStr(1, objAppointment.Body, strbody) Then
Set cAppt = objAppointment

ElseIf objAppointment.Subject = strSubject And objAppointment.Start = strStart Then
Set cAppt = objAppointment
End If

With cAppt
.Subject = "Cancelled: " & Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
.BusyStatus = olFree
.Save

.Delete
End With
End If

Next

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

Public Function GetGUID() As String
GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36) End Function 105. darqp says Hi Dana, I'm using your script but always when I create a new appointment i receive the meesage Run-time error "-2147221233(8004010f)" Message can't be find and it copy to second calendar. Could you help me? • Diane Poremsky says What type of email account or data file does the second calendar belong to? You can't copy imap calendars. 106. Paul says Hello, is it possible to use this macro to copy an internet calendar (iCal) to Outlook Exchange? Thanks a lot Paul • Diane Poremsky says I have not tested it with an ics, but as long as its the one you are copying from, it should work. 107. Adrian Hernandez says I want to copy items from my work calendar (Exchange) to my Hotmail calendar (accessed in Outlook as an ICAL calendar). The issue is that ICAL calendars are read-only, so I get errors when the new appointments are saved. New appointments do appear in the Hotmail calendar, but are not being synced back to the actual cloud Hotmail calendar. I tried using the option to share my Hotmail calendar with people (you enter the e-mail address). I then get an e-mail from Oulook.com (I.E. Hotmail) to accept/decline, I open the link but it always tells me that the invitation expired and is no longer valid. Any suggestions? • Diane Poremsky says What version of Outlook? Can you add the Hotmail account to Outlook as an account? Many companies won't allow it, but if you can, you'll have a read/write calendar - otherwise you're pretty much out of luck and will need to invite your Hotmail address to the appointment to add it to the calendar. 108. Daniel Schunk says Hi Diane, copying an appointment item works „soundless“. Is there a possibility to get a messagebox which says „Do you want to copy the date in the calendar? [yes] [no]“? Regards, Daniel • Diane Poremsky says That is actually fairly easy - replace the 'If busystatus' line with this: Dim intRes As Integer Dim Msg As String Msg = "Do you want to copy the appointment to " & newCalFolder.Parent.Name & " Calendar?" If Item.BusyStatus = olBusy Then intRes = MsgBox(Msg, vbYesNo + vbExclamation, "Confirm Copy") If intRes = vbNo Then Exit Sub End If 109. Adrian Hernandez says Hello, My computer was upgraded to Outlook 2013, now I can see my Hotmail account w/o having to use ICS (horray). Code works great. Only thing that I miss is being able to delete the original appointment and then have code aut. delete the copy. Any ideas? PS : • Diane Poremsky says I will see if i can do it - I can't remember if i tried deleting before. 110. Adrian Hernandez says Hi Diane, I noticed that meetings that are set for All Day, are not being copied. Any ideas as to why? • Diane Poremsky says This line: If Item.BusyStatus = olBusy Then has the effect of filtering out all day events (because they aren't marked busy). Remove that line and the matching End if to copy all appointments. 111. Adrian Hernandez says Diane, I managed to get some code to work for Deleting. Here's the code : Private Sub curCal_ItemRemove() Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem Dim strStart, strSubject As String 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 cAppt.Delete End If Next MsgBox "Trying to delete..." & Item End Sub • Diane Poremsky says Cool. I couldn't get itemremove to work - but I was using the subject find method to find it. I hadn't yet switched to using the GUID. I should update all of the code to use GUID by default. 112. Adrian Hernandez says Ok, finaly question. Now that I have 2 calendar on my Outlook account, is there a way I can set Outlook to not use the reminders of the my Hotmail Calendar (the one I am copying to)? I now get 2 alerts for every meeting, the original, and the one copied to the Hotmail calendar. It's a bit annoying. I would like to leave the alerts so if I am away from my computer for an extended time, my Hotmail calendar on my phone will alert me, but, would like to suppress the alerts on the computer. • Diane Poremsky says You can use code to not set a reminder on the copies, but Hotmail sets one for you (or it used to) and you can't suppress reminders in one calendar folder. Actually, maybe the solution is to not set reminders on the original in the local pst and only use Hotmail reminders... we can do this using vba if the default calendar reminder options prevents the Hotmail reminders. 113. Adrian Hernandez says I noticed that meetings that last all day and have recurrence are only being copied once w/o a recurrence. Weird thing is that when you open the copied meeting, it appears with the recurrence correctly set, but, when you go to the future you don't see the copied item. Any ideas as to why that happens? • Diane Poremsky says it's because the copy is just creating a new appointment, not copying the existing one. I'll update the code to handle it better. 114. Nate S says Thanks for the article. This was a great help. This was my first VBA code, so I needed the help getting started. After some tweaking I got this working the way I wanted. Big changes are: 1. Allow edits to the body - with the original code if you append something to the end of the body (after the guid) you lose the link. So I stored the ID in the Mileage field (just picked a free form string that I am not using). 2. With a large calendar (lots of items) looking through each item to find the item is very slow - causing a lot of lag when editing calendar items. So instead of storing a GUID in the appt item, I store the copy's EntryID in the original item's Mileage field. Then find the original item using GetItemFromID(). This is a lot faster. 3. I couldn't get Adrian's approach to deleting to work consistently. ItemRemove() doesn't give you the item that is being removed. So instead I catch the ItemAdd() on the trashfolder and see if I can find the item being added. It doesn't work if you Shift-Delete. Thanks a lot to everyone who contributed to this thread. Dim WithEvents curCal As Items Dim newCalFolder As Outlook.Folder Dim WithEvents trashFolder 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 ' trashfolder to watch for deleted items Set trashFolder = NS.GetDefaultFolder(olFolderDeletedItems).Items ' calendar moving copy to Set newCalFolder = GetFolderPath("\\destcal\cal") Set NS = Nothing End Sub Private Sub curCal_ItemAdd(ByVal Item As Object) Dim cAppt As AppointmentItem Dim moveCal As AppointmentItem 'remove to make a copy of all items 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 Item.Mileage = moveCal.EntryID Item.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 If IsNull(Item) Or IsEmpty(Item) Then Exit Sub If IsEmpty(Item.Mileage) Or Item.Mileage = "" Then Exit Sub Set cAppt = Application.GetNamespace("MAPI").GetItemFromID(Item.Mileage) If IsNull(cAppt) Or IsEmpty(cAppt) Then Exit Sub 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 trashFolder_ItemAdd(ByVal Item As Object) ' watch for deleted items Dim cAppt As AppointmentItem On Error Resume Next If IsNull(Item) Or IsEmpty(Item) Then Exit Sub If IsEmpty(Item.Mileage) Or Item.Mileage = "" Then Exit Sub Set cAppt = Application.GetNamespace("MAPI").GetItemFromID(Item.Mileage) If IsNull(cAppt) Or IsEmpty(cAppt) Then Exit Sub If cAppt.Categories "moved" Then Exit Sub cAppt.Delete 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 115. daniel says Hi Diane, When I remove the busy status if/then and change "Copied" in the subject line to "Work", the edit and delete functions no longer work. Have you or other experienced this? If so, is there a solution? Thanks for all of your hard work! • Diane Poremsky says Are you using the GUID in the body? If you are using older code (that I originally published), it searches for the "copy: subject" in the second calendar and you need to change it in the update and delete code too. The GUID code is better - it just looks for the guid in the body. 116. Bruce says Hi Diane, Thanks, your code works really well between my exchange calendars but i would also like to synchronize (one way) to SharePoint calendar. I have the calendar linked to my outlook. Is this going to be possible? • Diane Poremsky says As long as the calendar is open in Outlook, you can do it. You'd use the path in this line: Set newCalFolder = GetFolderPath("data-file-name\calendar") if you want to copy to this calendar and another one, you would set two folders (using bewCalfolder2 as the object) and repeat the lines that create the new appointment on the second calendar. It will be more difficult ot check both calendars when you update or delete but is possible. 117. Mats Eriksson says Hello Diane, Your code works like a charm one-way but I want to set up two-way syncing but have problems with the event sink for the iCloud calendar. For outlook I use (as per your code): Set outlookCal = NS.GetDefaultFolder(olFolderCalendar).Items and for iCloud: Set iCloudCal = Session.GetDefaultFolder(olFolderCalendar).Parent.Folders("iCloud").Items This is as per your instructions here "Working with VBA and non-default Outlook Folders" but it doesn't work with iCloud. The ICloud calendar folder looks like: Set iCloudCalFolder = GetFolderPath("iCloud\Calendar") and works when copying to iCloud. Any thoughts? /Mats PS Thank you for the effort you have put into this! • Diane Poremsky says Where is the folder this references? Set iCloudCal = Session.GetDefaultFolder(olFolderCalendar).Parent.Folders("iCloud").Items This is telling the macro it's in the default data file at the same level as the Inbox & default Calendar. This is the correct path for iCloud calendars: Set iCloudCalFolder = GetFolderPath("iCloud\Calendar") you'd use this if you are syncing between iCloud and the default calendar. If you are syncing the iCloud items back to a folder called iCloud then the line you are trying to use would work. 118. Mats Eriksson says Exactly! That is why it's not working. I need to back up to the parent and then "step down one step" to iCloud so to speak. With the Debug Watch I can see a path for the set statement that VBA will accept e.g. Set iCloudCal = NS.GetDefaultFolder(olFolderCalendar).Parent.Session.Folders("iCloud").Items but the event doesn't fire with this construction. The iCloud folder is at the default location. Thx for quick response • Diane Poremsky says if you are copying FROM iCloud, you'd use Set iCloudCal = GetFolderPath("iCloud\Calendar").items 119. Mats Eriksson says It compiles and runs but the event doesn't fire :( • Diane Poremsky says Add msgbox "Macro triggered" to the top of the macro - this will fire if the macro is called. if it doesn't run than the action is not triggering the macro. 120. Mats Eriksson says I always use debug breakpoints to track what is happening in my code and it is clear that nothing happens in this case. Nevertheless I tried with the msgbox "Event fired" and there was no message. • Diane Poremsky says This is to sync new iCloud items back to the outlook calendar? I'm guessing the macro is not able to detect new items in that folder. 121. Mats Eriksson says Indeed that's the purpose. Your code was extremely simple to set up for syncing PC->iCloud calendar, too bad if it doesn't work the other way :( Thank you for your tenacity with my problem and all others too here. 122. Christian says Hi Diane, thanks for publishing your code snippets. I've used and modified your code to just copy new items from one (shared) calendar to another shared calendar. It works in my development environment, but I get an runtime error when trying to implement it in my customer’s outlook environment. The error is caused by Set newCalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar) The goal would be to copy appointments from one exchange account default calendar to another exchange account default calendar. The user is, of course, able to access and edit appointments in the calendars by Outlook. However I get the runtime error: -2147221219 (8004011d). “The operation failed because of a registry or installation problem. Restart Outlook and try again. If the problem persists, reinstall.” Do you have a clue what the problem might be? Maybe something is missing? Any help will be appreciated! Thanks! • Christian says I've finally resolved the error. It was an issue with the Outlook profile. Thus, I've created a new Outlook profile (Control Center -> Mail -> Show profiles) and added every account like in the old one. After that, the script is working without any issues! Hopefully my comment helps anybody out there. • Diane Poremsky says thanks for the update. I should learn to read newer comments first when i work on a page. :) • Diane Poremsky says offhand, i have no idea what is wrong... is the mailbox the calendar is in in the profile or is just the calendar opened? if the mailbox is in the profile, try using the getfolderpath method. (you'll need the getfolderpath function too). Set newCalFolder = GetFolderPath("display name\calendar") • Christian says Thanks for the reply, the mailbox resp. account is in the profile! However, I've another update regarding my issue. It was somehow connected with Outlook Anywhere (connection via HTTP) which had problems to fully load the (global) adress lists, thus the code was not able to resolve the exchange account. I had to manually load the offline address book, afterwards it was working. 123. Jenny Bradley says I'm getting a compile error in the CurCal line saying ambigious name detected CurCal_Item Add. Is the issue that my main outlook calendar properties are "Jenny.Bradley@cheshirepark.com" and my secondary calendar to which I want copies made (at my choosing in msgbox) is "Jenny.Bradley@cheshirepark.com/calendar"?? My script is below: 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("Jenny.Bradley@cheshirepark.com\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 curCal_ItemRemove() 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) 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

• Diane Poremsky says

ambiguous name means you are using a macro name twice.

124. Mark Lautenbach says

So my question is, what needs to be changed in the code to copy from an Internet calendar that is active in Outlook to the Default Calendar? I have a subscribed internet calendar in Outlook that I would like to copy/move/delete appointments in my default outlook Calendar.

• Diane Poremsky says

If using GetFolderpath doesn't work, you won't be able to do it - the internet calendar is read-only and that could be causing issues. I'll try and test it.

125. Moritz says

Hello first of all im sorry for my bad english!

I have a question / problem, i've used your code and everything is working fine but there is a small problem: how do i copy a sent appointment from my calendar in to another Calendar?

• Diane Poremsky says

I'm not sure I understand what you want to do - as long as the appointment is on your calendar, the macro should copy it. It doesn't matter how it got there.

126. Rolf Wachter says

Hi Diane,
thank you for this piece of code. It's (almost) exactly what I've been looking after for some years.
But I've got a problem with the deleting part: When deleting an item in my Default Calendar, not only the matching item in newCal will be deleted, but also some others. It seems to be quite randomly which items will be deleted. Even items, that have been copied in this calendar without using the macro are affected.
Do you have an idea? My default calendar is an Exchange calendar, the one I'm copying to is the local copy of a Sharepoint calendar. I'm using Office 2010 on Win 7 and your code (with GUID) without any changes (except the FolderPath, of course)
Thanks for any help

• Diane Poremsky says

Is the GUID added to the appointments? As long as it is looking for the GUID, it should only delete ones that match, but during testing there were some instances where the GUID wasn't added. I forget the exact scenario though (I tested it months ago). I'll see if i can repro.

127. Rolf Wachter says

Thank you for the answer. That's why I was wondering. The GUID is added to both items, the original and the copied one. The script deletes randomly items with another GUID. I can't figure out, why tihs happens ...

Please post long or more complicated questions at OutlookForums by Slipstick.com.

If the Post Comment button disappears, press your Tab key.