Outlook Address from Alias

[RobDog888]

Well here it is in case you can use CDO. If you did a full install of
Outlook it should be installed already. If not you can install it from
the Outlook CD. Its Microsoft Collaboration Data Objects 1.21.

For client applications, you must install Outlook in order to install
CDO. In Outlook 2000 and later versions, CDO is included with
Outlook but is not part of the default setup, nor will it install on
first run. Therefore, you must explicitly select it during a custom
setup or use the Windows Installer object library to
programmatically install CDO

I cleared out some of the names and blocked the email address
from showing so they wont get spammed just in case, but it does
fillup the listview.

Option Explicit
'Add reference to MS CDO 1.21 Library
'Add reference to MS Office Outlook xx.x Object Library
'Add listview control (lvwGAL) 'Project > Components > MS Windows Common Controls 6.0
'Add 2 command buttons (cmdClose) and (cmdRefresh)
Private moApp As Outlook.Application
Private moNS As Outlook.NameSpace
Private moCDO As MAPI.Session
 
Private Const cdoPR_DISPLAY_NAME As Long = &H3001001E
Private Const cdoPR_ACCOUNT As Long = &H3A00001E
Private Const cdoPR_GIVEN_NAME As Long = &H3A06001E
Private Const cdoPR_SURNAME As Long = &H3A11001E
Private Const cdoPR_EMAIL As Long = &H39FE001E
 
Private Sub cmdClose_Click()
    Unload Me
End Sub
 
Private Sub cmdRefresh_Click()
    GetAddressCDO
End Sub
 
Private Sub Form_Load()
    
    On Error GoTo No_Bugs
    
    'INITIALIZE OOM (JUST SO CDO CAN LOGON TO INSTANCE)
    Set moApp = GetObject(, "Outlook.Application")
    If TypeName(moApp) = "Nothing" Then
        Set moApp = New Outlook.Application
    End If
    Set moNS = moApp.GetNamespace("MAPI")
    'INITIALIZE CDO
    Set moCDO = CreateObject("MAPI.Session")
    moCDO.Logon "", "", False, False
    'INITIALIZE LISTVIEW
    With lvwGAL
        .FullRowSelect = True
        .LabelEdit = lvwManual
        .MultiSelect = False
        .View = lvwReport
        .ColumnHeaders.Add , , "", 0
        .ColumnHeaders.Add , , "Display Name", (.Width / 5) - 70
        .ColumnHeaders.Add , , "Last Name", (.Width / 5) - 70
        .ColumnHeaders.Add , , "First Name", (.Width / 5) - 70
        .ColumnHeaders.Add , , "Alias", (.Width / 5) - 70
        .ColumnHeaders.Add , , "E-Mail", (.Width / 5) - 70
        .Sorted = True
        .SortOrder = lvwAscending
        .SortKey = 1
    End With
    'POPULATE LISTVIEW
    GetAddressCDO
    Exit Sub
    
No_Bugs:
    If Err.Number = 429 Then
        Resume Next
    Else
        MsgBox Err.Number & " - " & Err.Description, vbOKOnly + vbExclamation
    End If
End Sub
 
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    moCDO.Logoff
    Set moCDO = Nothing
    Set moNS = Nothing
    Set moApp = Nothing
End Sub
 
Private Sub lvwGAL_DblClick()
    On Error Resume Next
    Dim oDetails As Object
    Set oDetails = moCDO.GetAddressEntry(lvwGAL.SelectedItem)
    oDetails.Details
    Set oDetails = Nothing
End Sub
 
Private Sub GetAddressCDO()
 
    On Error GoTo No_Bugs
    
    Dim oAEntries As Object
    Dim oAEntry As Object
    Dim oFields As Object
    Dim lvItm As ListItem
    Dim i As Integer
    Dim ii As Integer
    Dim iii As Integer
    Dim vDetails As Variant
    Dim lRet As Long
    
    lvwGAL.ListItems.Clear
    Set oAEntries = moCDO.AddressLists.Item("Global Address List").AddressEntries
    For i = 1 To oAEntries.Count
        Set oAEntry = oAEntries.Item(i)
        Set lvItm = lvwGAL.ListItems.Add(, , oAEntry.ID)
        'ITERATE THROUGH ALL FIELDS OF THIS ADDRESS ENTRY
        For ii = 1 To oAEntry.Fields.Count
            Set oFields = oAEntry.Fields(ii)
            vDetails = oFields.Value
            On Error Resume Next
            lRet = UBound(vDetails)
            If Err.Number = 0 Then
                'ITERATE THROUGH ALL VALUES FOR THIS ARRAY
                For iii = 0 To UBound(vDetails)
                    'Debug.Print "Field ID:  " & oFields.ID & "; Field Array #" & iii & ";Value:  " & vDetails(iii)
                Next
            Else
                'ADD SINGLE VALUES TO THE LISTVIEW
                If oFields.ID = cdoPR_DISPLAY_NAME Then
                    lvItm.SubItems(1) = vDetails
                ElseIf oFields.ID = cdoPR_SURNAME Then
                    lvItm.SubItems(2) = vDetails
                ElseIf oFields.ID = cdoPR_GIVEN_NAME Then
                    lvItm.SubItems(3) = vDetails
                ElseIf oFields.ID = cdoPR_ACCOUNT Then
                    lvItm.SubItems(4) = vDetails
                ElseIf oFields.ID = cdoPR_EMAIL Then
                    lvItm.SubItems(5) = vDetails
                End If
                'Debug.Print "Field ID:  " & oFields.ID & "; Value  " & vDetails
            End If
        Next
        Set lvItm = Nothing
    Next
    Set oAEntries = Nothing
    Set oAEntry = Nothing
    Set oFields = Nothing
    Exit Sub
    
No_Bugs:
    MsgBox Err.Number & " - " & Err.Description, vbOKOnly + vbExclamation
End Sub

VB/Outlook Guru!!!