Copy new appointments to another calendar using VBA

Last reviewed on February 11, 2015   —  250 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, change, and delete appointments.
  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.

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

About Diane Poremsky

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 Outlook forums by Slipstick.com.

250 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

    1. Diane Poremsky

      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

    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?

    1. Diane Poremsky

      It can be made to work with updates - you need to trap a different event. I'll put something together.

    2. Clint

      Hi Dianne - Any luck on the update code for this code
      Thanks
      Clint

    3. Diane Poremsky

      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

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

    1. Diane Poremsky

      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

    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.

    1. Diane Poremsky

      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

    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.

    1. Diane Poremsky

      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

    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.

    1. Diane Poremsky

      This macro is one direction only. if you want two-way sync, try CodeTwo's FolderSync.

  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.

    1. Diane Poremsky

      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.

    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

    1. Diane Poremsky

      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

    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

    1. Diane Poremsky

      as you discovered before I could answer :) use If Item.Categories = "Blue" Then

  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?

    1. Diane Poremsky

      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

    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?

    1. Diane Poremsky

      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

    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.

    1. Diane Poremsky

      I'm going to attempt to do it. :)

  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

    1. Diane Poremsky

      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

    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.

    1. Diane Poremsky

      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

    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?

    1. Diane Poremsky

      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

    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?

    1. Diane Poremsky

      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

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

    1. Diane Poremsky

      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

    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.

    1. Diane Poremsky

      This is an Exchange server account? What permission does your account have on the shared calendar folder?

  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

    1. Diane Poremsky

      What is the error message?

  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

    1. Diane Poremsky

      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

    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

    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

    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

    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

    1. Diane Poremsky

      Do the copied ones update to outlook.com if you add a category (in the outlook.com calendar in outlook) ? I

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

    1. Diane Poremsky

      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

    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

    1. Diane Poremsky

      I don't know - i need to investigate it. Is the folder path correct? That could be one source of the error.

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

    1. Diane Poremsky

      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

    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.

    1. Daniel

      Diane,

      Has there been any progress on the update/delete functionality?

      Thanks!

    2. Diane Poremsky

      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

    Terrific. That worked.
    Thank you,
    Babak

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

    1. Diane Poremsky

      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

    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?

    1. Diane Poremsky

      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

    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!

    1. Diane Poremsky

      Which line does it stop on?

    2. Jacob Mulberry

      If Item.BusyStatus = olBusy Then

      This happens on Outlook 2010 and 2013.

    3. Diane Poremsky

      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.

    4. Jacob Mulberry

      I tried this to no avail. Still get the error. :/ Not sure what the difference is or what I need to do.

    5. Diane Poremsky

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

    6. Jacob Mulberry

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

    7. Diane Poremsky

      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

    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

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

    Jim

    1. Diane Poremsky

      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

    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.

    1. Diane Poremsky

      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.

    2. Jim Fekete

      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.

    3. Diane Poremsky

      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

    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.

    1. Diane Poremsky

      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.

    2. Jacob Mulberry

      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

    3. Diane Poremsky

      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

    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

    1. Diane Poremsky

      if its in a different data file, you need to use the getfolderpath function.
      http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/

    2. Carolina Giraldo Correa

      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

    3. Diane Poremsky

      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

    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

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

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

    1. Diane Poremsky

      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

    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,

    1. Diane Poremsky

      I'm still looking into this error.

    2. Todd

      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

    3. Diane Poremsky

      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

    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!

    1. Diane Poremsky

      Does this happen with all appointments or just some?

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

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

    1. Diane Poremsky

      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

    Thanks =)

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

    1. Diane Poremsky

      It is odd. I'll try and repro it.

  50. Paul

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

    1. Diane Poremsky

      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

    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

    1. Diane Poremsky

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

    2. Diane Poremsky

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

    3. Dimitris Bantileskas

      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

    4. Diane Poremsky

      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?

    5. Diane Poremsky

      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

    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

    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

    1. Diane Poremsky

      I eliminated the error using GetPublicFolder from http://www.outlookcode.com/codedetail.aspx?id=1164 but it doesn't copy the appt... will keep trying.

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

    1. Diane Poremsky

      Which line does it fail on?

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

    1. Diane Poremsky

      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)

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

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

      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

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

    1. Diane Poremsky

      Remove or comment out the On Error Resume Next line and see where it errors.

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

    1. Diane Poremsky

      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.

  61. Isaac Wyatt (@IsaacWyatt)

    Thanks - I'll try that out.

    Best,
    Isaac

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

      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?

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

      That should be doable... I think. I'll have to check.

  67. Sean

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

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

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

  70. Alex

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

    1. Diane Poremsky

      No, I haven't gotten it working. I initially tried using the message id, but need to search for it instead.

  71. Diane Poremsky

    Finally... working code to update the copy when you edit the original.

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

    1. Diane Poremsky

      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)

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

      You'd use the BeforeDelete event, with pretty much the same code that is used the itemchange event macro.

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

      Try changing Outlook.Folder to Outlook.MapiFolder -

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

    1. Diane Poremsky

      The item change code sample should pick up changes - I didn't do one for deletions, but yes, it would be possible.

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

      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.

    2. Dimtiris Bantileskas

      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

    3. Diane Poremsky

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

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

      If macro security is set to none and the VB Editor opens, it *should* work.

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

    1. Diane Poremsky

      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

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

    1. Diane Poremsky

      Typo, two double quotes: Set newCalFolder = GetFolderPath(""dbantileskas@nsllpcpa.com\Calendar\Dimitris Team")

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

  86. Dimitris Bantileskas

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

    1. Diane Poremsky

      That error says an object does not exist - try adding Dim newCalFolder As Outlook.Folder
      to the macro.

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

      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.

  91. David Moore

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

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

    1. Diane Poremsky

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

      end if

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

    1. Diane Poremsky

      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.

    2. Lauren

      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

    3. Diane Poremsky

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

    4. Lauren

      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

    5. Diane Poremsky

      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

  94. 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. Diane Poremsky

      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.

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

    3. Diane Poremsky

      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.

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

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

    1. Diane Poremsky

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

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

    1. Diane Poremsky

      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.

    2. shawn

      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

    3. Diane Poremsky

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

    4. Diane Poremsky

      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.

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

    1. Diane Poremsky

      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.

    2. Diane Poremsky

      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.

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

    1. Diane Poremsky

      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.

    2. Jakob Jørgensen

      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

    3. Diane Poremsky

      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.

    4. Jakob Jørgensen

      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?

    5. Diane Poremsky

      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.

    6. Jakob Jørgensen

      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

    7. Diane Poremsky

      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.

    8. Jakob Jørgensen

      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.

    9. Diane Poremsky

      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.

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

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

    1. Diane Poremsky

      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.

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

    1. Diane Poremsky

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

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

    1. Diane Poremsky

      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.

    2. Trent

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

    3. Diane Poremsky

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

    4. mdkarp

      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.

    5. Diane Poremsky

      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
      .DayOfWeekMask = itemPattern.DayOfWeekMask
      .Occurrences = itemPattern.Occurrences
      .Duration = itemPattern .Duration
      .PatternStartDate = itemPattern.PatternStartDate
      .StartTime = itemPattern.StartTime
      .EndTime = itemPattern.EndTime
      End With
      end if

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

    1. Diane Poremsky

      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?

    2. Seb

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

    3. Seb2

      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

    4. Diane Poremsky

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

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

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

    1. Diane Poremsky

      What type of email account or data file does the second calendar belong to? You can't copy imap calendars.

  107. Paul

    Hello,

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

    Thanks a lot
    Paul

    1. Diane Poremsky

      I have not tested it with an ics, but as long as its the one you are copying from, it should work.

  108. Daniel Schunk

    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

  109. Adrian Hernandez

    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 :

  110. Adrian Hernandez

    Hi Diane,

    I noticed that meetings that are set for All Day, are not being copied. Any ideas as to why?

  111. Adrian Hernandez

    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

  112. Adrian Hernandez

    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.

  113. Adrian Hernandez

    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?

Leave a Reply

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

This site uses XenWord.