RSSThis macro "watches" for a new appointment to be added to the calendar and copies it to a second calendar. This is useful if you are sharing a calendar or syncing one calendar with a smartphone.
The code contains and If - Then statement (If Item.BusyStatus = olBusy Then) and copies only items that are marked busy. You can use use Categories or keywords in the subject as the filter or copy all items by removing the If.. and Then lines. You can remove or change the "Copied" tag added to the subject line.
This code, as written, assumes the second calendar is in another data file in the profile. It can easily be changed to work with a folder in the current data file. See Working with VBA and non-default Outlook Folders for more information.
To use:
- Enable macros in the Trust Center. In Outlook 2010/2013, this is at File, Options, Trust Center, Macros. In Outlook 2007, go to Tools, Trust Center. Use either warn or no security for now. Once you are happy with it, you can sign it with a self-certificate and set macros to signed-only.
- Open the VB Editor by pressing Alt+F11 on your keyboard.
- Expand Project1 to display ThisOutlookSession and double click to open it to the right side.
- Paste the code below into ThisOutlookSession. I have a text file with the macros here: Text file containing the macros to copy, change, and delete appointments.
Change the folder path ("display name in folder list\Calendar") to the display name you see in the Folder List (this is usually the email address in Outlook 2010 and 2013). You can see the parent path in the Folder List (Ctrl+6) or right-click on the Calendar folder and choose Properties when in the Calendar module. For example, the path shown in the screenshot is "New PST\Test Cal".- Place the mouse in the Application_StartUp macro and press the Run button or F5.
- Create an appointment in your calendar and see if it was copied to the other calendar.
Change the folder path ("display name in folder list\Calendar") to the display name you see in the Folder List (this is usually the email address in Outlook 2010 and 2013). You can see the parent path in the Folder List (Ctrl+6) or right-click on the Calendar folder and choose Properties when in the Calendar module. For example, the path shown in the screenshot is "New PST\Test Cal".
Tip: The path can be copied from the Properties page, which can be helpful for long paths. Right-click on the calendar, choose Properties to see this dialog.
February 11 2015. Updated the macros to use a GUID. This is better (IMHO) because it allows you to change the time or subject... and works with the delete macro. I'm also setting the move-to-folder as a global variable so you only need to change the path once (in the application_startup macro).
If you prefer to use a random alphanumeric code instead of the GUID, use the last code sample at Create sequential numbers or random character keywords for the necessary VBA code and update the macro accordingly.
Dim WithEvents curCal As Items
Dim newCalFolder As Outlook.folder
Private Sub Application_Startup()
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
' calendar to watch for new items
Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items
' calendar moving copy to
Set newCalFolder = GetFolderPath("data-file-name\calendar")
Set NS = Nothing
End Sub
Private Sub curCal_ItemAdd(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim moveCal As AppointmentItem
' On Error Resume Next
'remove to make a copy of all items
If Item.BusyStatus = olBusy Then
Item.Body = Item.Body & "[" & GetGUID & "]"
Item.Save
Set cAppt = Application.CreateItem(olAppointmentItem)
With cAppt
.Subject = "Copied: " & Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
End With
' set the category after it's moved to force EAS to sync changes
Set moveCal = cAppt.Move(newCalFolder)
moveCal.Categories = "moved"
moveCal.Save
End If
End Sub
Public Function GetGUID() As String
GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
Copy to a Shared Exchange Calendar
When the calendar you want to copy to or from is in a shared Exchange mailbox, you need to resolve the owner's name or alias and pass it to GetSharedDefaultFolder. You can use the alias, default SMTP address, or display name. I recommend using the alias or email address.
Replace the Application_Startup macro in this text file with the version here.
Private Sub Application_Startup()
Dim NS As Outlook.NameSpace
Dim CalendarFolder As Outlook.Folder
Dim objOwner As Outlook.Recipient
Set NS = Application.GetNamespace("MAPI")
' default calendar
Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items
'calendar you are copying to
Set objOwner = NS.CreateRecipient("maryc")
objOwner.Resolve
If objOwner.Resolved Then
'MsgBox objOwner.Name
Set newCalFolder = NS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
Set Items = newCalFolder.Items
End If
End Sub
Update copied appointment
If you want to update appointments on the second calendar, add this code sample to the module. This code looks for an appointment with the same GUID. When you save changes, the matching event is also updated.
Because this code looks for the GUID, you can change the subject or start time.
This code is written to work with the ItemAdd macros above and gets the newCalFolder name from the application_startup macro.
Private Sub curCal_ItemChange(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim objAppointment As AppointmentItem
Dim strBody As String
On Error Resume Next
' use 2 + the length of the GUID
strBody = Right(Item.Body, 38)
For Each objAppointment In newCalFolder.Items
If InStr(1, objAppointment.Body, strBody) Then
Set cAppt = objAppointment
End If
Next
With cAppt
.Subject = "Copied: " & Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
.Save
End With
End Sub
Delete the copied appointment
When you delete the original appointment, the following code will delete the copy as well. Thanks to Adrian for this!
This code is written to work with the ItemAdd macros above and gets the newCalFolder name from the application_startup macro.
Private Sub curCal_ItemRemove() Dim cAppt As AppointmentItem Dim objAppointment As AppointmentItem Dim strBody As String On Error Resume Next ' use 2 + the length of the GUID strBody = Right(Item.Body, 38) For Each objAppointment In newCalFolder.Items If InStr(1, objAppointment.Body, strBody) Then Set cAppt = objAppointment cAppt.Delete End If Next End Sub
![Diane Poremsky [Outlook MVP]](http://media.slipstick.com/images/2013/mvp-icon.png){kind=icon}
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?
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
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.
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?
It can be made to work with updates - you need to trap a different event. I'll put something together.
Hi Dianne - Any luck on the update code for this code
Thanks
Clint
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.
Can I know event which start to work when i open the new coming letter in outlook(vba). Thank you!
If i understand the question correctly, you need the open event.
Public WithEvents Item As Outlook.MailItemSub 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
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.
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.
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.
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.
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.
This macro is one direction only. if you want two-way sync, try CodeTwo's FolderSync.
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.
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 ItemsPrivate 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
Thanks Diane Works great.
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
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.
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
as you discovered before I could answer :) use If Item.Categories = "Blue" Then
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?
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)
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?
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)
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.
I'm going to attempt to do it. :)
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
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.
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.
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.
Thanks for your help. Hopefully you get a little free time to get that trap working for update/moved meetings, that would be great.
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?
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.)
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?
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
Diane, I appreciate your quick response.
I tried adding .Save but still have the same problem.
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.
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.
This is an Exchange server account? What permission does your account have on the shared calendar folder?
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
What is the error message?
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
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)")
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.
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
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
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
Do the copied ones update to outlook.com if you add a category (in the outlook.com calendar in outlook) ? I
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?
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.
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
I don't know - i need to investigate it. Is the folder path correct? That could be one source of the error.
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
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
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.
Diane,
Has there been any progress on the update/delete functionality?
Thanks!
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. :))
Terrific. That worked.
Thank you,
Babak
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
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?
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?
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.
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!
Which line does it stop on?
If Item.BusyStatus = olBusy Then
This happens on Outlook 2010 and 2013.
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.
I tried this to no avail. Still get the error. :/ Not sure what the difference is or what I need to do.
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).
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. :)
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.)
Diane,
It stops on the line "If Item.BusyStatus = olBusy Then"
I am running Outlook 2013 if that makes a difference.
Thanks,
FWIW, this is the same error I reported above, running Outlook 2010. I've poked around in the code, but can't diagnose.
Jim
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
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.
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.
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.
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.
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.
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.
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
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
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
if its in a different data file, you need to use the getfolderpath function.
http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/
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
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.
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
Thank you very much Diana, I would really appreciate it.
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).
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?
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,
I'm still looking into this error.
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
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.
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!
Does this happen with all appointments or just some?
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).
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
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.
Thanks =)
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?
It is odd. I'll try and repro it.
Hi Diane, any luck with that? :-) Thanks again!
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).
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
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")
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")
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
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?
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
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
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
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.
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
Which line does it fail on?
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
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)
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.
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.
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.
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
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
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?
Remove or comment out the On Error Resume Next line and see where it errors.
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
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.
Thanks - I'll try that out.
Best,
Isaac
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.
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.
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?
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?
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?
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.
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!
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.
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
That should be doable... I think. I'll have to check.
No, it is a hotmail/windows live account. I did what you stated above previously per the original instructions.
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
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
Diane,
Thank you very much. It`s a very useful code. Did you manage to add update/delete functionality?
No, I haven't gotten it working. I initially tried using the message id, but need to search for it instead.
Finally... working code to update the copy when you edit the original.
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,
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)
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.
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.
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
You'd use the BeforeDelete event, with pretty much the same code that is used the itemchange event macro.
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?
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.
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.
Try changing Outlook.Folder to Outlook.MapiFolder -
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.
The item change code sample should pick up changes - I didn't do one for deletions, but yes, it would be possible.
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
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.
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
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.
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
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")
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.
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.
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?
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.
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!
If macro security is set to none and the VB Editor opens, it *should* work.
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?
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
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
Typo, two double quotes: Set newCalFolder = GetFolderPath(""dbantileskas@nsllpcpa.com\Calendar\Dimitris Team")
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!
Diane, I checked and fixed the typo errors. Unfortunately I receive the same error message. Please advise. Thanks.
That error says an object does not exist - try adding Dim newCalFolder As Outlook.Folder
to the macro.
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.
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.
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
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.
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
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.
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...
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.
everyone should try CodeTwo Sync for iCloud. its $20 but works wonderfully.
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.
you'll need to do something like this -
If instr(objAppointment.categories,"Personal") > 0 Then
exit sub
else
' do whatever
end if
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
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.
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
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"?
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
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
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
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.
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
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.
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
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
No, it should work - you just need two calendars. Do you get any error messages?
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
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.
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
Permissions wouldn't be a problem with non-Microsoft accounts. I'll see if i can repro with the same account set up.
Looks like its because its an imap calendar. Start and other fields fail too.
Is there a reason you are copying from imap to an Outlook.com calendar? I usually recommend setting the Outlook.com data file as the default data file then deleting the imap ost and letting outlook recreate it without the special folders. Just make sure you move the calendar, contacts, and tasks out before deleting it.
Diane,
I appreciate all the work you do to help us out here but I have tried the steps above and it almost works. It seems that it continually copies the same event from my local calendar to my outlook.com calendar. I'm using Outlook 2013. Any ideas what could be wrong?
Bradley
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.
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.
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
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.
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
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.
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?
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.
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
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.
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.
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.
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.
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
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.
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
You need to do something like .alldayevent = oAppt.alldayevent
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
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.
Hi Diane. Have you had any chance to look at being able to copy meetings with recurrences? Thanks. Trent
I looked but haven't had a lot of free time to fine tune it (aka make it work correctly).
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.
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
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
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?
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...
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
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.)
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
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?
What type of email account or data file does the second calendar belong to? You can't copy imap calendars.
Hello,
is it possible to use this macro to copy an internet calendar (iCal) to Outlook Exchange?
Thanks a lot
Paul
I have not tested it with an ics, but as long as its the one you are copying from, it should work.
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
That is actually fairly easy - replace the 'If busystatus' line with this:
Dim intRes As Integer
Dim Msg As String
Msg = "Do you want to copy the appointment to " & newCalFolder.Parent.Name & " Calendar?"
If Item.BusyStatus = olBusy Then
intRes = MsgBox(Msg, vbYesNo + vbExclamation, "Confirm Copy")
If intRes = vbNo Then
Exit Sub
End If
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 :
I will see if i can do it - I can't remember if i tried deleting before.
Hi Diane,
I noticed that meetings that are set for All Day, are not being copied. Any ideas as to why?
This line: If Item.BusyStatus = olBusy Then has the effect of filtering out all day events (because they aren't marked busy). Remove that line and the matching End if to copy all appointments.
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
Cool. I couldn't get itemremove to work - but I was using the subject find method to find it. I hadn't yet switched to using the GUID. I should update all of the code to use GUID by default.
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.
You can use code to not set a reminder on the copies, but Hotmail sets one for you (or it used to) and you can't suppress reminders in one calendar folder. Actually, maybe the solution is to not set reminders on the original in the local pst and only use Hotmail reminders... we can do this using vba if the default calendar reminder options prevents the Hotmail reminders.
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?
it's because the copy is just creating a new appointment, not copying the existing one. I'll update the code to handle it better.
Thanks for the article. This was a great help. This was my first VBA code, so I needed the help getting started. After some tweaking I got this working the way I wanted. Big changes are:
1. Allow edits to the body - with the original code if you append something to the end of the body (after the guid) you lose the link. So I stored the ID in the Mileage field (just picked a free form string that I am not using).
2. With a large calendar (lots of items) looking through each item to find the item is very slow - causing a lot of lag when editing calendar items. So instead of storing a GUID in the appt item, I store the copy's EntryID in the original item's Mileage field. Then find the original item using GetItemFromID(). This is a lot faster.
3. I couldn't get Adrian's approach to deleting to work consistently. ItemRemove() doesn't give you the item that is being removed. So instead I catch the ItemAdd() on the trashfolder and see if I can find the item being added. It doesn't work if you Shift-Delete.
Thanks a lot to everyone who contributed to this thread.
Dim WithEvents curCal As Items
Dim newCalFolder As Outlook.Folder
Dim WithEvents trashFolder As Items
Private Sub Application_Startup()
Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")
' calendar to watch for new items
Set curCal = NS.GetDefaultFolder(olFolderCalendar).Items
' trashfolder to watch for deleted items
Set trashFolder = NS.GetDefaultFolder(olFolderDeletedItems).Items
' calendar moving copy to
Set newCalFolder = GetFolderPath("\\destcal\cal")
Set NS = Nothing
End Sub
Private Sub curCal_ItemAdd(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim moveCal As AppointmentItem
'remove to make a copy of all items
If Item.BusyStatus = olBusy Then
Set cAppt = Application.CreateItem(olAppointmentItem)
With cAppt
.Subject = "[Copied] " & Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
End With
' set the category after it's moved to force EAS to sync changes
Set moveCal = cAppt.Move(newCalFolder)
moveCal.Categories = "moved"
moveCal.Save
Item.Mileage = moveCal.EntryID
Item.Save
End If
End Sub
Private Sub curCal_ItemChange(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim objAppointment As AppointmentItem
On Error Resume Next
If IsNull(Item) Or IsEmpty(Item) Then Exit Sub
If IsEmpty(Item.Mileage) Or Item.Mileage = "" Then Exit Sub
Set cAppt = Application.GetNamespace("MAPI").GetItemFromID(Item.Mileage)
If IsNull(cAppt) Or IsEmpty(cAppt) Then Exit Sub
With cAppt
.Subject = "[Copied] " & Item.Subject
.Start = Item.Start
.Duration = Item.Duration
.Location = Item.Location
.Body = Item.Body
.Save
End With
End Sub
Private Sub trashFolder_ItemAdd(ByVal Item As Object)
' watch for deleted items
Dim cAppt As AppointmentItem
On Error Resume Next
If IsNull(Item) Or IsEmpty(Item) Then Exit Sub
If IsEmpty(Item.Mileage) Or Item.Mileage = "" Then Exit Sub
Set cAppt = Application.GetNamespace("MAPI").GetItemFromID(Item.Mileage)
If IsNull(cAppt) Or IsEmpty(cAppt) Then Exit Sub
If cAppt.Categories "moved" Then Exit Sub
cAppt.Delete
End Sub
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
Dim oFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
Hi Diane,
When I remove the busy status if/then and change "Copied" in the subject line to "Work", the edit and delete functions no longer work. Have you or other experienced this? If so, is there a solution? Thanks for all of your hard work!
Are you using the GUID in the body? If you are using older code (that I originally published), it searches for the "copy: subject" in the second calendar and you need to change it in the update and delete code too. The GUID code is better - it just looks for the guid in the body.