Option Explicit
' ************************************************************************************************
' Autor/en: http://www.online-vba.de - Marc Wershoven
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von www.online-vba.de!
' Original-Quelltext: www.online-vba.de/vba_outlookadr.php
' ************************************************************************************************

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

Sub MWGetOutlookAdressbookEntries()
   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: MWGetOutlookAdressbookEntries --> 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