On Error GoTo OutOeffnen
    Dim objOutlook As Outlook.Application
    Dim objOutSpace As Outlook.NameSpace
    Dim objOutFolder As Outlook.MAPIFolder
    Dim objOutCont As Outlook.ContactItem
    Dim oItem As ListItem
 
    Set objOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0
    Set objOutSpace = objOutlook.GetNamespace("MAPI")
    Set objOutFolder = objOutSpace.GetDefaultFolder(olFolderContacts)
 
    If objOutFolder.Items.Count = 0 Then
        MsgBox "Es befinden sich keine Kontakte in Ihrem Ordner!", _
          vbInformation, "Hinweis"
        frmOutlookContacts.Picture1.SetFocus
        GoTo ausstieg
    Else
        frmOutlookContacts.lstKontakte.ListItems.Clear
            For Each objOutCont In objOutFolder.Items
            'Nur Kontakte anbfragen, keine Verteilerlisten
            If objOutCont.Class = olContact Then
                If Len(objOutCont.LastName) And Len(objOutCont.FirstName) > _
                  0 Then
                    'ein neues ListItem erzeugen
                    Set oItem = frmOutlookContacts.lstKontakte.ListItems.Add(, _
                      , " " & objOutCont.LastName & " " & objOutCont.FirstName)
                    oItem.SubItems(4) = objOutCont.FirstName
                    oItem.SubItems(5) = objOutCont.LastName
                End If
                'Icon aus der ImageList setzen
                oItem.SmallIcon = "Kontakt"
                If Len(objOutCont.Title) > 0 Then
                    If objOutCont.Title = "Herr" Then
                        oItem.SubItems(6) = "Herrn"
                    End If
                End If
                If Len(objOutCont.BusinessAddressStreet) > 0 Then
                    oItem.SubItems(1) = objOutCont.BusinessAddressStreet
                End If
                If Len(objOutCont.BusinessAddressPostalCode) > 0 Then
                    oItem.SubItems(2) = objOutCont.BusinessAddressPostalCode
                End If
                If Len(objOutCont.BusinessAddressCity) > 0 Then
                    oItem.SubItems(3) = objOutCont.BusinessAddressCity
                End If
            End If
        Next
    End If
 
ausstieg:
        Set oItem = Nothing
        Set objOutCont = Nothing
        Set objOutFolder = Nothing
        Set objOutSpace = Nothing
        Set objOutlook = Nothing
Exit Function
 
OutOeffnen:
    Set objOutlook = CreateObject("Outlook.Application")
    Err.Clear
    Resume Next