Slow to load contacts!

[Oggy]

Hi,

I have the following code that gets my contacts from outlook and
lists them in a listbox on a form to select one.


My problem is i have about 1000 contacts and it takes a while to load,
then when i close the userform it then takes the same time to unload.

When i load them up in outlook its instant.

Does anyone know what i can change to speed it up,

Regards


Oggy


Private Sub UserForm_Initialize()
Dim olApp As Outlook.Application
Dim oContact As Outlook.ContactItem
Dim oContactFolder As Outlook.MAPIFolder
Dim oContactItems As Outlook.Items
Dim oNS As Outlook.Namespace
Dim i As Long
Dim j As Long
Dim arr()


With Me.ComboBox1
.ColumnCount = 3
.ColumnWidths = "175 pt;150 pt;200 pt"
.TextColumn = -1


End With


On Error GoTo XIT
Set olApp = New Outlook.Application
Set oNS = olApp.GetNamespace("MAPI")
Set oContactFolder = oNS.GetDefaultFolder(olFolderContacts)
Set oContactItems = oContactFolder.Items


With Me
For i = 1 To oContactItems.Count
If oContactItems.Item(i).Class = olContact Then
Set oContact = oContactItems.Item(i)
If oContact.Categories = "Customer " Then
j = j + 1
ReDim Preserve arr(0 To 2, 1 To j)
With oContact
arr(0, j) = .CompanyName
arr(1, j) = .FullName
arr(2, j) = .BusinessAddress
End With
End If
End If
Next i


Me.ComboBox1.List() = Application.Transpose(arr)


End With


XIT:
Set oContact = Nothing
Set oContactItems = Nothing
Set oContactFolder = Nothing
Set oNS = Nothing
Set olApp = Nothing
End Sub

 

[NickHK]

Outlook would of course be faster, because you are working the same process.
In Excel, there will be some delay for data transfer.
One thing you can do is not redim on every iteration, but in blocks. You can
adjust the value of INC, depending on you expected number of entries.
Also, probably good to ReDim down at the end, to remove any used elements.

Const INC As Long = 50

ReDim Preserve arr(0 To 2, 1 To INC)

For i = 1 To oContactItems.Count
If oContactItems.Item(i).Class = olContact Then
Set oContact = oContactItems.Item(i)
If oContact.Categories = "Customer " Then
j = j + 1
'ReDim Preserve arr(0 To 2, 1 To j)
With oContact
arr(0, j) = .CompanyName
arr(1, j) = .FullName
arr(2, j) = .BusinessAddress
End With
If j = UBound(arr, 2) Then
ReDim Preserve arr(0 To 2, 1 To UBound(arr, 2) + INC)
End If
End If
End If
Next i

End Sub

I can't say if this is most efficient way to work with Outlook objects.
Also, I notice that you have a 0-based 1st dimension, but a 1-based 2nd
dimension. Just seems inconsistent to me...

NickHK