News Forum Phone database

> New Topic
> Reply
< Esato Forum Index > Sony Ericsson / Sony > General > Partial Solution for Recurring appointments in Outlook & T610 Bookmark topic

Hi
I use Outlook as my email and contacts management. I used to find it irritating that Outlook never sends the birthdays and anniversaries to my T610. When BB said that the K700 also would not support them, I decided to write a small macro to overcome this problem.
What the macro basically does is take the birthday and anniversary fields from the Contacts and saves them as a non recurring appointment. I have attached the text file which contains the code for the macro

Instructions.
1. Start Outlook. Go to Tools->Macro->Visual Basic Editor
2. In the Editor select ThisOutlookSession and paste the Code
3. Press F5.
4. Check the calendar folder. The birthdays and anniversaries should have been added.

Please understand that this works for me, but I suggest you take a backup and try this macro.

You can always convert recurrring appointments to non recurring appointments based on this. So that some pseudo solution could be found.

Hope this helps. And bouquets and brickbats are welcome.

Kiran
Code Starts
'This runs the macro When Outlook starts up.
Private Sub Application_Startup()
Call ConvertBAtoAppt
End Sub
'Code to convert Birthdays and Appointments in Outlook's default Contacts Folder into an appointment'
Sub ConvertBAtoAppt()
Dim objOL As Application
Dim objNS As NameSpace
Dim strSubjectBirthday As String
Dim strSubjectAnniversary As String
Dim dteStart As Date
Dim colContact As Items
Dim objContact As ContactItem
Dim objContactFolder As MAPIFolder
Dim dteContactBirthday As Date
Dim colCalender As Items
Dim objAppts As AppointmentItem
Dim objCalenderFolder As MAPIFolder
Dim dteMonth As Long
Dim dteDay As Long
Dim dteNew As Date
Dim i As Integer
Dim j As Integer

'Set the Default PST (Outlook Folder) and Set the Contacts Folder
Set objOL = CreateObject("Outlook.Application")
Set objNS = objOL.GetNamespace("MAPI")
Set objContactFolder = objNS.GetDefaultFolder(olFolderContacts)
Set colContact = objContactFolder.Items
Set objCalenderFolder = objNS.GetDefaultFolder(olFolderCalendar)
Set colCalender = objCalenderFolder.Items
strSubjectBirthday = "'s Birthday"
strSubjectAnniversary = "'s Anniversary"
dteNew = CDate("1/1/4501")

'Start processing contact details
For i = colContact.Count To 1 Step -1
Set objContact = colContact.Item(i)

'Create new Appointments for Birthday
If objContact.Birthday dteNew Then
Set objContact = colContact.Item(i)
dteContactBirthday = CDate(objContact.Birthday)
dteDay = Day(dteContactBirthday)
dteMonth = Month(dteContactBirthday)
Set objAppts = objOL.CreateItem(olAppointmentItem)
With objAppts
.Subject = objContact + strSubjectBirthday
dteStart = _
GetNextYearlyOccurrence(Date, _
dteDay, _
dteMonth)
.Start = DateAdd("d", _
-objAppts.ReminderMinutesBeforeStart / (60 * 24), _
dteStart)
.Duration = 1439
.ReminderSet = True
End With
For j = 1 To colCalender.Count
If objAppts.Subject = colCalender.Item(j) Then colCalender.Item(j).Delete
Next
objAppts.Save
End If
'Create new Appointment for Anniversary
If objContact.Anniversary dteNew Then
dteContactBirthday = CDate(objContact.Anniversary)
dteDay = Day(objContact.Anniversary)
dteMonth = Month(objContact.Anniversary)
Set objAppts = objOL.CreateItem(olAppointmentItem)
With objAppts
.Subject = objContact + strSubjectAnniversary
dteStart = _
GetNextYearlyOccurrence(Date, _
dteDay, _
dteMonth)
.Start = DateAdd("d", _
-objAppts.ReminderMinutesBeforeStart / (60 * 24), _
dteStart)
.Duration = 1439
.ReminderSet = True
End With
For j = 1 To colCalender.Count
If objAppts.Subject = colCalender.Item(j) Then colCalender.Item(j).Delete
Next
objAppts.Save
End If
Next
Set objOL = Nothing
Set objNS = Nothing
Set objContact = Nothing
Set colContact = 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) dteOcc = DateSerial(intYear + 1, lngMonth, lngDay)
End If
GetNextYearlyOccurrence = dteOcc
End Function
--
Posted: 2004-05-23 11:16:52
Edit : Quote

---

New Topic   Reply

Forum Index