Outlook Update Birthday

Sub update_birthday()


    Dim app As Outlook.Application
    Set app = CreateObject("Outlook.Application")

    Dim ns As Outlook.NameSpace
    Set ns = app.GetNamespace("MAPI")
    ns.Logon

    Dim contacts As Outlook.MAPIFolder
    Set contacts = ns.GetDefaultFolder(olFolderContacts)

    Dim obj As Object
    Dim contact As Outlook.ContactItem
    For Each obj In contacts.Items
        If TypeName(obj) = "ContactItem" Then
            Set contact = obj
            If contact.Birthday <> DateValue("1/1/4501") Then
                Dim d As Date
                d = contact.Birthday
                contact.Birthday = DateValue("1/1/4501")
                contact.Save
                contact.Birthday = d
                contact.Save
            End If
        End If
    Next
    Beep

End Sub