Sub CreateNewBirthdayForAllContacts()
    Dim olApp               As Outlook.Application
    Dim nspNameSpace        As Outlook.NameSpace
    Dim fldContacts         As Outlook.MAPIFolder
    ' Get reference to the Outlook Contacts folder.
    Set olApp = New Outlook.Application
    Set nspNameSpace = olApp.GetNamespace("MAPI")
    Set fldContacts = nspNameSpace.GetDefaultFolder(olFolderContacts)
   
    Counter = GetAllContacts(fldContacts)
    MsgBox Counter & _
         " birthday items has been created."
End Sub
Function CreateNewBirthday(personName As String, birthday As Date)
    Dim olApp As Outlook.Application
    Dim olNewBirthday As Outlook.AppointmentItem
    Set olApp = New Outlook.Application
    Set olNewBirthday = olApp.CreateItem(olAppointmentItem)
   
    ' #### USER OPTIONS ####
    ' remind me of birthdays XX days before
    intDays = 1.5
    Dim iRec As RecurrencePattern
   
    With olNewBirthday
        .start = birthday
        .AllDayEvent = True
        .Subject = personName & " 的 " & "生日"
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 24 * 60 * intDays
        Set iRec = .GetRecurrencePattern()
        With iRec
            .RecurrenceType = olRecursYearly
        End With
        .Save
    End With
End Function
Function CreateNewBirthdayFromContact(theContact As ContactItem)
    Dim olApp As Outlook.Application
    Dim olNewBirthday As Outlook.AppointmentItem
    Set olApp = New Outlook.Application
    Set olNewBirthday = olApp.CreateItem(olAppointmentItem)
   
    ' #### USER OPTIONS ####
    ' remind me of birthdays XX days before
    intDays = 1.5
    Dim iRec As RecurrencePattern
   
    With olNewBirthday
        .start = theContact.birthday
        .AllDayEvent = True
        .Subject = theContact.FullName & " 的 " & "生日"
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 24 * 60 * intDays
        .Links.Add theContact
        Set iRec = .GetRecurrencePattern()
        With iRec
            .RecurrenceType = olRecursYearly
        End With
        .Save
    End With
End Function
	
Function GetAllContacts(fldContacts As MAPIFolder) As Integer
    Dim subfolders          As Outlook.Folders
    Dim objContacts         As Object
    Dim objContact          As Object
    Dim avarContactsArray() As Variant
    Dim Counter             As Integer
   
    ' Restrict the contact items to those that have an entry in
    ' the birthday field.
    Set objContacts = fldContacts.items _
       .Restrict("[Birthday] <> ''")
      
    ' Resize the array to the number of Outlook Contacts.
    Counter = objContacts.Count
    If Counter > 0 Then
        ReDim avarContactsArray(Counter - 1)
    End If
   
    For Each objContact In objContacts
            'MsgBox objContact.FullName
            'CreateNewBirthday objContact.FullName, objContact.birthday
            CreateNewBirthdayFromContact objContact
    Next objContact
   
    'recursive readding subfolder
    Dim subfolder As Outlook.MAPIFolder
    Dim subCounter  As Integer
    Set subfolders = fldContacts.Folders
    For Each subfolder In subfolders
        subCounter = GetAllContacts(subfolder)
        'MsgBox subfolder.Name & subCounter
        Counter = Counter + subCounter
    Next
   
    GetAllContacts = Counter
End Function