Improve Filtering Calendar

[lpsquall]

Hi all and happy holidays. I've been working on the code below for a few days now. I gathered most of it from various posts online. The code below is working however, it takes a long time to complete. I was wondering if someone can help me improve the code. This macro performs the following:

1. We import contacts to a sub contacts folder every hour. These contacts have birthdays that do not get added to the outlook calendar. The macro re saves the contacts which causes the birthday to appear as an all day event on the calendar.
2. The macro then looks at all the calendar items to see if it finds an appointment with the word Birthday in the subject line. If it finds the appointment, it will confirm that if the contact still exists in the contact folder. If the contact exists, it will associate a category to the appointment and save the appointment. If it doesn't find the contact, it will remove the appointment only if it was a part of the category specified.

The problem is that it is searching through all the calendar entries for the word "Birthday" and also verifying if the appointment subject line matches the contact name which causes the marco to take a long time to complete. I was reading online about using restrict and collections but I am a beginner in coding and I am not sure how to include it in the code. Furthermore, I am not looking to utilize a date range since I am working with birthdays. I believe the best approach is to try and filter by all day appointment but I am not sure how to proceed. Any help would be greatly appreciated. I am surprised I got this far and I am close to the finish line. Please help me get there. Thanks in advance for those who look at the code.


Public Sub PutBirthdaysInCalendar()
Dim OutApp As Object, oApptFolder As MAPIFolder, KonktactName$
Dim oContact As ContactItem, temp1
Dim oCalFolder As MAPIFolder, jest As Boolean, x&, n&
Dim oAppoitment As AppointmentItem, temp
Dim sMsg As String
Dim bMsg As String
Dim i As Integer
Dim b As Integer
Dim c As Integer
Dim a As Integer
Set oCalFolder = Session.GetDefaultFolder(olFolderCalendar)
Set oApptFolder = Session.GetDefaultFolder(olFolderContacts).Folders("bdaytest")
sMsg = "Scanning Contacts..."
bMsg = "Updating Contacts Birthday's..."
i = 1
b = 1
a = 0
c = oApptFolder.Items.Count

ProgressBox.ShowPercent = True
ProgressBox.Increment a, sMsg
ProgressBox.Show
On Error GoTo koniec
For n = oApptFolder.Items.Count To 1 Step -1
If oApptFolder.Items(n).Class = oApptFolder.Items.Count Then Exit For
Set oContact = oApptFolder.Items(n)
Debug.Print oContact.FullName
If Year(oContact.Birthday) < 5000 Then
i = 1 + i
oContact.FullName = oContact.LastName & ", " & oContact.FirstName
temp1 = oContact.Birthday
oContact.Birthday = FormatDateTime("01-01-3001", vbShortDate)
oContact.Birthday = temp1
oContact.Save
End If
a = (i / c) * 100
ProgressBox.Increment a, sMsg
Debug.Print i
Next

Unload ProgressBox
ProgressBox.Hide
ProgressBox.ShowPercent = True
ProgressBox.Increment b, bMsg
ProgressBox.Show
For Each oAppoitment In oCalFolder.Items
DoEvents
With oAppoitment
If .AllDayEvent = True And _
.IsRecurring = True And _
.subject Like "*Birthday" Then 'subject in your lang (change it)
KonktactName = .subject
KonktactName = Replace(.subject, "'s Birthday", "")
Debug.Print KonktactName 'list of birthdays in immediate window [Ctrl+G]
jest = False
For x = oApptFolder.Items.Count To 1 Step -1
If oApptFolder.Items(x).Class <> 40 Then Exit For
Set oContact = oApptFolder.Items(x)
Debug.Print oContact.FirstName & " " & oContact.LastName
If oContact.FirstName & " " & oContact.LastName = KonktactName Then
jest = True
oAppoitment.Categories = "testcategory"
oAppoitment.Save
Exit For
End If
Next
If jest = False And _
oAppoitment.Categories = "testcategory" Then .Delete 'delete this appointment (move it to trash)
End If
End With
b = b + 1
ProgressBox.Increment b, bMsg
Next
koniec:
Unload ProgressBox
ProgressBox.Hide
End Sub