A
Adam
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
them into a userform in Excel 2003,then when i selected the contact
and close the userform it then takes the same time to unload.
Can anyone advise me on any changes i can make in the code to speed
it
up!
Many thanks in advance
Regards
Adam
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
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
them into a userform in Excel 2003,then when i selected the contact
and close the userform it then takes the same time to unload.
Can anyone advise me on any changes i can make in the code to speed
it
up!
Many thanks in advance
Regards
Adam
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