Outlook Global Address List (GAL) ..

[Zack Barresse]

Brettdj has a KB entry which lists all information in your GAL. It is way cool! Is there anyway you could do this for the Outlook Address Book? I've done some playing around but haven't come up with anything that works. I think this would also be a good KB entry. Does anyone have any ideas?

[CBrine]

Zack,
Here's some code I put together to get properties from the Global Address List. Not quite what you are looking for, but along the same thread as the KB entry. It was difficult in that you need to know the hex address(property Tags) of the property in order to get the data.
Here's a web site I found that list many of the properties tags. I will see if I can do some reasearch into the Outlook address book, to see what I can get and post it if no one else does.
http://www.cdolive.com/cdo10.htm

Private Sub CommandButton1_Click()
Dim appOut As MAPI.Session
Dim GAL As AddressList
Dim GalE As AddressEntry
Dim Email As Field
Dim V
Dim BPhone As Field
Const CdoPR_EMS_AB_PROXY_ADDRESSES = &H800F101E
Const CdoPR_HOME_TELEPHONE_NUMBER = &H3A09001E
Const CdoPR_BUSINESS_TELEPHONE_NUMBER = &H3A08001E
On Error Resume Next
Set appOut = CreateObject("Mapi.Session")
appOut.Logon
Set GAL = appOut.GetAddressList(0) 
For Each GalE In GAL.AddressEntries
    'Get address
    Set Email = GalE.Fields(CdoPR_EMS_AB_PROXY_ADDRESSES)
    For Each V In Email.Value
        If Left(V, 5) = "SMTP:" Then
            ActiveSheet.Range("A65353").End(xlUp).Offset(1, 1).Value = Mid(V, 6, 60)
        End If
Next
Set BPhone = GalE.Fields(CdoPR_BUSINESS_TELEPHONE_NUMBER)
    ActiveSheet.Range("A65535").End(xlUp).Offset(1, 2).Value = BPhone
ActiveSheet.Range("A65535").End(xlUp).Offset(1, 0).Value = GalE.Name
    ActiveSheet.Range("A65535").End(xlUp).Offset(1, 0).Select
    If GalE.Name = "Brine, Calvin" Then MsgBox "Now"
Set BPhone = Nothing
    Set Email = Nothing
    V = ""
Next

[CBrine]

Zack,
Here's what I think you were looking for. This grabs the contacts list's entries as well as the personal address book entries. You will need to setup a reference for the Outlook object library or change the code to late binding, for it to work. It currently only display's the contact's first name value, but if you keep the reference in place and type "MsgBox Itm." VBA will show you the options available.

PS- Here's where I got the information to do this.
http://msdn.microsoft.com/library/de...dn_movs105.asp
Although, as with all microsoft documentation, it leaves a lot to be desired, but it does give you the basic's you need to continue.

HTH

Private Sub CommandButton1_Click()
Dim ol As Outlook.Application
Dim NS As Outlook.NameSpace
Dim Adl As Outlook.AddressList
Dim AdlE As Outlook.AddressEntry
Dim CL As Outlook.MAPIFolder
Dim itmCl As Outlook.Items
Dim Itm As Outlook.ContactItem
Set ol = CreateObject("Outlook.application") 
ol.Session.Logon
'Outlook Contact's
Set NS = ol.GetNamespace("MAPI")
Set CL = NS.GetDefaultFolder(olFolderContacts)
Set itmCl = CL.Items
For Each Itm In itmCl
MsgBox Itm.FirstName
Next
'Personal addressbook entries.
For Each AdlE In Adl.AddressEntries
MsgBox AdlE.Name
Next
ol.Session.Logoff
End Sub

[Zack Barresse]

Thanks Calvin,

This is what I ended up with ...

Option Explicit
Sub GetAddyBookInfo()
    Application.ScreenUpdating = False
    Dim ol As Outlook.Application, NS As Outlook.NameSpace, Adl As Outlook.AddressList, _
        AdlE As Outlook.AddressEntry, CL As Outlook.MAPIFolder, itmCl As Outlook.Items, _
        Itm As Outlook.ContactItem, n As Long, i As Long, newSht As Worksheet, _
        yesno As VbMsgBoxResult, ow As Boolean
    ow = False: n = 2
    On Error GoTo NoSheet
    Sheets("Email Info").Activate
    yesno = MsgBox("You already have an Email sheet.  Overwrite?", vbYesNoCancel, "Overwrite?")
    Select Case yesno
        Case vbYes
            ow = True
        Case vbNo
            ow = False
        Case vbCancel
            GoTo endMe
    End Select
    GoTo YesSheet
NoSheet:
    Set newSht = Worksheets.Add(before:=Sheets(Sheets.Count))
    ActiveSheet.Name = "Email Info"
YesSheet:
    Set ol = CreateObject("Outlook.Application")
    ol.Session.Logon
    Set NS = ol.GetNamespace("MAPI") 'Outlook Contact's
    Set CL = NS.GetDefaultFolder(olFolderContacts)
    Set itmCl = CL.Items
    With Sheets("Email Info")
        If ow = True Then .Cells.Delete 'Overwrite
        With .[A1]: .Value = "Last Name": .Font.Bold = True: .Interior.ColorIndex = 4: End With
        With .[B1]: .Value = "First Name": .Font.Bold = True: .Interior.ColorIndex = 4: End With
        With .[C1]: .Value = "Full Name": .Font.Bold = True: .Interior.ColorIndex = 4: End With
        With .[D1]: .Value = "Email Address": .Font.Bold = True: .Interior.ColorIndex = 4: End With
        With .[E1]: .Value = "Phone Number": .Font.Bold = True: .Interior.ColorIndex = 4:  End With
        For Each Itm In itmCl
            .Cells(n, 1).Value = Itm.LastName
            .Cells(n, 2).Value = Itm.FirstName
            .Cells(n, 3).Value = Itm.FullName
            .Cells(n, 4).Value = Itm.Email1Address
            .Cells(n, 5).Value = Itm.PrimaryTelephoneNumber
            n = n + 1
        Next
        For i = .Range("A65536").End(xlUp).Row To 2 Step -1 '** Clean up
            If .Range("A" & i).Value = "" Then .Range("A" & i).EntireRow.Delete
        Next i
        .Activate
        If MsgBox("Would you like to Sort by Last Name?", vbYesNo, "Sort?") = vbYes Then _
            .Cells.Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess
        .Cells.EntireColumn.AutoFit
    End With
    ol.Session.Logoff
endMe:
    Set ol = Nothing: Set NS = Nothing: Set Adl = Nothing: Set AdlE = Nothing
    Set CL = Nothing: Set itmCl = Nothing: Set Itm = Nothing
    Application.ScreenUpdating = True
End Sub