Outlook address book in Excel

[pliant]

I have an excel sheet where users need to enter email addresses...is there any way to have their Outlook address book come up in Excel so the can simply select the addresses from there and have the selected addresses appear in the Excel sheet cell?

 

[pliant]

I am now using this to retrieve an address list but am having a few problems:

Private Sub GetOutlookAddressBook()
  
' Need to add reference to Outlook
'(In VBA editor Tools References MS Outlook #.# Library)
' Adds addresses to existing Sheet called Address and
' defines name Addresses containing this list
' For use with data Validation ListBox (Source as =Addresses)

On Error GoTo error
  
  Dim objOutlook As Outlook.Application
  Dim objAddressList As Outlook.AddressList
  Dim objAddressEntry As Outlook.AddressEntry
  Dim intCounter As Integer
  
  ' Setup connection to Outlook application
  Set objOutlook = CreateObject("Outlook.Application")
  Set objAddressList = objOutlook.Session.AddressLists("Contacts")
  
  Application.EnableEvents = False
     
  ' Clear existing list
  Sheets("Address").Range("A:A").Clear
       
  'Step through each contact and list each that has an email address
  For Each objAddressEntry In objAddressList.AddressEntries
     If objAddressEntry.Address <> "" Then
        intCounter = intCounter + 1
        Application.StatusBar = "Address no. " & intCounter & " ... " & objAddressEntry.Address
        Sheets("Address").Cells(intCounter, 1) = objAddressEntry.Address
        DoEvents
    End If
  Next objAddressEntry
  
  ' Define range called "Addresses" to the list of emails
  Sheets("Address").Cells(1, 1).Resize(intCounter, 1).Name = "Addresses"
error:
  Set objOutlook = Nothing
  Application.StatusBar = False
  Application.EnableEvents = False
End Sub

I want to retrieve addresses from a Global Address List (GAL) so i can't use "Contacts":
Set objAddressList = objOutlook.Session.AddressLists("Contacts")

The address list i want to access is a under a few subheadings:

Global Address List
Enterprise
   Messaging1
       Recipients
   Message2
       Recipients
           -addresses-

If i just use "Recipients" it returns the Message1 Recipients but they are in the format :
/o=XYZ Corporation/ou=ae/cn=Recipients/cn=john Mcenzie

Is there any way to get the Message2 Recipients and get them to the format:
John Mcenzie john@xyz.com

 

[pliant]

no help on this?

 

[pliant]

ok some more info:

  Dim objOutlook As Outlook.Application
  Dim objAddressList As Outlook.AddressList
  Dim objAddressEntry As Outlook.AddressEntry
  Dim intCounter As Integer
  Dim counter As Integer
  Dim addrCount As Integer
  
  ' Setup connection to Outlook application
  Set objOutlook = CreateObject("Outlook.Application")
  Set objAddressList = objOutlook.Session.AddressLists("Global Address List")
  
  'number of address lists in Global Address List
  addrCount = objOutlook.Session.AddressLists.Count
  MsgBox ("addrCount = " & addrCount)
  
  'print out the name of each address list in column
  For Each objAddressList In objOutlook.Session.AddressLists
    counter = counter + 1
    Sheets("Address").Cells(counter, 2) = objAddressList.Name
  Next objAddressList

By using the above i was able to determine that the index of the address list i wish to make use of is 526 so i can use the following to obtain a list of the addresses in it:

Set objAddressList = objOutlook.Session.AddressLists(526)

 For Each objAddressEntry In objAddressList.AddressEntries
        intCounter = intCounter + 1
        Sheets("Address").Cells(intCounter, 1) = objAddressEntry.Name               
        DoEvents
  Next objAddressEntry

However, if an address list is added to or deleted from the Global Address List this index number will change and the results will no longer be accurate. However, i can't specify the name of the address list due the problem listed above (duplicate address list names in different locations)

Is there a more reliable way to reference the address list than through using the index number??

 

[pliant]

Ok i found a more reliable way from someone on a different board. They suggested using the unique ID in case anyone here is interested.

Obtain the unique address id using:
Dim AddressID as String
AddressID = objOutlook.Session.AddressLists(526).ID
msgbox (AddressID)

Then search for that ID in the list of addresses lists and then retrieve the address entries from that address list:

For Each objAddressList In objOutlook.Session.AddressLists
   If  objAddressList.ID = "00000000DCA740C8C042101AB4B908002B2FE18201000000000100002F6F3D456E7465  7270726973652F6F753D4B4E412043616E616461204D6573736167696E672F636E3D45  78557365727300" Then
       For Each objAddressEntry In objAddressList.AddressEntries
           intCounter = intCounter + 1
           Sheets("Test" ).Cells(intCounter, 1) = objAddressEntry.Name
           DoEvents
       Next
   End If
 Next objAddressList

However, I've discovered this code will only work when Outlook is opened. If Outlook is not opened then the above code should not be preformed. Is there any code to use to detect if Outlook is open or not?

 

[Juan Pablo González]

Something like

On Error Resume Next
If GetObject(, "Outlook.Application") Is Nothing Then
  'Outlook is not running
End If

 

[pliant]

Ok that works great! thanks

Would there be anyway to access the Global Address Book in Outlook through using code in case the user does not have Outlook open. Or must the user manually open the Outlook application before the list can be updated?

 

[pliant]

Set objOutlook = CreateObject("Outlook.Application")

This is what causes it to happen without Outlook having to be open. :D

 

[kiddzi]

Hi,

I realise this is an old thread and may not be followed anymore but wanted to give it a try anyway as the previous posts are exactly what I want to achieve.

