not surprised the process slow with
ReDim Preserve arr(0 To 2, 1 To j)
for each J change the ReDim is expensive

why not estimate the size of the 2nd dimension let say jsize set to 200 and
redim with 30 to 50% increase when j = jsize
"Ken Slovak - [MVP - Outlook]" wrote in message
...
Apply the SetColumns method to that Items collection and set only the
columns you want loaded. When done use ResetColumns to return to normal.
See
the Object Browser Help for sample code for SetColumns.

--
Ken Slovak
[MVP - Outlook]
http://www.slovaktech.com
Author: Absolute Beginner's Guide to Microsoft Office Outlook 2003
Reminder Manager, Extended Reminders, Attachment Options
http://www.slovaktech.com/products.htm


"Oggy" wrote in message
ups.com...
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