Link userform to the outlook global address list

[maramiro]

Hello,
I have a userform and i m trying to link the contact dropbox of the userform to the outlook global adress list.
the following code doesnt give me the global adress list, it only provides me my personnel contact list.
Does anyone know how to twist the code to make it global instead of personnel.

Thank you

Private Sub UserForm_Initialize()
'Outlook objects.
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim olConItems As Outlook.Items
Dim olItem As Object

'Excel objects.
Dim wbBook As Workbook
Dim wsSheet As Worksheet

'Location in the imported contact list.
Dim lnContactCount As Long
Dim strDummy As String
'Turn off screen updating.
Application.ScreenUpdating = False
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Sheets("phonebook")

'Format the target worksheet.
With wsSheet
.Range("A1").CurrentRegion.Clear
.Cells(1, 1).Value = "Name"
.Cells(1, 2).Value = "Title"
With .Range("A1:F1")
.Font.Bold = True
.Font.ColorIndex = 10
.Font.Size = 11
End With
End With
wsSheet.Activate
'Initalize the Outlook variables with the MAPI namespace and the default Outlook folder of the current user.
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(10)
Set olConItems = olFolder.Items

'Row number to place the new information on; starts at 2 to avoid overwriting the header
lnContactCount = 2
'For each contact: if it is a business contact, write out the business info in the Excel worksheet;
For Each olItem In olConItems
If TypeName(olItem) = "ContactItem" Then
With olItem
If InStr(olItem.CompanyName, strDummy) > 0 Then
Cells(lnContactCount, 1).Value = .LastNameAndFirstName
Cells(lnContactCount, 2).Value = .JobTitle

End If
End With
lnContactCount = lnContactCount + 1
End If
Next olItem
'Null out the variables.
Set olItem = Nothing
Set olConItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
'Sort the rows alphabetically using the CompanyName or FullName as appropriate, and then autofit.
With wsSheet
.Range("A2", Cells(2, 6).End(xlDown)).Sort key1:=Range("A2"), order1:=xlAscending
.Range("A:B").EntireColumn.AutoFit
End With
'Turn screen updating back on.
Application.ScreenUpdating = True
Worksheets("MENU").Select

End Sub

 

[Andrew Poulsom]

That implies that you don't have CDO installed:

http://support.microsoft.com/kb/171440/en-us

 

[maramiro]

Can i install it?? Is there any other code that could be used for the same purpose?

 

[Andrew Poulsom]

Maybe this will help you:

http://www.mrexcel.com/forum/showthread.php?561991-Extract-outlook-contact-properties

 

[maramiro]

this code is actually working when i do it as it on the sheet 1 combobox.
but instead of creating the code on the combobox of sheet1 ,
I would like to do it on my userform combobox.
my combobox is called "ownerbox" in the userform.
Thanks a lot

Sub GetFromGlobalAddressList()
'write the default Outlook contact name list to the active worksheet
Dim OlApp As Object
Dim OlList As Object
Dim OlAds As Object
Dim Larray() As String
Dim i As Long
Set OlApp = CreateObject("Outlook.Application")
Set OlList = OlApp.GetNamespace("MAPI").AddressLists("Global Address List")
Set OlAds = OlList.AddressEntries
With Sheet1.ComboBox1
.Clear 'clear old address list
ReDim Larray(OlAds.Count)
For i = 1 To OlAds.Count
Larray(i) = OlAds(i)
Next i
.List() = Larray
End With
Set OlApp = Nothing
End Sub

 

[Andrew Poulsom]

Can't you modify that code and put it in your UserForm_Initialize event procedure?

 

[maramiro]

THANK YOU SOOO SOO MUCH FOR YOUR HELP AND PATIENCE !!
its all working now.