Display data in a combo box

[Oggy]

I have a userform with a combo box, i am trying to get the combobox to
display external data from outlook, objcontacts. I have no idea how to
achieve this, please help.

 

[Norman Jones]

Hi Oggy,

Try something like:

'=============>>
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

Me.ComboBox1.Clear

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

For i = 1 To oContactItems.Count
If oContactItems.Item(i).Class = olContact Then
Set oContact = oContactItems.Item(i)
Me.ComboBox1.AddItem oContact.FullName
End If
Next
Me.ComboBox1.ListIndex = 0

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


Set a reference to the Microsoft Outlook xx Object Library:

In the VBE,

Tools | References| Locate and select the library.

 

[Oggy]

Thanks Norman, it work perfect. I lost sleep on this!

can you please advise me how to add there address and telephone numbers


Many thanks again

Regards
Oggy

 

[Norman Jones]

Hi Oggy,

Perhaps try adding a ListBox and try something like:

'=============>>
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.ListBox1
.ColumnCount = 3
.ColumnWidths = "90 pt;72 pt;90 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)
j = j + 1
ReDim Preserve arr(0 To 2, 1 To j)
With oContact
arr(0, j) = .FullName
arr(1, j) = .HomeAddress
arr(2, j) = .HomeTelephoneNumber
End With
End If
Next i

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

End With

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

 

[Oggy]

Hi Norman, You are brilliant, it works a treat. can this be done in a
combobox. What i am trying to achieve is search for a name (the
combobox lists as you enter the letters) and see the address on my
selection then upon selection enter it into excel speadsheet.

Sorry to be a pain, i owe you a drink

regards

Oggy

 

[Norman Jones]

Hi Oggy,

Retaining the ListBox, add a CommandButton and the
following code:

'=============>>
Private Sub CommandButton1_Click()
Dim SH As Worksheet
Dim destRng As Range

Set SH = ThisWorkbook.Sheets("Sheet1") '<<=== CHANGE

Set destRng = SH.Range("A" & Rows.Count).End(xlUp)(2)
With Me.ListBox1
destRng.Value = .List(.ListIndex, 0)
destRng(1, 2).Value = .List(.ListIndex, 1)
destRng(1, 2).Value = .List(.ListIndex, 2)
End With
End Sub
'<<=============

 

[Oggy]

Hi Norman,

Many thanks for all help, that worked a treat, its very clever stuff.
I have alot of contacts split up by catogerys. Is there a way i can
pull in the outlook contacts by catogery so that i am not loading all
of my contacts.


Many thanks again

Regards

Ian

 

[Norman Jones]

Hi Oggy,

'---------------
I have alot of contacts split up by catogerys. Is there a way i can
pull in the outlook contacts by catogery so that i am not loading all
of my contacts.

'---------------

Try something like:

'=============>>
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.ListBox1
.ColumnCount = 3
.ColumnWidths = "90 pt;72 pt;90 pt"
.TextColumn = -1
.MultiSelect = fmMultiSelectSingle
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 = "Personal" Then '<<=== CHANGE
j = j + 1
ReDim Preserve arr(0 To 2, 1 To j)
With oContact
arr(0, j) = .FullName
arr(1, j) = .HomeAddress
arr(2, j) = .HomeTelephoneNumber
End With
End If
End If
Next i

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

End With

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

 

[Oggy]

Thanks Norman you have done it again!

One final thing, then i promise to leave you alone, When i pull in the
address i get the carriage return characters, how do i get rid of them?

Regards

Oggy

 

[Norman Jones]

Hi Oggy,

One final thing, then i promise to leave you alone, When i pull in the
address i get the carriage return characters, how do i get rid of them?

Try:

'=============>>
Private Sub CommandButton1_Click()
Dim SH As Worksheet
Dim destRng As Range

Set SH = ThisWorkbook.Sheets("Sheet1") '<<=== CHANGE

Set destRng = SH.Range("A" & Rows.Count).End(xlUp)(2)
With Me.ListBox1
destRng.Value = .List(.ListIndex, 0)
destRng(1, 2).Value = _
Replace(.List(.ListIndex, 1), Chr(13), "", 1)
destRng(1, 3).Value = _
Replace(.List(.ListIndex, 2), Chr(13), "", 1)
End With
End Sub
'<<=============