Consulting

Results 1 to 1 of 1

Thread: Improve Filtering Calendar

  1. #1
    VBAX Newbie
    Joined
    Dec 2014
    Posts
    1
    Location

    Improve Filtering Calendar

    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
    Last edited by lpsquall; 12-24-2014 at 09:55 AM.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •