Applies to Microsoft Outlook 2010, Outlook 2007, Outlook 2003, Outlook 2002
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.
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