How to get contact information from GAL using employee mail address in Outlook 2003?

[Muthukumar]

Hi,

Anyone please help me in getting VBA code to extract the contact information (like phone number, office location, company) from Global Address List by using the mail address. I have searched in many blogs and forums but didnt get the code i am expecting. :help

I really appreciate if anyone point me to a right direction.. Thanks in advance

[skatonni]

Looks like it was quite a challenge for Outlook 2003. You will need Redemption. Do not know if the link will be removed by moderators so bookmark it now.

It is the first item in google search "global address list outlook vba"

http://windowssecrets.com/forums/showthread.php/121886-How-to-retrieve-GAL-info-into-Outlook-contacts-with-VBA

Public Sub RetrieveGALInfo()
' Written by Stephan Ip, 10/15/2009, adapted from Outlook VBA code in Sue Mosher's OutlookCode forum:
' http://www.outlookcode.com/threads.aspx?forumid=2&messageid=30319
'
' Revised 10/16/2009, to use Outlook Redemption so that this works with *both* Outlook 2003 and Outlook 2007,
' and also to bypass Outlook's native security. Example of using Outlook Redemption to retrieve GAL info:
' http://www.eggheadcafe.com/software/aspnet/32109678/-redemption-objects-fo.aspx
'
' Revised 10/20/2009, to use MAPI tables in Outlook Redemption to filter and retrieve a complete set of
' GAL entries in a single call instead of looping through all the GAL entries, which is extremely slow.
' Also revised to retrieve only the "Executives" instead of everyone from the GAL, because that's all we need!
' Dmitry Streblechenko webpage documenting use of Outlook Redemption MAPI tables:
' http://www.dimastr.com/redemption/mapitable.htm
'
' Also thank you to Hans V. in the Woody's Lounge Outlook forum.
'
' Updates/adds contacts from Global Address List into "global" contacts folder in Outlook.
On Error Resume Next

Dim objSession As Redemption.RDOSession
Dim objOutlook As Application
Dim myNameSpace As NameSpace
Dim myFolder As MAPIFolder, myGALFolder As MAPIFolder
' Dim GAL, allGAL
' Dim i As Integer, j As Integer
Dim entry As Object

Dim strName$, strFirstName$, strLastName$, strBusPhone$, strMobilePhone$, strEmail1$, strUserFld1$
Dim blnContactFound As Boolean
Dim objItems As Items
Dim objItem As Object, objAdd As Object
' Dim StartTime As Date, StopTime As Date ' <-- For testing purposes only

' Outlook Redemption MAPI table var declarations
Dim Columns(6)
Dim Row
Dim Table As Redemption.MAPITable
Dim Filter As Redemption.TableFilter
Dim RestrAnd As Redemption.RestrictionAnd
Dim Restr1 As Redemption.RestrictionProperty
Dim Restr2 As Redemption.RestrictionProperty

' MAPI property hexadecimal constants
Const PR_ACCOUNT = &H3A00001E
Const PR_DISPLAY_NAME = &H3001001E
Const PR_GIVEN_NAME = &H3A06001E
Const PR_SURNAME = &H3A11001E
Const PR_BUSINESS_TELEPHONE_NUMBER = &H3A08001E
Const PR_MOBILE_TELEPHONE_NUMBER = &H3A1C001E
Const PR_EMAIL = &H39FE001E
Const PR_DEPARTMENT_NAME = &H3A18001E

Set objSession = CreateObject("Redemption.RDOSession") ' Create instance of Redemption
Set objOutlook = CreateObject("Outlook.Application") ' Create instance of Outlook
objSession.MAPIOBJECT = objOutlook.Application.Session.MAPIOBJECT ' Set the Redemption MAPI to Outlook's MAPI to bypass security

Set myNameSpace = objOutlook.GetNamespace("MAPI")

Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
Set myGALFolder = myFolder.Folders("global")
Set objItems = myGALFolder.Items

' Set GAL = myNameSpace.AddressLists("Global Address List")
' Set GAL = objSession.AddressBook.AddressLists(True).Item("Gl obal Address List")
' Set allGAL = GAL.AddressEntries

' Create the Outlook Redemption MAPI table and populate with GAL entries
Set Table = CreateObject("Redemption.MAPITable")
Table.Item = objSession.AddressBook.AddressLists(True).Item("Gl obal Address List").AddressEntries

