Results 1 to 8 of 8

Thread: Excel VBA Macro to Extract Outlook GAL Email Address Using Alias

  1. #1
    Junior Member
    Join Date
    Aug 2020
    Posts
    5
    Rep Power
    0

    Excel VBA Macro to Extract Outlook GAL Email Address Using Alias

    Hi,

    In a worksheet called "Users" I have a defined named range for column A called "Aliases" which has one text data in each cell like:

    VACBHAW
    VTQOBRE
    POTWVYZ

    I would like to lookup these aliases in the Outlook Global Address List (GAL) and pull in these three fields: emails, name, and phone number. Each alias exists in Outlook GAL, if it doesn't then it should not return anything for those three fields. Keep in mind that I have hundreds of these aliases listed in column A, so I would like the code to be fast if possible. Please note I have Office 365.

    I found a similar code online, but I don't know how to modify it to fit my requirement:

    Code:
    Sub tgr()    
        Dim appOL As Object
        Dim oGAL As Object
        Dim oContact As Object
        Dim oUser As Object
        Dim arrUsers(1 To 65000, 1 To 7) As String
        Dim UserIndex As Long
        Dim i As Long
        Dim sEmails as String
        Dim cl as Range
        Dim rngEmails as Range
    
    
        With Worksheets("Users")
            Set rngEmails = .Range("A2:" & .Range("A" & .Rows.Count).End(xlup).Address)
        End With
    
    
        For each cl in rngEmails
            If Len(cl.value)>0 Then
                sEmails = sEmails & Cl.Value & ","
            Else
                'No email in cell, ignore it
            End If
        Next cl
    
        Set appOL = CreateObject("Outlook.Application")
        Set oGAL = appOL.GetNamespace("MAPI").AddressLists("Global Address List").AddressEntries
    
        For i = 1 To oGAL.Count
            Set oContact = oGAL.Item(i)
            If oContact.AddressEntryUserType = 0 Then
               Set oUser = oContact.GetExchangeUser
                If InStr(1, sEmails, oUser.PrimarySmtpAddress, vbTextCompare) > 0 Then
                    UserIndex = UserIndex + 1
                    arrUsers(UserIndex, 1) = oUser.PrimarySmtpAddress
                    arrUsers(UserIndex, 2) = oUser.Department
                    arrUsers(UserIndex, 3) = oUser.Name
                    arrUsers(UserIndex, 4) = oUser.CompanyName
                    arrUsers(UserIndex, 5) = oUser.BusinessTelephoneNumber
                    arrUsers(UserIndex, 6) = oUser.Alias
                    arrUsers(UserIndex, 7) = oUser.MobileTelephoneNumber
                    
                End If
            End If
        Next i
        appOL.Quit
        If UserIndex > 0 Then
            Range("A2").Resize(UserIndex, UBound(arrUsers, 2)).Value = arrUsers
        End If
        Set appOL = Nothing
        Set oGAL = Nothing
        Set oContact = Nothing
        Set oUser = Nothing
        Erase arrUsers
     End Sub

  2. #2
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10

    Hi showtime,

    Welcome to ExcelFox. Code below. If you want the working file, check out the attachment.

    Code:
    Option Explicit
    
    Sub GetExchangeUserDetailsFromAlias()
        
        Dim str As String
        Dim olApp As Object 'Outlook.Application
        Dim olNameSpace As Object 'Outlook.Namespace
        Dim olRecipient As Object 'Outlook.Recipient
        Dim oEU As Object 'Outlook.ExchangeUser
        Dim arrUsers(1 To 65000, 1 To 3) As String
        Dim lngUser As Long
        Dim rngAlias As Range, rngAliasList As Range
        
        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application")
        If olApp Is Nothing Then
            Set olApp = CreateObject("Outlook.Application")
        End If
        On Error GoTo 0
        
        Set olNameSpace = olApp.GetNamespace("MAPI")
        
        With Worksheets("Users")
            Set rngAliasList = .Range("rngAliasList")
        End With
        For Each rngAlias In rngAliasList
            lngUser = lngUser + 1
            If Len(rngAlias.Value) > 0 Then
                str = rngAlias.Value
                Set olRecipient = olNameSpace.CreateRecipient(str)
                olRecipient.Resolve
                If olRecipient.Resolved Then
                    If olRecipient.AddressEntry.AddressEntryUserType = 0 Then 'olExchangeUserAddressEntry
                        Set oEU = olRecipient.AddressEntry.GetExchangeUser
                        If Not (oEU Is Nothing) Then
                            With oEU
                                arrUsers(lngUser, 1) = .PrimarySmtpAddress
                                arrUsers(lngUser, 2) = .Name
                                arrUsers(lngUser, 3) = .MobileTelephoneNumber
                            End With
                        End If
                    End If
                End If
            End If
        Next rngAlias
        rngAliasList.Offset(, 1).Resize(, 3).Value = arrUsers
        
        Set olApp = Nothing 'Outlook.Application
        Set olNameSpace = Nothing 'Outlook.Namespace
        Set olRecipient = Nothing 'Outlook.Recipient
        Set oEU = Nothing 'Outlook.ExchangeUser
        If lngUser Then Erase arrUsers
        Set rngAlias = Nothing
        Set rngAliasList = Nothing
        
    End Sub
    Attached Files Attached Files
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  3. #3
    Junior Member
    Join Date
    Aug 2020
    Posts
    5
    Rep Power
    0
    Wow! This is awesome and it works like a charm. Thank you so much!!!
    Last edited by DocAElstein; 08-20-2024 at 02:27 PM.

  4. #4
    Junior Member
    Join Date
    Aug 2020
    Posts
    5
    Rep Power
    0
    I detected a small issue with the code - it returns #N/A for the three extracted fields/columns from row 65,0001 to the last row of the worksheet.

    Also would appreciate if you can make these small modifications:

    1) Add a header for each column of the three fields such as Email, Name and Phone Number.
    2) Some emails comes like joe.smith@outlook.com (there is always a period between the first and last name) and would like to capitalize the "J"and "S", some are already come in correct form so those shouldn't change.
    3) The Name column comes like Smith, Joe G. (ABC Company) - is it possible to separate Joe (first name) G. (middle name) and Smith (last name) in separate columns with the appropriate headers? Code should disregard the (ABC Company)....it's always in this format "(company name)". Some people don't have a middle name so it should be blank in that column.

    Thanks!!
    Last edited by showtime; 08-06-2020 at 08:43 AM.

  5. #5
    Junior Member
    Join Date
    Aug 2020
    Posts
    5
    Rep Power
    0
    The #NA from row 65,001 to end of the worksheet should be blank since there is no alias listed in the adjacent column A. Just wanted to clarify that.
    Last edited by DocAElstein; 08-20-2024 at 02:26 PM.

  6. #6
    Junior Member
    Join Date
    Aug 2020
    Posts
    5
    Rep Power
    0
    Quote Originally Posted by Excel Fox View Post
    Hi showtime,

    Welcome to ExcelFox. Code below. If you want the working file, check out the attachment.

    Code:
    Option Explicit
    
    Sub GetExchangeUserDetailsFromAlias()
        
        Dim str As String
        Dim olApp As Object 'Outlook.Application
        Dim olNameSpace As Object 'Outlook.Namespace
        Dim olRecipient As Object 'Outlook.Recipient
        Dim oEU As Object 'Outlook.ExchangeUser
        Dim arrUsers(1 To 65000, 1 To 3) As String
        Dim lngUser As Long
        Dim rngAlias As Range, rngAliasList As Range
        
        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application")
        If olApp Is Nothing Then
            Set olApp = CreateObject("Outlook.Application")
        End If
        On Error GoTo 0
        
        Set olNameSpace = olApp.GetNamespace("MAPI")
        
        With Worksheets("Users")
            Set rngAliasList = .Range("rngAliasList")
        End With
        For Each rngAlias In rngAliasList
            lngUser = lngUser + 1
            If Len(rngAlias.Value) > 0 Then
                str = rngAlias.Value
                Set olRecipient = olNameSpace.CreateRecipient(str)
                olRecipient.Resolve
                If olRecipient.Resolved Then
                    If olRecipient.AddressEntry.AddressEntryUserType = 0 Then 'olExchangeUserAddressEntry
                        Set oEU = olRecipient.AddressEntry.GetExchangeUser
                        If Not (oEU Is Nothing) Then
                            With oEU
                                arrUsers(lngUser, 1) = .PrimarySmtpAddress
                                arrUsers(lngUser, 2) = .Name
                                arrUsers(lngUser, 3) = .MobileTelephoneNumber
                            End With
                        End If
                    End If
                End If
            End If
        Next rngAlias
        rngAliasList.Offset(, 1).Resize(, 3).Value = arrUsers
        
        Set olApp = Nothing 'Outlook.Application
        Set olNameSpace = Nothing 'Outlook.Namespace
        Set olRecipient = Nothing 'Outlook.Recipient
        Set oEU = Nothing 'Outlook.ExchangeUser
        If lngUser Then Erase arrUsers
        Set rngAlias = Nothing
        Set rngAliasList = Nothing
        
    End Sub
    Can you help remove the error that I detected with the code and if possible make those small modifications? You can skip or make # 3 optional (by adding the code as a comment). Thank you

  7. #7
    Junior Member
    Join Date
    Mar 2023
    Posts
    1
    Rep Power
    0
    This is exactly what I was looking for but it stops returning data after the first 3 rows, how would I modify to lookup like 30+ lines?

    Quote Originally Posted by Excel Fox View Post
    Hi showtime,

    Welcome to ExcelFox. Code below. If you want the working file, check out the attachment.

    Code:
    Option Explicit
    
    Sub GetExchangeUserDetailsFromAlias()
        
        Dim str As String
        Dim olApp As Object 'Outlook.Application
        Dim olNameSpace As Object 'Outlook.Namespace
        Dim olRecipient As Object 'Outlook.Recipient
        Dim oEU As Object 'Outlook.ExchangeUser
        Dim arrUsers(1 To 65000, 1 To 3) As String
        Dim lngUser As Long
        Dim rngAlias As Range, rngAliasList As Range
        
        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application")
        If olApp Is Nothing Then
            Set olApp = CreateObject("Outlook.Application")
        End If
        On Error GoTo 0
        
        Set olNameSpace = olApp.GetNamespace("MAPI")
        
        With Worksheets("Users")
            Set rngAliasList = .Range("rngAliasList")
        End With
        For Each rngAlias In rngAliasList
            lngUser = lngUser + 1
            If Len(rngAlias.Value) > 0 Then
                str = rngAlias.Value
                Set olRecipient = olNameSpace.CreateRecipient(str)
                olRecipient.Resolve
                If olRecipient.Resolved Then
                    If olRecipient.AddressEntry.AddressEntryUserType = 0 Then 'olExchangeUserAddressEntry
                        Set oEU = olRecipient.AddressEntry.GetExchangeUser
                        If Not (oEU Is Nothing) Then
                            With oEU
                                arrUsers(lngUser, 1) = .PrimarySmtpAddress
                                arrUsers(lngUser, 2) = .Name
                                arrUsers(lngUser, 3) = .MobileTelephoneNumber
                            End With
                        End If
                    End If
                End If
            End If
        Next rngAlias
        rngAliasList.Offset(, 1).Resize(, 3).Value = arrUsers
        
        Set olApp = Nothing 'Outlook.Application
        Set olNameSpace = Nothing 'Outlook.Namespace
        Set olRecipient = Nothing 'Outlook.Recipient
        Set oEU = Nothing 'Outlook.ExchangeUser
        If lngUser Then Erase arrUsers
        Set rngAlias = Nothing
        Set rngAliasList = Nothing
        
    End Sub

  8. #8
    Junior Member
    Join Date
    Aug 2024
    Posts
    7
    Rep Power
    0
    You can use the following VBA code to extract Outlook GAL email addresses using aliases for multiple rows:
    Code:
    Sub GetExchangeUserDetailsFromAlias()
        
        Dim str As String
        Dim olApp As Object 'Outlook.Application

Similar Threads

  1. VBA To Extract Email Address From Text
    By dunndealpr in forum Excel Help
    Replies: 43
    Last Post: 06-05-2019, 03:56 PM
  2. Excel macro to get GAL from outlook.
    By superman in forum Excel Help
    Replies: 2
    Last Post: 09-05-2014, 10:14 AM
  3. Extract Outlook 2007 global address List in excel 2007
    By superman in forum Outlook Help
    Replies: 0
    Last Post: 09-03-2014, 07:15 PM
  4. Replies: 2
    Last Post: 05-23-2013, 08:08 AM

Posting Permissions

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