Synchronizacja -> Nokia 6300,FS N560,Outlook a wpisy w kalendarzu

Witajcie.
Za pomocą laptopa wyposażonego w bluetooth synchronizuje z nim telefon komórkowy Nokie 6300 oraz swojego pocketa FS N560 także za pomocą bluetooth. Jeśli chodzi o sama synchronizację i połączenie nie mam z tym żadnych problemów.
Natomiast chodzi mi o synchronizację kontaktów.

Otóż kiedy w kontaktach w programie Outlook lub edytując kontakt z poziomu kontaktów w pockecie i nadając komuś datę urodzin to takowa pojawia mi się w kalendarzu. "Urodziny należą do...".

Po zsynchronizowaniu wszystkich urządzeń wszystkie w swoich kalendarzach posiadają taki wpis.

Natomiast jeśli w telefonie edytuje kontakt i dopisuję do danej osoby datę urodzin to....
Oczywiście w szczegółach kontaktu w outlook lub tych z pocketa widać wpisaną poprawnie datę urodzin natomiast informacja
ta nie ma swojego odzwierciedlenia w kalendarzu na czym mi bardzo zależy.

Dlatego zwracam się do kolegów i koleżanek czy jest jakiś sposób na rozwiązanie mojego problemu?


Zauważyłem, że jeśli z takiego kontaktu w outlooku wytnę datę urodzin (ctrl+x ) zapisze zmiany w kontakcie
po czym ponownie wkleję to wpis pojawia się w kalendarzu.

Może ktoś potrafiłby zrobić takie makro?

Witajcie.
Na innym forum związanym z programem outlook zwróciłem się z tym samym problemem.
Pewna bardzo życzliwa osoba napisała mi gotowca. Działa super.
Przekazuje tą wiedzę wam może się komuś przyda.

Pozdrawiam.

Oto makro:

Public Sub AddBirthdays()
    On Error Resume Next

    Dim oContactFolder As Folder
    Set oContactFolder = Session.GetDefaultFolder(olFolderContacts)
   
    Dim oCalendarFolder As Folder
    Set oCalendarFolder = Session.GetDefaultFolder(olFolderCalendar)
   
    Dim item As ContactItem
    For Each item In oContactFolder.Items
       
        Dim oContact As ContactItem
        Set oContact = item
       
        Dim dtBirthday: dtBirthday = oContact.Birthday
        If dtBirthday <> FormatDateTime("4501-01-01", vbShortDate) Then
           
            strStart = """" & FormatDateTime(oContact.Birthday, vbShortDate) & " " & FormatDateTime(oContact.Birthday, vbShortTime) & """"
            strEnd = """" & FormatDateTime(oContact.Birthday, vbShortDate) & " " & FormatDateTime(oContact.Birthday, vbShortTime) & """"
           
            Dim strFilter
            strFilter = "[Start] <= " & strEnd & " AND [End] > " & strStart
           
            Dim oItems As Items
            Set oItems = oCalendarFolder.Items
           
            Dim oAppt As AppointmentItem
            Set oAppt = oItems.Find(strFilter)
           
            Dim bPresent: bPresent = False
            While Not oAppt Is Nothing
               
                Dim strDestSubject: strDestSubject = "Urodziny należy do: " & oContact.Subject
               
                If oAppt.Subject = strDestSubject Then
                    bPresent = True
                End If
               
                Set oAppt = oItems.FindNext
            Wend
           
            If bPresent = False Then
               
                Set objAppt = oItems.Add
                If Not objAppt Is Nothing Then
               
                    With objAppt
                        .Subject = "Urodziny należy do: " & oContact.Subject
                        .Start = oContact.Birthday
                        .AllDayEvent = True
                        .ReminderSet = True
                    End With
                   
                    Set objRP = objAppt.GetRecurrencePattern
                    With objRP
                        .RecurrenceType = olRecursYearly
                        .DayOfMonth = Day(oContact.Birthday)
                        .MonthOfYear = Month(oContact.Birthday)
                        .PatternStartDate = objAppt.Start
                    End With
                   
                    objAppt.Save
               
                End If
            End If
        End If
    Next

End Sub