' Set up the restriction
' In this case, we want to restrict GAL entries to Department beginning with "Executive"
' What we want to do is this:
' (Department Like "Executive*")
' BUT since we cannot use regular expressions in MAPI restrictions, we have to do it this somewhat kludgy way:
' (Department >= "Executive" And Department < "Executivf")
Set Filter = Table.Filter
Filter.Clear
Set RestrAnd = Filter.SetKind(RES_AND)
Set Restr1 = RestrAnd.Add(RES_PROPERTY)
Restr1.ulPropTag = PR_DEPARTMENT_NAME
Restr1.relop = RELOP_GE
Restr1.lpProp = "Executive"
Set Restr2 = RestrAnd.Add(RES_PROPERTY)
Restr2.ulPropTag = PR_DEPARTMENT_NAME
Restr2.relop = RELOP_LT
Restr2.lpProp = "Executivf"
Filter.Restrict

' Restriction is done, read the GAL data
Columns(0) = PR_ACCOUNT
Columns(1) = PR_DISPLAY_NAME
Columns(2) = PR_GIVEN_NAME
Columns(3) = PR_SURNAME
Columns(4) = PR_BUSINESS_TELEPHONE_NUMBER
Columns(5) = PR_MOBILE_TELEPHONE_NUMBER
Columns(6) = PR_EMAIL

Table.Columns = Columns
Table.GoToFirst

' Start timing (for testing purposes only) -- rem out in Production!
' Debug.Print "Start: " & Now

' Loop through the MAPI table to get the field values for the entries
Do
Row = Table.GetRow
If Not IsEmpty(Row) Then
' Get field values
' For each field, if the GAL data doesn't exist, then we're going to get an error, so
' when that's the case, we need to assign an empty string to the var and clear the error
strName$ = Row(1)
If Err.Number <> 0 Then
strName$ = ""
Err.Clear
End If

strFirstName$ = Row(2)
If Err.Number <> 0 Then
strFirstName$ = ""
Err.Clear
End If

strLastName$ = Row(3)
If Err.Number <> 0 Then
strLastName$ = ""
Err.Clear
End If

strBusPhone$ = Row(4)
If Err.Number <> 0 Then
strBusPhone$ = ""
Err.Clear
End If

strMobilePhone$ = Row(5)
If Err.Number <> 0 Then
strMobilePhone$ = ""
Err.Clear
End If

strEmail1$ = Row(6)
If Err.Number <> 0 Then
strEmail1$ = ""
Err.Clear
End If

' strUserFld1$ = ??? ' <-- TODO: Where to get the BlackBerry PIN from in the GAL???

' Re-set flag
blnContactFound = False

' Try to find matching contact in the "global" contacts folder,
' and if found, update that contact's data
Set objItem = objItems.Find("[FileAs]=" & Chr(34) & strName$ & Chr(34))

If Not TypeName(objItem) = "Nothing" Then
' Match found!
' Set flag and update data
blnContactFound = True
With objItem
.BusinessTelephoneNumber = strBusPhone$
.MobileTelephoneNumber = strMobilePhone$
.Email1Address = strEmail1$
.User1 = strUserFld1$
.Save
End With
End If

' If the contact wasn't found above, then add it
If Not blnContactFound Then
Set objAdd = objItems.Add ' Create a new contact
With objAdd ' Add the data to the new contact
.FirstName = strFirstName$
.LastName = strLastName$
.BusinessTelephoneNumber = strBusPhone$
.MobileTelephoneNumber = strMobilePhone$
.Email1Address = strEmail1$
.User1 = strUserFld1$
.FileAs = strName$
.Save
End With
End If
End If
Loop Until IsEmpty(Row)

' Stop timing (for testing purposes only) -- rem out in Production!
' Debug.Print "Stop: " & Now

' Cleanup
Set objItems = Nothing
' Set allGAL = Nothing
' Set GAL = Nothing
Set Restr1 = Nothing
Set Restr2 = Nothing
Set RestrAnd = Nothing
Set Filter = Nothing
Set Table = Nothing
Set myGALFolder = Nothing
Set myFolder = Nothing
Set myNameSpace = Nothing
Set objOutlook = Nothing
Set objSession = Nothing

End Sub