LISTING 1: Code to Convert Annually Recurring Appointments to Tasks

Sub ConvertYearlyApptToTask()
    Dim objOL As Application
    Dim objNS As NameSpace
    Dim objCalendar As MAPIFolder
    Dim colAppts As Items
    Dim colRecurAppts As Items
    Dim strRestrict As String
    Dim objAppt As AppointmentItem
    Dim objApptRecur As RecurrencePattern
    Dim strSubject As String
    Dim objTask As TaskItem
    Dim objTaskRecur As RecurrencePattern
    Dim dteStart As Date
    Dim i As Integer
   
    ' get all recurring appointments
    Set objOL = CreateObject("Outlook.Application")
    Set objNS = objOL.GetNamespace("MAPI")
    Set objCalendar = objNS.GetDefaultFolder(olFolderCalendar)
    Set colAppts = objCalendar.Items
Begin Callout A
    strRestrict = "[IsRecurring] = True"
    Set colRecurAppts = colAppts.Restrict(strRestrict)
End Callout A
    For i = colRecurAppts.Count To 1 Step -1
        Set objAppt = colRecurAppts.Item(i)
        ' check for yearly recurrences
Begin callout B
        Set objApptRecur = objAppt.GetRecurrencePattern
End callout B
        If objApptRecur.RecurrenceType = olRecursYearly Then
            Set objTask = objOL.CreateItem(olTaskItem)
            If InStr(1, objAppt.Subject, "Birthday", vbTextCompare) = 0 And _
               InStr(1, objAppt.Subject, "Anniversary", vbTextCompare) = 0 Then
                With objTask
                    .Subject = objAppt.Subject
                    dteStart = _
                            GetNextYearlyOccurrence(Date, _
                              objApptRecur.DayOfMonth, _
                              objApptRecur.MonthOfYear)
                    .StartDate = DateAdd("d", _
                                 -objAppt.ReminderMinutesBeforeStart / (60 * 24), _
                                 dteStart)
                    .DueDate = dteStart
                    .ReminderSet = True
                    .ReminderTime = .StartDate
                                       
Begin callout C
                    Set objTaskRecur = objTask.GetRecurrencePattern
                    With objTaskRecur
                        .RecurrenceType = olRecursYearly
                        .DayOfMonth = Day(objTask.StartDate)
                        .MonthOfYear = Month(objTask.StartDate)
                        If objApptRecur.NoEndDate Then
                            objTaskRecur.NoEndDate = True
                        Else
                            .PatternEndDate = objApptRecur.PatternEndDate
                            .Occurrences = objApptRecur.Occurrences
                        End If
                    End With
End callout C
                    .Save
                End With
                objAppt.Delete
            End If
        End If
    Next
   
    Set objOL = Nothing
    Set objNS = Nothing
    Set objCalendar = Nothing
    Set colAppts = Nothing
    Set colRecurAppts = Nothing
    Set objAppt = Nothing
    Set objTask = Nothing
    Set objApptRecur = Nothing
    Set objTaskRecur = Nothing
End Sub

Function GetNextYearlyOccurrence(dteDate As Date, lngDay As Long, lngMonth As Long)
    Dim intYear As Integer
    Dim dteOcc As Date
    intYear = Year(dteDate)
    dteOcc = DateSerial(intYear, lngMonth, lngDay)
    If DateDiff("d", dteDate, dteOcc) < 0 Then
        dteOcc = DateSerial(intYear + 1, lngMonth, lngDay)
    End If
    GetNextYearlyOccurrence = dteOcc
End Function