Option Explicit

Private Sub cmdKontakteAuflisten_Click()
  Dim olAppl As Outlook.Application
  Dim olNS As Outlook.NameSpace
  Dim olMAPIFolder As Outlook.MAPIFolder
  Dim olItems As Outlook.Items
  Dim olResItems As Outlook.Items
  Dim olContact As Outlook.ContactItem

  Dim sFilter As String

  On Error GoTo errMsgOL
  Set olAppl = CreateObject("Outlook.Application")
  Set olNS = olAppl.GetNamespace("MAPI")
  Set olMAPIFolder = olNS.GetDefaultFolder(olFolderContacts)
  Set olItems = olMAPIFolder.Items

  sFilter = "[MessageClass] = 'IPM.Contact'"

  Set olResItems = olItems.Restrict(sFilter)

  List1.Clear
  For Each olContact In olResItems
    List1.AddItem olContact
  Next olContact

byebye:
  Set olResItems = Nothing
  Set olItems = Nothing
  Set olMAPIFolder = Nothing
  Set olNS = Nothing
  Set olAppl = Nothing

  Exit Sub

errMsgOL:
  MsgBox "Es ist ein Fehler beim Zugriff auf Outlook " & _
        aufgetreten!", vbCritical
  Resume byebye
End Sub