How to identify the correct 'GAL' and its '.AddressLists.Item(number)' of a particular email account in Outlook


  • Hi All

    I have a total of two different email accounts aligned with their 'Microsoft Exchange' (different domains) in my MS Outlook 2010 application. I have written a VBA code to identify the correct email account/ domain for my requirements.  I run this code from Excel VBA window.

    It can find the correct email account/ domain, but unable to figure out the exact "Global Address List" of that particular email account, and this problem lead up to mismatch of the correct number for its '.AddressLists.Item(number)', and wrong results...

    I am new here, and very new to the Outlook automation, please help me.

    For Example: I have one email account - "" and another is "", and both are connected with their "Global Address List" via Mircosoft Exchange Servers.
    I have to only access GAL for my "" account to identify User IDs/ Alias numbers and his/her Manager Name & Alias.

    I only know programmically that ".AddressLists.Item(16)" is located to this '' account in my Outlook application, so while running my codes I have to choose the exact Item() number by clicking on many msgbox(es), but how would other employee know their exact AddressList.Item() for their '' e-mail account.

    Set myAddressList = OutSess.Session.AddressLists.Item(9' ("Global Address List") for the first 'GAL' of ''

    Set myAddressList = OutSess.Session.AddressLists.Item(16' ("Global Address List") for the second 'GAL' of ''

    Please Note ---> The order/ sequence of email accounts and their ExchangeServers and AddressList.Item() can be differ in the Outlook application of every employee who runs this VBA program. 

    'Option Explicit
    Sub Get_OutlookContacts_New()
    '' VBA Code - Running from Excel to Outlook application
    '' 1) Need to automatically assign the exact GAL and its AddressLists.Item(number) to the particular "" email account/domain
    Dim objOutlook As Outlook.Application
    Dim objAddressBook As Outlook.AddressList
    Dim objAddressEntry As Outlook.AddressEntry
    Dim lngRow As Long
    Dim OutSess As Outlook.Account
    Dim iCnt As Long
    Dim iTtlGAL As Long, iCntGAL As Long
    With Application
         .ScreenUpdating = False:       .DisplayAlerts = False
         .EnableEvents = False:         .Calculation = xlCalculationManual:                End With
        Set objOutlook = CreateObject("Outlook.Application")
        For iCnt = 1 To objOutlook.Session.Accounts.Count
            If MsgBox("Your e-mail account name: " & vbTab & objOutlook.Session.Accounts.Item(iCnt) & vbCrLf & _
                    "This is account number: " & vbTab & iCnt & " out of " & objOutlook.Session.Accounts.Count & vbCrLf & _
                    vbCrLf & _
                    "Would you like to proceed with this account?", vbYesNo + vbQuestion) = vbYes Then
                Set OutSess = objOutlook.Session.Accounts(iCnt)
                With OutSess.Session
                    For iLoop = 1 To .AddressLists.Count
                        If .AddressLists.Item(iLoop) = "Global Address List" Then
                            iTtlGAL = iTtlGAL + 1
                        End If
                    Next iLoop
                    For iLoop = 1 To .AddressLists.Count
                        If .AddressLists.Item(iLoop) = "Global Address List" Then
                            iCntGAL = iCntGAL + 1
                            If MsgBox("Item number: " & iLoop & " out of " & .AddressLists.Count & vbNewLine & _
                                     "Item name: " & .AddressLists.Item(iLoop) & vbNewLine & _
                                     "Total avaliable Address Entries: " & .AddressLists.Item(iLoop).AddressEntries.Count, vbYesNo + vbQuestion, "Note: This GAL number is " & iCntGAL & " out of " & iTtlGAL) = vbYes Then
                                Set myAddressList = OutSess.Session.AddressLists.Item(iLoop)  '("Global Address List") for the second 'GAL'
                                iYes = 1
                              GoTo iNxtAcctLine:
                            End If
                        End If
                    Next iLoop
                End With
            End If
        Next iCnt
        If iYes <> 1 Then: Exit Sub:
        MsgBox "Now working with e-mail address: " & vbTab & OutSess & vbNewLine & _
                "Current Users Count: " & vbTab & vbTab & myAddressList.AddressEntries.Count, vbInformation, OutSess

    Please help me to make this programmically smart by using the account details.

    Thanks in advance!

    Friday, February 22, 2013 5:29 AM

All replies

  • I don't think you can do that using the Outlook Object Model.

    If using Redemption is an option, it exposes per-account GAL through the RDOExchangeAccount.GAL and RDOExchangeAccount.AllAddressLists properties:

    Dmitry Streblechenko (MVP)
    Redemption - what the Outlook
    Object Model should have been
    Version 5.4 is now available!

    Friday, February 22, 2013 6:29 AM
  • Thank you Sir!

    Using Redemption is not an option at my work place right now, need to see if there is any scope.  :(

    I am trying to attach screenshots of AddressLists of my Outlook's AddressBook. Since my account already has been verify, I don't know why it is still not allowing me to upload image, says need to verify account. :( 

    Okay coming to the point....

    In Outlook 2010: If we goto ""Contacts >> Address Book
    >> Tools >> Options...
     "", then we get a small 'Addressing' window,
    there if we select "Start with Global Address List" then click
    on "Choose Automatically" dropdown option, there we can see
    the arrangement/order of all the AddressLists in the Outlook.<o:p></o:p>

    If this is how I am getting AddressList by my VBA codes (above post), then it may be possible to identify that which GAL do belong to which email acccount/domain in the Outlook.

    More Information: On this 'Addressing' window, if we choose "Custom" option >> Global Address List (any one of them) >> click on "Properties" button, then we get another small window. There we can get some more details like The Current Server & path. I don't know if this can be helpful to solve my query.

    Please take a look on this situation/logic too, looking for some more help to automate all the step.

    Thanks in advance!

    Saturday, February 23, 2013 8:55 AM
  • No, what you see is the name resolution order. That order can be anything.

    Dmitry Streblechenko (MVP)
    Redemption - what the Outlook
    Object Model should have been
    Version 5.4 is now available!

    Sunday, February 24, 2013 9:16 PM
  • Okay Sir!

    Thank you for considering my query!

    I have written VBA codes by using the Outlook Object Model for the same, please see below:

    Option Explicit
    Sub GetMultipleExchangeAccounts_Tested()
    ' Help from
    ' Start from here...
    ' Below VBA code pull GAL Contact data from Exchange Server for each Alias/SSO Id on and Excel sheet
    Dim OutApp As Outlook.Application
    Dim OutTI As Outlook.TaskItem
    Dim OutRec As Outlook.Recipient
    Dim OlAcct As Outlook.Account
    Dim col As New VBA.Collection
    Dim TimeStart As Date, TimeEnd As Date
    Dim iYes As Integer, iLoop As Long, iLR As Long, iLC As Integer
    Dim SysSSONme, SysSSOAlias, SysSSOEmail As Variant
    Dim L4MgrSSO, L4MgrNme, L4MgrEmail As Variant
    Dim ToBeVerifiedSSO As Variant
        TimeStart = Format(VBA.Now, "hh:mm:ss")
    With Application
         .ScreenUpdating = False:       .DisplayAlerts = False
         .EnableEvents = False:         .Calculation = xlCalculationManual:                End With
        Set OutApp = New Outlook.Application
        Set OutTI = OutApp.CreateItem(3)
        ' Check for Outlook 2010
        If Left(OutApp.Version, 2) = "14" Then
            ' Enumerate the list of accounts looking for those that are Exchange Server accounts
            ' If an account is found, add it to a collection to be used later.
            For Each OlAcct In OutApp.Session.Accounts
                If OlAcct.AccountType = olExchange Then
                    If OlAcct Like "*" Then
                        iYes = 1:
                        col.Add OlAcct
                        Debug.Print "VBA.Collection added: " & OlAcct
                    End If
                End If
            MsgBox "This code only works with Outlook 2010.", vbCritical
          Exit Sub
        End If
        If iYes <> 1 Then: MsgBox "Unable to find your '' email account.", vbCritical: Exit Sub:
        ' Did the code find any accounts of the type olExchange?
        If col.Count > 0 Then
            For Each OlAcct In col
                If OlAcct.ExchangeMailboxServerName Like "*" Then
                    With ThisWorkbook.Worksheets("Sheet1")
                        iLR = .Range("A" & Rows.Count).End(xlUp).Row
                        For iLoop = 2 To iLR
                            .Range("F" & iLoop).Select
                            Application.ScreenUpdating = False
                            Application.StatusBar = Format(((iLoop / iLR) * 100), "0.00") & "%"
                            ToBeVerifiedSSO = Trim(.Range("B" & iLoop).Value)         ' "432104321" ' <------ Change this entry to get the property details
                            Set OutRec = OutTI.Recipients.Add(ToBeVerifiedSSO)      '   Set outRec = OutTI.Recipients.Add("Alias/SSO number")
                            If OutRec.Resolved Then
                                SysSSONme =
                                SysSSOAlias = OutRec.AddressEntry.GetExchangeUser.Alias
                                SysSSOEmail = OutRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
                                .Range("L" & iLoop).Value = SysSSONme
                                .Range("M" & iLoop).Value = SysSSOAlias
                                .Range("N" & iLoop).Value = SysSSOEmail
                                On Error GoTo errHandler1
                                L4MgrNme =
                                On Error GoTo errHandler2
                                L4MgrSSO = OutRec.AddressEntry.GetExchangeUser.GetExchangeUserManager.Alias
                                On Error GoTo errHandler3
                                L4MgrEmail = OutRec.AddressEntry.GetExchangeUser.GetExchangeUserManager.PrimarySmtpAddress
                                If .Range("F" & iLoop).Value Like "Error*" Or .Range("G" & iLoop).Value Like "Error*" Then
                                    GoTo iNextLoopRow:
                                End If
                                If StrComp(Trim(.Range("D" & iLoop).Value), L4MgrSSO, vbTextCompare) = 0 Then
                                    .Range("F" & iLoop).Value = L4MgrSSO
                                    .Range("G" & iLoop).Value = L4MgrNme
                                    .Range("H" & iLoop).Value = "MgrSSO Matched"
    '                               ' MsgBox " SSO is different", vbCritical
                                    .Range("F" & iLoop).Value = L4MgrSSO
                                    .Range("G" & iLoop).Value = L4MgrNme
                                    .Range("H" & iLoop).Value = L4MgrSSO & " - Not Matched with " & Trim(.Range("D" & iLoop).Value)
                                End If                                                        
                                .Range("K" & iLoop).Value = ToBeVerifiedSSO & " - Not Found in GAL"
                '               ' MsgBox "Couldn't find Employee SSO: " & ToBeVerifiedSSO, vbExclamation
                            End If
                            ToBeVerifiedSSO = Empty
                            SysSSONme = Empty:      SysSSOAlias = Empty:        SysSSOEmail = Empty
                            L4MgrNme = Empty:       L4MgrSSO = Empty:       L4MgrEmail = Empty
                        Next iLoop
                    End With
                    MsgBox "Yahhoo ExchangeMailboxServerName not found.", vbCritical, OlAcct
                  Exit Sub
                End If
            Next OlAcct
            MsgBox "You do not have any accounts configured to use an Exchange Server.", vbCritical
          Exit Sub
        End If
        On Error Resume Next
            col.Remove (1)                      ' 1 as index number for OlAcct, which is the one and only for here
        On Error GoTo 0
        Application.StatusBar = False
        Set OutApp = Nothing:       Set OutTI = Nothing:        Set OutRec = Nothing
        TimeEnd = Format(VBA.Now, "hh:mm:ss")
        MsgBox "Task Completed!" & vbCrLf & "Total Tool Running Time: " & vbTab & Format((TimeEnd - TimeStart), "hh:mm:ss"), vbInformation, OutApp
        With Application
             .ScreenUpdating = False:       .DisplayAlerts = False
             .EnableEvents = False:         .Calculation = xlCalculationAutomatic:                End With
    Exit Sub:
        '    MsgBox "Error " & Err.Number & ": " & Err.Description & " in row # " & iLoop, vbExclamation, "Error"
            ThisWorkbook.Worksheets("Sheet1").Range("F" & iLoop).Value = "Error " & Err.Number & ": " & Err.Description & " in row # " & iLoop
            Resume Next
            ThisWorkbook.Worksheets("Sheet1").Range("G" & iLoop).Value = "Error " & Err.Number & ": " & Err.Description & " in row # " & iLoop
            Resume Next
            ThisWorkbook.Worksheets("Sheet1").Range("J" & iLoop).Value = "Error " & Err.Number & ": " & Err.Description & " in row # " & iLoop
            Resume Next
    End Sub

    Though I have tested it with more than 3000 records (Alias numbers) of GAL, and it runs up to 2:30 hours, so there is enough scope to improve the processing speed (program running time). 

    Since it is my the 1st effort in Outlook programming (learning), so still don't know the risk part of it, need some help/advise...

    Now can you/ anyone please confirm the above code from your side as well for the above said requirements?

    I would also highly appreciate if anyone can elevate my VBA script's speed.

    Thanks in advance! Regards, SunOffice

    Tuesday, February 26, 2013 10:37 PM
  • I am not sure how this related to your original question. You are not accessing any address lists.

    Dmitry Streblechenko (MVP)
    Redemption - what the Outlook
    Object Model should have been
    Version 5.4 is now available!

    Wednesday, February 27, 2013 5:58 AM
  • Yes a bit! Even still I don't know how it is giving me always correct result for my both Exchange Server's email accounts with their GAL. :O (still trying to study it more)

    ...but this VBA script is written for the main/current situation of the project, which is solving the problem.

    That's why I need a help of an expert who can confirm it's flow of running for surprise free operationI would also highly appreciate if anyone can elevate my above VBA script's speed.

    Thanks in advance! Regards, SunOffice

    Wednesday, February 27, 2013 6:47 AM