Outlook Adressbuch in Excel auslesen

Option Explicit
' Original-Quelltext unter: https://www.online-vba.de/outlook-adressbuch-in-excel-auslesen
' Express-Hilfe für VBA unter https://www.online-vba.de/vba-expresshilfe
' Es gelten die Nutzungsbedingungen von Online-VBA.de

'Achtung VERWEIS im VBA Projekt setzen: "Microsoft Outlook x.x Object Library"!
'Achtung VERWEIS im VBA Projekt setzen: "Microsoft CDO x.x Library"!

Public Sub OVBAde_GetOutlookAdressbookEntries()
  Const lNAME = &H3A06001E 'Nachname
  Const lVORNAME = &H3A11001E 'Vorname
  Const lALIAS = &H3A00001E 'Alias
  Const lDISPLAYNAME = &H3001001E 'Angezeigter Name
  Const lADDRESS = &H3A29001E 'Adresse
  Const lORT = &H3A27001E 'Ort
  Const lPLZ = &H3A2A001E 'Postleitzahl
  Const lLAND = &H3A26001E 'Land
  Const lTITEL = &H3A17001E 'Titel, Anrede
  Const lFIRMA = &H3A16001E 'Firma
  Const lABTEILUNG = &H3A18001E 'Abteilung
  Const lMOBILHANDY = &H3A1C001E 'Mobiltelefon
  Const lTELBUERO = &H3A08001F 'Telefon Geschäftlich
  Const lTELHOME = &H3A09001E 'Telefon Privat
  Const lEMAIL = &H39FE001E 'E-Mail
  Const lSMTP = &H39FE001F
  Dim oAlias As Object, oCDO As Object
  Dim z As Long
  Dim i As Long
  Dim oADREntries As MAPI.AddressEntries
  Dim oADREntry As MAPI.AddressEntry
  Dim sName As String, aAdress As String
    
    z = 2
    
    Set oOutlookApp = GetObject(, "Outlook.Application") 'Outlook muss offen sein, alternativ umbauen!
    Set oNameSpace = oOutlookApp.GetNamespace("MAPI")
    Set oCDO = CreateObject("MAPI.Session")
    oCDO.Logon "", "", False, False
    
    Set oADREntries = oCDO.AddressLists.Item(1).AddressEntries
    
    For Each oADREntry In oADREntries.Items
        Application.StatusBar = CStr("VBA: OVBAde_GetOutlookAdressbookEntries --> Import " & _
                            i & " von " & oADREntries.Count & " Elementen ...")
        Set oAlias = oADREntry.Fields(CdoPR_ACCOUNT)
        
        ' Nur Einträge, welche ein E-Mail Eintrag sind werden verarbeitet
        If oADREntry.DisplayType = olUser Then
            
            sAddress = oADREntry.Fields(lSMTP).Value
            sName = oADREntry.Fields(lNAME).Value
            
            ' Ausgabe auf aktivem Tabellenblatt, evtl. neues Blatt einfügen/hinzufügen bei Bedarf
            Cells(z, 1) = oAlias
            Cells(z, 2) = sAddress
            Cells(z, 3) = sName
            
            z = z + 1
            
        End If
    
    Next oADREntry
    
    Application.StatusBar = CStr("Fertig.")
    
    MsgBox "Fertig."
End Sub