Kontakte in Outlook importieren (.vcf)

Option Explicit

Public Sub ImportAlleVCards()
    Dim sRoot As String
    sRoot = "C:\XYZ"   ' <-- HIER DEN PFAD ANPASSEN WENN NÖTIG

    If Dir(sRoot, vbDirectory) = "" Then
        MsgBox "Ordner nicht gefunden: " & sRoot, vbExclamation
        Exit Sub
    End If

    On Error GoTo ErrHandler
    Dim cnt As Long
    cnt = ImportVcfAusOrdner(sRoot)
    MsgBox cnt & " vCard(s) importiert.", vbInformation
    Exit Sub

ErrHandler:
    MsgBox "Fehler: " & Err.Number & " - " & Err.Description, vbCritical
End Sub

Private Function ImportVcfAusOrdner(ByVal sPath As String) As Long
    Dim fso As Object, folder As Object, file As Object, subf As Object
    Dim ns As Outlook.NameSpace
    Dim itm As Object
    Dim count As Long

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(sPath)
    Set ns = Application.Session  ' wir sind in Outlook

    ' Dateien im aktuellen Ordner
    For Each file In folder.Files
        If LCase$(fso.GetExtensionName(file)) = "vcf" Then
            On Error Resume Next
            Set itm = ns.OpenSharedItem(file.Path) ' öffnet .vcf als Kontakt
            If Err.Number <> 0 Then
                Debug.Print "VCF konnte nicht geöffnet werden: " & file.Path & " | " & Err.Description
                Err.Clear
            Else
                If TypeOf itm Is Outlook.ContactItem Then
                    Dim c As Outlook.ContactItem
                    Set c = itm
                    c.Save  ' speichert in Standard-Kontakte
                    count = count + 1
                End If
            End If
            On Error GoTo 0
        End If
    Next file

    ' Rekursiv durch Unterordner (ohne Hidden/System)
    For Each subf In folder.SubFolders
        If ((subf.Attributes And 2) = 0) And ((subf.Attributes And 4) = 0) Then
            count = count + ImportVcfAusOrdner(subf.Path)
        End If
    Next subf

    ImportVcfAusOrdner = count
End Function