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 Dim objItems As Outlook.Items Dim oPattern As RecurrencePattern ' Use the selected calendar folder Set CalFolder = Application.ActiveExplorer.CurrentFolder Set objItems = CalFolder.Items For Each objAppt In objItems If objAppt.IsRecurring = True Then Set recAppt = objAppt ' 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 End If 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