PDA

View Full Version : [SOLVED] Outlook Global Address List (GAL) ..



Zack Barresse
10-13-2004, 09:19 AM
Brettdj has a KB entry (http://www.vbaexpress.com/kb/getarticle.php?kb_id=222) which lists all information in your GAL. It is way cool! :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
10-13-2004, 10:02 AM
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
10-13-2004, 10:54 AM
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/default.asp?url=/library/en-us/dnout98/html/msdn_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
10-13-2004, 11:42 AM
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