Results 1 to 7 of 7
  1. #1
    New Lounger
    Join Date
    Feb 2009
    Location
    New York, New York
    Posts
    14
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Hey folks, I'm trying to write an Outlook VBA procedure which retrieves data from the Global Address List into the user's Contacts folder. I've come up with the following procedure (below) based on looking at code in a post in Sue Mosher's OutlookCode forum.

    It actually works great in Outlook 2007. The problem is it doesn't work in Outlook 2003, and I need it to work with both (for now). I've commented in my code where it breaks in 2003:
    1) No ExchangeUser var type
    2) No AddressEntryUserType property for AddressEntry
    3) No GetExchangeUser method for AddressEntry

    Does anyone know how I can get around these limitations and tweak the procedure to also work with Outlook 2003?

    I also tried posting this question in the OutlookCode forum, but for some reason, I'm having some problems posting there.

    Also, how do I refresh a folder (like the Contacts folder) using Outlook VBA?

    Thank you in advance for anyone who can point me in the right direction!

    Code:
    Public Sub RetrieveGALInfo()
    ' Written by Stephan Ip, 10/15/2009, adapted from Outlook VBA code in Sue Mosher's OutlookCode forum:
    ' http://www.outlook-code.com/threads....essageid=30319
    '
    ' Updates/adds contacts from Global Address List into "global" contacts folder in Outlook.
    ' IMPORTANT: This will work in Outlook 2007, but NOT in Outlook 2003!
    ' TODO: How do I also make this work in Outlook 2003?
    On Error Resume Next
    
    	Dim objOutlook As Application
    	Dim myNameSpace As NameSpace
    	Dim myFolder As MAPIFolder, myGALFolder As MAPIFolder
    	Dim GAL As AddressList, allGAL As AddressEntries
    	Dim i As Integer
    	Dim entry As AddressEntry
    	Dim exUser As ExchangeUser  ' <-- doesn't work in Outlook 2003
    	
    	Dim strFirstName$, strLastName$, strBusPhone$, strMobilePhone$, strEmail1$
    	Dim blnContactFound As Boolean
    	Dim objItems As Items
    	Dim objItem As Object, objAdd As Object
    	
    	Set objOutlook = CreateObject("Outlook.Application")
    	Set myNameSpace = objOutlook.GetNamespace("MAPI")
    
    	Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
    	Set myGALFolder = myFolder.Folders("global")
    	
    	Set GAL = myNameSpace.AddressLists("Global Address List")
    	Set allGAL = GAL.AddressEntries
    	
    	' Loop through all the Global Address List entries
    	For i = 1 To allGAL.Count
    		Set entry = allGAL.Item(i)
    		If entry.AddressEntryUserType = olExchangeUserAddressEntry Then ' <-- doesn't work in Outlook 2003
    			Set exUser = entry.GetExchangeUser  ' <-- doesn't work in Outlook 2003
    			' check for blank last name
    			If exUser.LastName <> "" Then
    				' Get field values
    				strFirstName$ = exUser.FirstName
    				strLastName$ = exUser.LastName
    				strBusPhone$ = exUser.BusinessTelephoneNumber
    				strMobilePhone$ = exUser.MobileTelephoneNumber
    				strEmail1$ = exUser.PrimarySmtpAddress
    				
    				Set objItems = myGALFolder.Items
    		 
    				' 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) & strLastName$ & _
    				  IIf(Len(strLastName$) > 0 And Len(strFirstName$) > 0, ", ", "") & strFirstName$ & Chr(34))
    		  
    				If Not TypeName(objItem) = "Nothing" Then
    					' Match found!
    					' Set flag and update data
    					blnContactFound = True
    					objItem.BusinessTelephoneNumber = strBusPhone$
    					objItem.MobileTelephoneNumber = strMobilePhone$
    					objItem.Email1Address = strEmail1$
    					objItem.Save
    				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$
    						.FileAs = strLastName$ & IIf(Len(strLastName$) > 0 And Len(strFirstName$) > 0, ", ", "") & strFirstName$
    						.Save
    					End With
    				End If
    			End If
    		End If
    	Next i
    	
    	' TODO: Find out if there's a way to refresh the "global" contacts folder using Outlook VBA?
    	
    	' Cleanup
    	Set objItems = Nothing
    	Set allGAL = Nothing
    	Set GAL = Nothing
    	Set myGALFolder = Nothing
    	Set myFolder = Nothing
    	Set myNameSpace = Nothing
    	Set objOutlook = Nothing
    
    End Sub
    [pre]Stephan Ip
    www.CustomOfficeDev.com
    [/pre]

  2. #2
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts
    These items aren't exposed in the Outlook 2003 VBA object model. You'd need a library such as CDO or Outlook Redemption to get at them.

  3. #3
    New Lounger
    Join Date
    Feb 2009
    Location
    New York, New York
    Posts
    14
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Thank you Hans for your usual superb acumen! I took your advice and re-wrote the procedure today using the Outlook Redemption library (revised code below), and this works in both Outlook 2003 and Outlook 2007.

    The only thing I'm not 100% happy with is that it does take a long time to loop through all the entries in the GAL to get the field values. (It takes like a few minutes for the logic to loop through the hundreds of GAL entries.) Can you think of a more efficient way of doing this?

    Thanks again.

    Code:
    Public Sub RetrieveGALInfo()
    ' Written by Stephan Ip, 10/15/2009, adapted from Outlook VBA code in Sue Mosher's OutlookCode forum:
    ' http://www.outlook-code.com/threads....essageid=30319
    '
    ' Revised 10/16/2009, to use Outlook Redemption to work 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/...bjects-fo.aspx
    '
    ' 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
    	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
    	
    	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 GAL = myNameSpace.AddressLists("Global Address List")
    	Set GAL = objSession.AddressBook.AddressLists(True).Item("Global Address List")
    	Set allGAL = GAL.AddressEntries
    	
    	' Loop through all the Global Address List entries
    	For i = 1 To allGAL.Count
    		Set entry = allGAL.Item(i)
    		' check for blank last name
    		If entry.LastName <> "" Then
    			' check for blank NT account name
    			If entry.NTAccountName <> "" Then
    				' Get field values
    				strName$ = entry.Name
    				strFirstName$ = entry.FirstName
    				strLastName$ = entry.LastName
    				strBusPhone$ = entry.BusinessTelephoneNumber
    				strMobilePhone$ = entry.MobileTelephoneNumber
    				strEmail1$ = entry.SMTPAddress
    '				strUserFld1$ = entry.???	 ' <-- TODO: Where to get the BlackBerry PIN from in the GAL???
    			
    				Set objItems = myGALFolder.Items
    	 
    				' 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
    			Else
    				' Next line for testing purposes only -- rem out in Production!
    				Debug.Print "Blank NT account name: " & entry.Name
    			End If
    		End If
    	Next i
    	
    	' TODO: Find out if there's a way to refresh the "global" contacts folder using Outlook VBA?
    	
    	' Cleanup
    	Set objItems = Nothing
    	Set allGAL = Nothing
    	Set GAL = Nothing
    	Set myGALFolder = Nothing
    	Set myFolder = Nothing
    	Set myNameSpace = Nothing
    	Set objOutlook = Nothing
    	Set objSession = Nothing
    	
    End Sub
    [pre]Stephan Ip
    www.CustomOfficeDev.com
    [/pre]

  4. #4
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts
    You need to loop through all GAL entries; I think this will always be slow using VBA. A server-side script might be faster, but I have no experience with that. Perhaps you'll find some ideas in Making the Exchange Server GAL Portable.

  5. #5
    New Lounger
    Join Date
    Feb 2009
    Location
    New York, New York
    Posts
    14
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Thanks Hans. I'll look into it and see what I can come up with...
    [pre]Stephan Ip
    www.CustomOfficeDev.com
    [/pre]

  6. #6
    New Lounger
    Join Date
    Feb 2009
    Location
    New York, New York
    Posts
    14
    Thanks
    0
    Thanked 0 Times in 0 Posts
    As an aftermath to this thread, I was able to figure out a more efficient way to do what I wanted -- by using Outlook Redemption MAPI tables: http://www.dimastr.com/redemption/mapitable.htm

    For this project, I realized that I needed to retrieve only the "Executives" and not all the hundreds of entries from the GAL, and by using Outlook Redemption MAPI tables, you can retrieve a whole set of GAL entries, with a filter, in a single call. The procedure now takes only seconds to run instead of minutes! I'm posting my revised code here for anyone else who may want to do something similar.

    Outlook Redemption -- for $200, it's a great tool. Thanks again Hans for pointing me in the right direction.

    [codebox]Public Sub RetrieveGALInfo()
    ' Written by Stephan Ip, 10/15/2009, adapted from Outlook VBA code in Sue Mosher's OutlookCode forum:
    ' http://www.outlook-code.com/threads.aspx?f...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...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[/codebox]
    [pre]Stephan Ip
    www.CustomOfficeDev.com
    [/pre]

  7. #7
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts
    Thanks - it may well be useful to someone else!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •