Contactitem collection

[SNick1974]

I have a sub in my program to display all the contacts from a public folder. My problem is the performance. Some of company branch have more than 1000 mixed items in a folder (mails, contacts, ...). This is taking more than 60 seconds to get the result . Any idea to decrease the responds time will be appreciate.

Set olObject = olItems.GetFirst
 
' For i = 1 To olItems.Count
    While Not (TypeName(olObject) = "Nothing")
    
        If olObject.Class = Outlook.olContact Then
' Set olSafeContactItem = New Redemption.SafeContactItem
' olSafeContactItem.Item = olObject
            
            Set olContactItem = olObject
' With olSafeContactItem
            With olContactItem
                If optAffichageContacts(mcOptCourriel).Value = True Then
                    If .Email1Address <> "" Then
                        Set itmListItem = lvwContactsPublics.ListItems.Add(, .EntryID, .FullName, , mcIconOutlookContact)
                        Call itmListItem.ListSubItems.Add(, , .Email1Address)
                        Call itmListItem.ListSubItems.Add(, , .CompanyName)
                    End If
                Else
                    If .BusinessFaxNumber <> "" Then
                        Set itmListItem = lvwContactsPublics.ListItems.Add(, .EntryID, .FullName, , mcIconOutlookContact)
                        Call itmListItem.ListSubItems.Add(, , .BusinessFaxNumber)
                        Call itmListItem.ListSubItems.Add(, , .CompanyName)
                    End If
                End If
            End With
        End If
    
        Set olObject = olItems.GetNext
    
    Wend
    'Next i