Copy new appointments to another calendar using VBA

Last reviewed on September 15, 2014   —  238 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.

Use a macro to copy appointments

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 and change appointments. This is a slight variation on the macros below - the original and target calendar are set in the Startup macro.
  5. Folder pathsChange 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.

parent path on folder propertiesTip: 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.

Dim WithEvents curCal As Items
 
Private Sub Application_Startup()
   Dim NS As Outlook.NameSpace
   Set NS = Application.GetNamespace("MAPI")
' calendar to watch for new items
   Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items
   Set NS = Nothing
End Sub
 
Private Sub curCal_ItemAdd(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim moveCal as AppointmentItem
Dim newCalFolder As Folder

' On Error Resume Next
'calendar to copy the appt to
Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Test")

If Item.BusyStatus = olBusy Then

Set cAppt = Application.CreateItem(olAppointmentItem)

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

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

    End If
 End Sub


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

 

Copy to a Shared Exchange Calendar

When the calendar you want to copy to or from is in a shared Exchange mailbox, you need to resolve the owner's name or alias and pass it to GetSharedDefaultFolder. You can use the alias, default SMTP address, or display name. I recommend using the alias or email address.

Replace the Application_Startup macro in this text file with the version here.

Private Sub Application_Startup()
  Dim NS As Outlook.NameSpace
  Dim CalendarFolder As Outlook.Folder
  Dim objOwner As Outlook.Recipient
  
  Set NS = Application.GetNamespace("MAPI")
   ' default calendar
Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items


   'calendar you are copying to
Set objOwner = NS.CreateRecipient("maryc")
    objOwner.Resolve
     

 If objOwner.Resolved Then
   'MsgBox objOwner.Name

  Set newCalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
  Set Items = newCalFolder.Items
 End If

End Sub

Update copied appointment

If you want to update appointments on the second calendar, add this code sample to the module. This code gets the subject and start date/time when you edit an appointment and looks for a match on the second calendar. When you save changes, the matching event is also updated.

Using this code, you can't change the subject or start time. To be able to change the start time or date, add a random code or GUID at the end of the Notes field to both appointments to identify the matching appointment (a sample follows this macro).

Private Sub curCal_ItemChange(ByVal Item As Object)
Dim newCalFolder As Outlook.Folder
Dim cAppt As AppointmentItem
Dim objAppointment As AppointmentItem
Dim strStart, strSubject As String
    
 On Error Resume Next
'calendar to copy the appt to
Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Test")
    
strSubject = "Copied: " & Item.Subject
strStart = Item.Start

For Each objAppointment In newCalFolder.Items
 If objAppointment.Subject = strSubject And objAppointment.Start = strStart Then
         Set cAppt = objAppointment
   End If
 Next
 
With cAppt
    .Subject = "Copied: " & Item.Subject
    .Start = Item.Start
    .Duration = Item.Duration
    .Location = Item.Location
    .Body = Item.Body
    .Save
End With
 
End Sub

If you need to be able to change the start date or time, you'll need another way to identify the matching appointment. One way is by adding a GUID at the end of the body. Because the GUID list fairly long, there is a high certainty that the code is unique.

Use this code in the ItemAdd macro:

If Item.BusyStatus = olBusy Then

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

Use this in the ItemChange macro:

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

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

And this function to generate the code:

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

If you prefer to use a random alphanumeric code, use the last code sample at Create sequential numbers or random character keywords for the necessary VBA code.

Written by

Diane Poremsky
A Microsoft Outlook Most Valuable Professional (MVP) since 1999, Diane is the author of several books, including Outlook 2013 Absolute Beginners Book. She also created video training CDs and online training classes for Microsoft Outlook. You can find her helping people online in Outlook Forums as well as in the Microsoft Answers and TechNet forums.

Please post long or more complicated questions at Outlookforums.

238 responses to “Copy new appointments to another calendar using VBA”

  1. Norethel

    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

    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

  3. Rafael

    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?

  4. Aziz

    Can I know event which start to work when i open the new coming letter in outlook(vba). Thank you!

  5. Chris

    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.

  6. Chris

    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.

  7. Cory Hug

    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.

  8. derek christensen

    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.

  9. Joe Lehman Jr.

    Thanks Diane Works great.

  10. Hiral Parikh

    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

  11. Zoheb Siddiqui

    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

  12. Zoheb Siddiqui

    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?

  13. Zoheb Siddiqui

    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?

  14. madams

    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.

  15. Zoheb Siddiqui

    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

  16. Gary

    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.

  17. Gary

    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

    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?

  19. Vaibhav Rajeshirke

    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?

  20. Vaibhav Rajeshirke

    Diane, I appreciate your quick response.
    I tried adding .Save but still have the same problem.

  21. Jakob Riis

    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.

  22. Babak

    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

  23. Babak

    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

  24. Babak

    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

  25. Travis Smith

    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

  26. BAbak

    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

  27. Maurits

    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?

  28. Jim Fekete

    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

  29. Babak

    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

  30. Babak

    Terrific. That worked.
    Thank you,
    Babak

  31. Daniel Schunk

    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

  32. Orlando

    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?

  33. Jacob Mulberry

    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!

  34. Jacob Mulberry

    Diane,

    It stops on the line "If Item.BusyStatus = olBusy Then"
    I am running Outlook 2013 if that makes a difference.

    Thanks,

  35. Jim Fekete

    FWIW, this is the same error I reported above, running Outlook 2010. I've poked around in the code, but can't diagnose.

    Jim

  36. Jim Fekete

    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.

  37. Jim Fekete

    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.

  38. Carolina Giraldo Correa

    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

  39. Carolina Giraldo Correa

    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

  40. Carolina Giraldo Correa

    Thank you very much Diana, I would really appreciate it.

  41. GR8iTUD

    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).

  42. Todd Hunter

    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,

  43. Paul

    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!

  44. Paul

    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).

  45. Paul

    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

  46. Todd Hunter

    Thanks =)

  47. Paul

    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?

  48. Paul

    Hi Diane, any luck with that? :-) Thanks again!

  49. Dimitris Bantileskas

    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

  50. Dimitris

    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

  51. Dimitris Bantileskas

    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

  52. Callie Daum

    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

  53. Isaac Wyatt (@IsaacWyatt)

    Hi Diane - Can you help?

    I'm having trouble modifying this for copy events from Internet Calendars (in my case, Google Calendar) to my local primary Calendar. I've set up a stack exchange question here if you care to look:

    http://stackoverflow.com/questions/19036052/how-do-i-automatically-copy-events-from-an-internet-calendar-to-my-primary-local

    Thanks,
    Isaac

  54. Callie daum

    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.

  55. Callie Daum

    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.

  56. Dimitris Bantileskas

    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

  57. Callie Daum

    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?

  58. Dimitris Bantileskas

    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

  59. Isaac Wyatt (@IsaacWyatt)

    Thanks - I'll try that out.

    Best,
    Isaac

  60. James Mears

    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.

  61. Kevin Minkoff

    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?

  62. patrik quick

    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?

  63. Sean

    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!

  64. Dimitrs Bantileskas

    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

  65. Sean

    No, it is a hotmail/windows live account. I did what you stated above previously per the original instructions.

  66. Anthony

    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

  67. Shawn

    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

  68. Alex

    Diane,
    Thank you very much. It`s a very useful code. Did you manage to add update/delete functionality?

  69. gmichael7

    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,

  70. gmichael7

    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.

  71. rharrison75

    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

  72. Trent

    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?

  73. Steve Smith

    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.

  74. Steve Smith

    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.

  75. Dimitris Bantileskas

    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

  76. Dimitris Bantileskas

    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

  77. Dimitris Bantileskas

    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.

  78. Andreas

    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?

  79. Andreas

    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!

  80. John

    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?

  81. Dimitris Bantileskas

    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

  82. Andreas

    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!

  83. Dimitris Bantileskas

    Diane, I checked and fixed the typo errors. Unfortunately I receive the same error message. Please advise. Thanks.

  84. Dimitris Bantileskas

    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.

  85. Dimitris Bantileskas

    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

  86. Dimitris Bantileskas

    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

  87. Dave Woyciesjes

    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...

  88. David Moore

    everyone should try CodeTwo Sync for iCloud. its $20 but works wonderfully.

  89. Dave Woyciesjes

    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.

  90. Lauren

    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.

    Thank you greatly in advance!
    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

  91. Lauren

    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

    1. shawn

      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

  92. Alex

    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

  93. shawn.hippen@jcep.info

    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

  94. shawn

    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

  95. Bradley Davidson

    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?
    Bradley

  96. Jakob Jørgensen

    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

  97. Jakob Jørgensen

    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.

  98. Sebastian

    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

  99. Daniel Schunk

    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

  100. Trent

    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

  101. Seb

    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

  102. Dana Stodgel (@DanaStodgel)

    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

  103. darqp

    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?

  104. Paul

    Hello,

    is it possible to use this macro to copy an internet calendar (iCal) to Outlook Exchange?

    Thanks a lot
    Paul

Leave a Reply

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