I have the following code which works as I need by looking at the name entered in a cell, looking this up in the Global Address List and returning the address string in the next cell.

Help needed:

1. I want to cut this GAL returned string down to just the actual e-mail address if possible.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
2. Stop the Outlook security prompt.<o></o>
3. All of the above but in a tidier and more efficient coding

[FONT=Verdana][COLOR=black][COLOR=black][FONT=Verdana]Dim Outlook As Object[/FONT][/COLOR]
[FONT=Verdana][COLOR=black]Const olFolderContacts As Long = 10[/COLOR][/FONT]
 
[COLOR=black][FONT=Verdana]Private Sub Worksheet_Change(ByVal Target As Range)[/FONT][/COLOR]
 
[COLOR=black][FONT=Verdana]Dim contactName As String[/FONT][/COLOR]
[FONT=Verdana][COLOR=black]Dim contacts As Object[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Dim contact As Object[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Dim comment As Excel.comment[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Dim contactInfo As String[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Dim addressLists As Object  ' Outlook.AddressLists[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Dim GAL As Object  ' Outlook.AddressList[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Dim addressEntries As Object  ' Outlook.AddressEntries[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Dim addressEntry As Object  ' Outlook.AddressEntry[/COLOR][/FONT]
 
[COLOR=black][FONT=Verdana]' get target cell value ONLY if single cell selected[/FONT][/COLOR]
[FONT=Verdana][COLOR=black]If Target.Cells.Count = 1 Then[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]contactName = Target.Value[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Else[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Exit Sub[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]End If[/COLOR][/FONT]
[COLOR=black][FONT=Verdana]' ignore blanks[/FONT][/COLOR]
[FONT=Verdana][COLOR=black]If Len(contactName) = 0 Then[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Exit Sub[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]End If[/COLOR][/FONT]
 
[COLOR=black][FONT=Verdana]' grab Outlook, if not already instantiated previously[/FONT][/COLOR]
[FONT=Verdana][COLOR=black]If Outlook Is Nothing Then[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Set Outlook = GetOutlookApp[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]End If[/COLOR][/FONT]
 
[COLOR=black][FONT=Verdana]' get contacts[/FONT][/COLOR]
[FONT=Verdana][COLOR=black]Set contacts = GetItems(GetNS(Outlook), olFolderContacts)[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]' try to grab target contact[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]On Error Resume Next[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Set contact = contacts.Item(contactName)[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]On Error GoTo 0[/COLOR][/FONT]
 
[COLOR=black][FONT=Verdana]' remove existing comment, if any[/FONT][/COLOR]
[FONT=Verdana][COLOR=black]On Error Resume Next[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Set comment = Target.comment[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]comment.Delete[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]On Error GoTo 0[/COLOR][/FONT]
[COLOR=black][FONT=Verdana]If contact Is Nothing Then[/FONT][/COLOR]
 
[COLOR=black][FONT=Verdana]' try to find in GAL[/FONT][/COLOR]
[FONT=Verdana][COLOR=black]Set addressLists = GetNS(Outlook).addressLists[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Set GAL = addressLists.Item("Global Address List")[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Set addressEntries = GAL.addressEntries[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]On Error Resume Next[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Set addressEntry = addressEntries.Item(Target.Value)[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]On Error GoTo 0[/COLOR][/FONT]
[COLOR=black][FONT=Verdana]If addressEntry Is Nothing Then[/FONT][/COLOR]
 
[FONT=Verdana][COLOR=black]  ' nothing in Contacts Folder or GAL[/COLOR][/FONT]
[FONT=Verdana][COLOR=black] contactInfo = "No contact found with this name."[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Else[/COLOR][/FONT]
 
[FONT=Verdana][COLOR=black]  ' in GAL but not Contacts Folder[/COLOR][/FONT]
[FONT=Verdana][COLOR=black] contactInfo = addressEntry.Name & Chr(10) & addressEntry.Address & Chr(10) & _[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]                Chr(10) & "This information came from the Global Address List."[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]End If[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Else[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]' in Contacts Folder[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]contactInfo = contact.Email1Address[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]End If[/COLOR][/FONT]
 
[COLOR=black][FONT=Verdana]' put contact info into adjacent cell[/FONT][/COLOR]
[FONT=Verdana][COLOR=black]' turn off Events to avoid event firing again[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Application.EnableEvents = False[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Target.Offset(0, 1).Value = contactInfo[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Application.EnableEvents = True[/COLOR][/FONT]
 
[FONT=Verdana][COLOR=black]End Sub[/COLOR][/FONT]
 
[FONT=Verdana][COLOR=black]Function GetOutlookApp() As Object[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Set GetOutlookApp = CreateObject("Outlook.Application")[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]End Function[/COLOR][/FONT]
 
[FONT=Verdana][COLOR=black]Function GetNS(ByRef app As Object) As Object[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Set GetNS = app.GetNamespace("MAPI")[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]End Function[/COLOR][/FONT]
 
[FONT=Verdana][COLOR=black]Function GetItems(olNS As Object, folder As Long) As Object[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]Set GetItems = olNS.GetDefaultFolder(folder).Items[/COLOR][/FONT]
[FONT=Verdana][COLOR=black]End Function[/COLOR][/FONT]
[/COLOR][/FONT]

Many Thanks in advance.

 

[tech_guru]

Easily convert Outlook address book in Excel

Hi,
I read your query and there is a simple solution for the issues, there is a blog written specifically for the mentioned purpose the blog will definitely able to solve your query.
Here is the link vCard Export an Extreme Conversion Tool
Regards
James