This code creates appointments from a selected recurring appointment. It picks up the appointment's start date (see warning below!) and creates appointments from the start date up to 30 days in the future, if the recurring appointment does not have an end date set.
The code gets the subject from the date of the selected appointment and creates a filter, so only the selected recurring appointment series is copied to appointments. If you have more than one appointment series with the same subject, appointments will be created for each series, since the filter uses the subject. Edit the subject of the series you want to copy so it is unique.
If you just need a list of dates, see How to print a list of recurring dates using VBA. To copy just a single occurrence to an appointment, see Copy Selected Occurrence to Appointment.
Using the macro
This macro was tested in Outlook 2010, Outlook 2007 and Outlook 2003. It should work with at least Outlook 2002 as well (it's built off the Outlook 2002 macro listed in More Information).
However, the filter (sFilter) needs to be edited for older versions, as [IsRecurring] does not work. Use this instead:
sFilter = "[Start] >= '1/1/2000' And [End] < '" & tEnd & "' And [Subject] = " & strSubject
Also, leading or ending spaces (" My Appointment" or "My Appointment ") in the subject will cause the macro to fail with 0 appointments found. Removing the spaces from the subject should take care of it. You could also move or copy the recurring appointment to a new Calendar folder and remove the subject filter.
When you select an appointment in Day/Week/Month view, the start date is for the selected occurrence, not the first appointment in the series. When you select the series in list view, it will use the very first date of the appointment. For this reason, I recommend using list view with this macro. I also recommend leaving the Message Box popup in the code and assigning categories to the copies. It makes it easier to identify inconsistencies before removing the original appointment series. See Tweaking the Macro for additional filter options
I recommend testing this macro first by creating (or copying) a recurring event (or two) to a second Calendar folder and running the code while viewing that folder.
Outlook 2010 users can customize the QAT or ribbon with a button for the macro (File, Custom ribbon or Quick Access toolbar commands) or you can show the Developer ribbon and run it from the Macros button.
In older versions of Outlook, run the macro from the Tools, Macros menu or customize the toolbar and assign the macro to a toolbar button.
Convert Recurring Appointments to Appointments
Open the VBA Editor using Alt+F11. Expand the Project to display ThisOutlookSession on the left. Double click to open it and paste the code below into the right side. Select a calendar folder then run the macro.
To use, select a recurring appointment or meeting and run the macro. I highly recommend using list view when you use this macro.
Press the Break key on your keyboard to end macro if it is running longer than a few minutes and you are not using a date filter.
Sub ConvertRecurring()
Dim CalFolder As Outlook.MAPIFolder
Dim CalItems As Outlook.Items
Dim ResItems As Outlook.Items
Dim sFilter, strSubject As String
Dim iNumRestricted As Integer
Dim itm, newAppt As Object
Dim tStart, tEnd As Date
Dim recAppt As Object
' Use the selected calendar folder
Set CalFolder = Application.ActiveExplorer.CurrentFolder
Set recAppt = Application.ActiveExplorer.Selection.Item(1)
' Get all of the appointments in the folder
Set CalItems = CalFolder.Items
' Sort all of the appointments based on the start time
CalItems.Sort "[Start]"
' Include the recurrences from the selected date forward
CalItems.IncludeRecurrences = True
' Pick up the Start Date of the selected appointment occurrence
' Use a List view to get all occurrences
tStart = Format(recAppt.Start, "Short Date")
' macro limits all appt to 30 days from now
' so you can end a series early
tEnd = Format(Now + 30, "Short Date")
' Pick up the selected appointment's subject
strSubject = recAppt.Subject
'create the Restrict filter
sFilter = "[Start] >= '" & tStart & "'" & " And [End] < '" & tEnd & "' And [IsRecurring] = True And [Subject] = " & Chr(34) & strSubject & Chr(34)
' Apply the filter to the collection
Set ResItems = CalItems.Restrict(sFilter)
iNumRestricted = 0
'Loop through the items in the collection.
For Each itm In ResItems
iNumRestricted = iNumRestricted + 1
Set newAppt = ActiveExplorer.CurrentFolder.Items.Add(olAppointmentItem)
newAppt.Start = itm.Start
newAppt.End = itm.End
newAppt.Subject = itm.Subject & " (Copy)"
newAppt.Body = itm.Body
newAppt.Location = itm.Location
newAppt.Categories = "Test Code, " & itm.Categories
newAppt.ReminderSet = False
' Copies attachments to each appointment.
If itm.Attachments.Count > 0 Then
CopyAttachments itm, newAppt
End If
newAppt.Save
Next
' Display the actual number of appointments created
MsgBox (iNumRestricted & " appointments were created"), vbOKOnly, "Convert Recurring Appointments"
Set itm = Nothing
Set newAppt = Nothing
Set ResItems = Nothing
Set CalItems = Nothing
Set CalFolder = Nothing
End Sub
Sub CopyAttachments(objSourceItem, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next
Set fldTemp = Nothing
Set fso = Nothing
End Sub
Tweaking the Macro
If you want to create appointments for all recurring series in the selected calendar, remove the subject from the filter and use a generic start date, or hard-code a date. By using a start date far in the past, you can select any date in the Day, Week, or Month view.
Remember: [IsRecurring] doesn't work in Outlook 2007 and under.
Use a specific start (or end) date
Use a filter with the start date hard-coded:
sFilter = "[Start] >= '1/1/2000' And [End] < '" & tEnd & "' And [IsRecurring] = True And [Subject] = " & strSubject
Use a start date in the past:
tStart = Format(Now - 365, "Short Date") sFilter = "[Start] >= '" & tStart & "'" & " And [End] < '" & tEnd & "' And [IsRecurring] = True"
To use a specific end date, replace tEnd with the date:
sFilter = "[Start] >= '1/1/2000' And [End] < '1/1/2016' And [IsRecurring] = True And [Subject] = " & strSubject
Include attendees names in appointments
To include a list of meeting invitees in the appointment body, use
newAppt.Body = "Attendees: " & itm.RequiredAttendees & itm.OptionalAttendees & vbCrLf & itm.Body
This will add your own name on appointments (you are always 'attending').
Convert all appointments in a series
To convert all events in the series, replace tEnd = Format(Now + 30, "Short Date") with the following code. If the series doesn't have an end date, appointments are created through one year from now. (The start date is the appointment start, if selected in list view.)
Change the 2 and 1 as needed.
Dim oPattern As RecurrencePattern
Set oPattern = recAppt.GetRecurrencePattern
tEnd = oPattern.PatternEndDate
' if no end date or more than 2 years into the future
' then 1 year from now
' date for 'if tEnd >' should always be equal or higher
If tEnd > Format(Now, "mm/dd/") & Format(Now, "yyyy") + 2 Then
tEnd = Format(Now, "mm/dd/") & Format(Now, "yyyy") + 1
End If
More Information
OL2002: Incorrect Count Property Using Recurring Appointments
Joris Linssen says
This is a great solution for an obviously missing feature in Outlook, so thanks for that! To make the solution even more complete I've added the code newAppt.BusyStatus = itm.BusyStatus to my implementation of the macro, in order to carry over the busy/free/tentative state of the recurring appointment.
Ken says
I receive "0 appointments were created" in Outlook 2013 running this on a recurring meeting copied from another calendar. The original appointment was created with Outlook 2003. This appointment is the only one in this calendar.
I see an IsRecurring property in Item 1 of CalItems, but tried using the pre-2007 sFilter, but get the same results. ResItems is empty.
I noticed that after setting the CalItems,IncludeRecurrences to true, the CalItems.count = 2147483647 and CalItems.Item 1.ConversationID changes from something that looks like a GUID to .
It seems like the filter isn't working.
Any Ideas?
Diane Poremsky says
This: CalItems.count = 2147483647 is normal - outlook doesn't actually count each specific occurrence, it counts between the start and end, resulting in the weird value. I've used it with both outlook 2013 and 2016, so the version is not the problem. I'll see if i can repro.
Ohhh... when you copied the meeting, did it copy the series or just the single occurrence? Outlook has been known to copy only the single occurrence.
casonsemail says
I get: Run-time Error '91' Object Variable or With Block not set..
Set newAppt = ActiveExplorer.CurrentFolder.Items.Add(olAppointmentItem)
newAppt.MessageClass = "IPM.Appointment.PMAppointment-v4"
With newAppt
.Start = itm.Start
.End = itm.End
.Subject = itm.Subject
.Body = itm.Body
.Location = itm.Location
.Categories = itm.Categories
.ReminderSet = False
.Save
'calling user-defined fields from form
Set objProp = newAppt.UserProperties.Add("ProjectName", olText, True)
objProp.Value = itm.UserProperties("ProjectName").Value
.Save
End With
' Copies attachments to each appointment.
If itm.Attachments.Count > 0 Then
CopyAttachments itm, newAppt
End If
newAppt.Save
Next
' Display the actual number of appointments created
MsgBox (iNumRestricted & " appointments were created"), vbOKOnly, "Convert Recurring Appointments"
Set itm = Nothing
Set newAppt = Nothing
Set ResItems = Nothing
Set CalItems = Nothing
Set CalFolder = Nothing
Set objProp = Nothing
End Sub
casonsemail says
Hi Diane, thanks for the additional input. I'm not entirely certain what the problem is. After I made those modifications, I no longer get the mismatch error, but the value simply doesn't carry over into the field on the form. I'll do some additional research and see if I can find a solution. If I do, I'll share it back here.
Thanks for your help.
Best,
Cason
Diane Poremsky says
Uncomment error handling code and try adding value to this:
objProp.Value = itm.UserProperties("ProjectName").value
Denis says
Thank you so much!
Denis says
Hi Diane,
Application.ActiveExplorer.Selection.Item(1) it looks like this line is taking out one appointment at a time, is there a way to change this so that the script will take out all appointments in the folder?
Diane Poremsky says
You should be able to do that. You need to check each event and make sure it's recurring then move on to the next one.
In a quickie test, this macro worked on all recurring appt.
Convert all recurring appt macro
casonsemail says
I've added the field, and entered the code, but I am getting a mismatch error. I've modified the code so it is uniform with your previous recommendations. I'm sure this is attributable to my lack of knowledge, but could you show me how to declare these values using the code you've previously provided? Thank you.
Set newAppt = ActiveExplorer.CurrentFolder.Items.Add(olAppointmentItem)
newAppt.MessageClass = "IPM.Appointment.PMAppointment-v3"
Set objProp = newAppt.UserProperties.Add("ProjectName", olText, True)
With newAppt
.Start = itm.Start
.End = itm.End
.Subject = itm.Subject
.Body = itm.Body
.Location = itm.Location
.Categories = itm.Categories
.ReminderSet = False
.Save
'calling user-defined fields from form
.UserProperties("ProjectName").Value = itm.UserProperties("ProjectName")
.Save
End With
Diane Poremsky says
I think you can set the Set objProp and objProp.value right before With newappt line, but they will also work before the Save -
Dim objProp As Outlook.UserProperty
Set newAppt = ActiveExplorer.CurrentFolder.Items.Add(olAppointmentItem)
newAppt.MessageClass = "IPM.Appointment.PMAppointment-v3"
With newAppt
.Start = itm.Start
.End = itm.End
.Subject = itm.Subject
.Body = itm.Body
.Location = itm.Location
.Categories = itm.Categories
.ReminderSet = False
.Save
'calling user-defined fields from form
Set objProp = newAppt.UserProperties.Add("ProjectName", olText, True)
objProp.Value = itm.UserProperties("ProjectName")
.Save
End With
casonsemail says
Hi Diane, apologies that the code didn't copy over properly. I'm not trying to filter on the UDF. I was simply trying to copy the field values over. This is the code I have using your suggestions, but it still is not working. I've looked in the "all fields" tab in developer mode in Outlook, and my fields are there, so I'm not sure what is going on. Thank you for any additional troubleshooting you can help with.
Set newAppt = ActiveExplorer.CurrentFolder.Items.Add(olAppointmentItem)
newAppt.MessageClass = "IPM.Appointment.PMAppointment-v3"
With newAppt
.Start = itm.Start
.End = itm.End
.Subject = itm.Subject
.Body = itm.Body
.Location = itm.Location
.Categories = itm.Categories
.ReminderSet = False
.Save
'calling user-defined fields from form
.UserProperties("ProjectName") = itm.UserProperties("ProjectName")
.UserProperties("ProjectOwner") = itm.UserProperties("ProjectOwner")
.UserProperties("ProjectDescription") = itm.UserProperties("ProjectDescription")
.Save
End With
Diane Poremsky says
if the field doesn't exist, you need to add it.
Dim objProp As Outlook.UserProperty
Set objProp = newAppt.UserProperties.Add("ProjectName", olText, True)
objProp.Value = itm.UserProperties("ProjectName")
casonsemail says
This macro is excellent! I've been able to copy not only the calendar invite, but also call on my custom form. I am having difficulty carrying over my user-defined fields,however, even with the suggestions above. I've tried making some modifications using the .User Properties.Find("...") function without any success. My code doesn't error out anywhere, it simply fails to copy over the data in the UDF. Can you please share some insight when you have a minute? Here is the code in full, below:
Diane - apologies for the second post, for some reason the code didn't copy properly into the comment box:
Sub ConvertRecurring()
Dim CalFolder As Outlook.MAPIFolder
Dim CalItems As Outlook.Items
Dim ResItems As Outlook.Items
Dim sFilter, strSubject As String
Dim iNumRestricted As Integer
Dim itm, newAppt As Object
Dim tStart, tEnd As Date
Dim recAppt As Object
' Use the selected calendar folder
Set CalFolder = Application.ActiveExplorer.CurrentFolder
Set recAppt = Application.ActiveExplorer.Selection.Item(1)
' Get all of the appointments in the folder
Set CalItems = CalFolder.Items
' Sort all of the appointments based on the start time
CalItems.Sort "[Start]"
' Include the recurrences from the selected date forward
CalItems.IncludeRecurrences = True
' Pick up the Start Date of the selected appointment occurrence
' Use a List view to get all occurrences
tStart = Format(recAppt.Start, "Short Date")
' macro limits all appt to 360 days from now
' so you can end a series early
tEnd = Format(Now + 360, "Short Date")
' Pick up the selected appointment's subject
strSubject = recAppt.Subject
'create the Restrict filter
sFilter = "[Start] >= '" & tStart & "'" & " And [End] 0 Then
CopyAttachments itm, newAppt
End If
newAppt.Save
Next
' Display the actual number of appointments created
MsgBox (iNumRestricted & " appointments were created"), vbOKOnly, "Convert Recurring Appointments"
Set itm = Nothing
Set newAppt = Nothing
Set ResItems = Nothing
Set CalItems = Nothing
Set CalFolder = Nothing
End Sub
Sub CopyAttachments(objSourceItem, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next
Set fldTemp = Nothing
Set fso = Nothing
End Sub
Diane Poremsky says
Are you trying to filter on the UDF? If you want to copy the fields, add them to the lines that create the new appt.
newappt.UserProperties("Custom1") = itm.UserProperties("Custom1")
Luis says
Thank you Diane,
We are making progress: now the appointments created by the macro contain the custom form.
Still, though, the values of the custom fields are not created: they are left blank.
This is the portion of your code to which I added the additional lines for custom class and fields:
Set newAppt = ActiveExplorer.CurrentFolder.Items.Add(olAppointmentItem)
'added class
newAppt.MessageClass = "IPM.Appointment.Activity"
newAppt.Start = itm.Start
newAppt.End = itm.End
newAppt.Mileage = itm.Mileage
newAppt.Subject = itm.Subject & " (Copy)"
newAppt.Body = itm.Body
newAppt.Location = itm.Location
newAppt.Categories = "Test Code, " & itm.Categories
newAppt.ReminderSet = False
'calling custom fields
newAppt.UserProperties("InvoiceTo") = itm.UserProperties("InvoiceTo")
Thanks for your help and patience!
Diane Poremsky says
I assume there is a .save there somewhere?
Also, it's cleaner to use with statement when you use an object multiple times like this. I wonder if it's because the field doesn't exist. Add a save before the custom field to read - the custom form will be set and the field should exist.
With newAppt
.MessageClass = "IPM.Appointment.Activity"
.Start = itm.Start
.End = itm.End
.Mileage = itm.Mileage
.Subject = itm.Subject & " (Copy)"
.Body = itm.Body
.Location = itm.Location
.Categories = "Test Code, " & itm.Categories
.ReminderSet = False
.Save
'calling custom fields
.UserProperties("InvoiceTo") = itm.UserProperties("InvoiceTo")
End with
Luis says
Thanks for your reply! I used this code but the custom fields are not copied. Actually I notice that if I open the individual appointments created by the macro, they are in the default Outlook format and they don't correspond to the custom form (even if I set it as default for the folder): not only the custom values are not copied, but I cannot even add them manually because the entire form is missing.
Could it be because I need to declare the custom form somewhere at the beginning of the macro...? Or specify the folder where the form is published?
I really appreciate your help with this!
Diane Poremsky says
You can add the fields, but will need to add the fields to the view to see the values. To change the form, you need to set the message class.
newAppt.MessageClass = IPM.Appointment.myform
You could call the template when you create the newappt, but changing the class is probably easier.
Luis says
Hello Diane,
Thanks for the great macro, it's a time saver!
Could you please help me to include custom fields so they don't get lost? Our appointments are created with a custom form. I tried to add these fields in the macro but I must got the syntax wrong: how can I call them?
Thanks a lot!
Diane Poremsky says
custom fields are copied like this:
newAppt.UserProperties("Custom4") = itm.UserProperties("Custom4")
Devin says
Hi. Thanks for the code. I actually am at this page to include the 'Sub CopyAttachments(...) into the 'Create a Task From Email' code you provided elsewhere. It throws a run-time error 424 ('object required') at:
'For Each objAtt In objSourceItem.Attachments'
It appears that the objAtt is not defined, and I can't see where this comes from. Could you help me with this? Thanks.
Diane Poremsky says
It doesn't need to be declared. Are objSourceItem & objTargetItem (or whatever you are passing to the sub) declared?
Sub CopyAttachments(objSourceItem, objTargetItem)
Van Knowles says
This a great macro, and very instructive to those of us who are sort of middling VBA coders.
In Outlook 2007, I was able to find the recurrence start date even in Day/Week/Month view by using the RecurrencePattern object:
Dim FocalItem As AppointmentItem
Dim FocalRecur As RecurrencePattern
...
Set FocalItem = Application.ActiveExplorer.Selection.Item(1)
Set FocalRecur = FocalItem.GetRecurrencePattern
' Pick up the Start Date of the selected appointment occurrence
tStart = Format(FocalRecur.PatternStartDate, "Short Date")
I have not tested this extensively, so maybe there are pitfalls I'm not aware of. I don't know which versions of Outlook include this object, but it exists and seems to work in 2007.
FYI
Dave Schmied says
Is there a way to include and update attendees of each recurrence? Or, is there some way to delete the original without sending a cancellation to attendees?
Diane Poremsky says
To delete the original without sending notification, set outlook offline and delete it. Let outlook send updates, delete the updates from the outbox.
You can open the appointment as an occurrence, make changes and send updates just for that date.
Bart Stouten says
Hi Diana,
Thank you for this beautiful macro. In Outlook 2010 I encountered a problem when the first word in the Subject was 'All'. Changing the sFilter line to
sFilter = "[Start] >= '" & tStart & "'" & " And [End] < '" & tEnd & "' And [IsRecurring] = True And [Subject] = """ & strSubject & """"
solved the problem.
totalflex says
Great macro, it does the job. Thank you for sharing it.
I have one simple question:
Is there a way to also copy "show as" value from the original recurring appointment to the copied one?
The free, out of office and busy are so meaningful for my particular case...
Diane Poremsky says
Yes, you can copy any field -
newAppt.BusyStatus= itm.BusyStatus
Eric says
Responding to Diane's response: I believe the correct name for this property is BusyStatus (I was not able to find a "ShowtimeAs" property in a live 2013 object model, or documented anywhere).
Diane Poremsky says
Correct. The name in the UI is show time as, the field name is BusyStatus. Have no idea why I wrote that - obviously wasn't thinking. :)
Ed Roberts says
Diane,
That did the trick. I re-ran the macro with the edited itm.subject line and everything looks just the way I wanted. Removing the messages with the appended subject lines was simple in View/List mode.
Thanks, again!
Ed
Ed Roberts says
This code worked perfectly in Outlook 2010 in converting a recurring appointment with many exceptions into individual appointments with all the exception information preserved. THANK YOU!!
This was truly a life saver and will gets lots of use.
The new appointment subjects are all appended with "(Copy)". Is there a global way of renaming a portion of the list view so that I can eliminate those extra characters (like find/replace perhaps)? I can find them easily enough with the Test Code category. Or would REMing the line "newAppt.Subject = itm.Subject & " (Copy)"" be easier?
Thanks, again.
Diane Poremsky says
You are on the right track - if you don't want that word in the subject, edit the subject line:
newAppt.Subject = itm.Subject
If you need to remove it from existing copies you created, I have a macro that can do it - remove the first batch you ran through the macro and rerun it.
Jonathan says
Thank you very much for the quick response. I tried the filter, but wasn't able to get it to work in Outlook 2007, either. About the same time, I made the realization that shifting to individual appointments won't solve the dilemma I have, and I abandoned the venture.
Thanks, again, for trying to help. I greatly appreciate it.
Jonathan says
Hi Diance,
Thank you for the post, but I've had some issues implementing this macro in my team's particular situation.
We have seven people making appointments for four training associates. We use a shared calendar on which we've partitioned out each day in 45-minute intervals for each associate's schedule. The training associate is invited to the meeting so that they receive any updates that are made to the appointment. The meetings are set to recur so that I didn't have to individually copy and invite each associate to each appointment each day.
Since implementing this system, I've discovered all the issues that arise out of relying on exceptions made to recurring appointments. I tried this macro, but we use Outlook 2007, and either none of the exceptions are copied, or everything is copied, including the copies, creating an infinite loop.
I presume the trouble boils down to the lack of the "IsRecurring" tag in 2007. Without it, Subject is the only limiting factor, and if you remove Subject, you open up everything to being copied.
To avoid that, is there some way to add a category limiter to the macro? I notice that the macro adds the category of "Test Code" to copied appointments. Is there some way I can tell the macro to ignore any appointment that has "Test Code" as a category?
Thank you very much.
P.S. I've tried a few times to export and import the calendar, as I know this both breaks up the series and also maintains exceptions, but the import has scrambled the calendar each time I've tried. Some appointments are fine, some are way off, and some just disappear into the ether.
Diane Poremsky says
This should work to restrict categories under one condition - you use either one category or enter the full category string as the category name 'text code, bill' exactly as it appears in the category field. Or if you use categories already, use [categories] = 'category name' and add a category to meetings you converted already.
sFilter = "[Start] >= '" & tStart & "'" & " And [End] < '" & tEnd & "' And [Categories] <> 'Test Code' And [Subject] = " & strSubject
But its not working for me in Outlook 2013.
Mark Laforest says
Hi Diane
Any progress?
Thanks
Mark.
Mark Laforest says
Hi Dianne
Howare you?
You may recall I started that threat about changing the end date on recurring Appointments in Outlook and the problems it creates with past Appointments (losing notes and attachments).
I think it prompted you to do this Macro.
Have you considered making it more user friendly?
My customers have no idea how to creat and run Macros. They just want to click a button and be asked a simple question like "What date range would you like to convert this series into single Appointments" and then for the program to do its bit.
Would you like to do that? Would you like to quote me to do that?
Thanks
Mark
Medical Business Systems.
Diane Poremsky says
I'll take a look at it.