Visitenkarte kann aufgrund von unbekanntem Fehler nicht geparst werden

Wer seine Kontakte einmalig auf sein Android-Handy bekommen möchte, kann diese als Vcard von einer externen SD-Karte importieren. Das funktioniert jedoch nicht so ohne weiteres mit allen Outlook®-Versionen. Ab Outlook® 2007 hat Microsoft das Vcard-Format seinen eigenen Bedürfnissen angepasst und entsprechend erweitert. Diese Erweiterungen sind jedoch nicht vcf-konform und müssen vor einem Import entfernt werden:

Zur Verwendung dieses Beispiels beachten Sie bitte die wichtigen Hinweise, sowie den Workshop VBA in Outlook® verwenden.

Sollte für alle Outlook®-Versionen funktionieren, wurde aus Zeitgründen nur mit 2010 getestet

Den Code bitte in das Modul DieseOutlookSitzung kopieren. Damit der Code wirksam wird, muss anschließend Outlook® neu gestartet werden.

Option Explicit
 
'=========================================================================
' Exportiert Vcards ohne Outlookzusatz
' (c) Peter Marchert - http://www.outlook-stuff.com/
' 2011-01-23 Version 1.0.0
'=========================================================================

Public Sub ExportToVCF()
 
    '=====================================================================
    ' Exportiert Kontakte als VCF-Datei
    '=====================================================================
    
    Dim objFolder As Outlook.MAPIFolder
    Dim objContact As Outlook.ContactItem
    Dim strPath As String
    Dim strFileName As String
    Dim blnSingleMode As Boolean
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Singlemode festlegen (exportiert nur den markierten Kontakt)
    '---------------------------------------------------------------------
'    blnSingleMode = True
    
    '---------------------------------------------------------------------
    ' Zielpfad festlegen
    '---------------------------------------------------------------------
    strPath = "S:\Vcards\"
 
    '---------------------------------------------------------------------
    ' Bei Singelmode nur markierten Kontakt exportieren
    '---------------------------------------------------------------------
    If blnSingleMode Then
 
        '-----------------------------------------------------------------
        ' Aktuellen Kontakt referenzieren
        '-----------------------------------------------------------------
        Set objContact = Outlook.ActiveExplorer.Selection(1)
 
        '-----------------------------------------------------------------
        ' Dateinamen ermitteln
        '-----------------------------------------------------------------
        strFileName = objContact.FullName & ".vcf"
 
        '-----------------------------------------------------------------
        ' Ungültige Zeichen entfernen
        '-----------------------------------------------------------------
        Call CleanFileName(strFileName)
 
        '-----------------------------------------------------------------
        ' Kontakt als Visitenkarte speichern
        '-----------------------------------------------------------------
        Call objContact.SaveAs(strPath & strFileName, olVCard)
 
        '-----------------------------------------------------------------
        ' Visitenkarte bereinigen
        '-----------------------------------------------------------------
        Call CleanVcard(strPath & strFileName)
 
    Else
 
        '-----------------------------------------------------------------
        ' Outlook-Standard-Kontakteordner referenzieren
        '-----------------------------------------------------------------
        Set objFolder = Outlook.Session.GetDefaultFolder(olFolderContacts)
 
        '-----------------------------------------------------------------
        ' Aktuellen Ordner referenzieren (wenn gewünscht, ' entfernen)
        '-----------------------------------------------------------------
        'Set objFolder = Outlook.ActiveExplorer.CurrentFolder
        
        '-----------------------------------------------------------------
        ' Alle Kontakte bearbeiten
        '-----------------------------------------------------------------
        For Each objContact In objFolder.Items
 
            '-------------------------------------------------------------
            ' Dateinamen ermitteln
            '-------------------------------------------------------------
            strFileName = objContact.FullName & ".vcf"
 
            '-------------------------------------------------------------
            ' Ungültige Zeichen entfernen
            '-------------------------------------------------------------
            Call CleanFileName(strFileName)
 
            '-------------------------------------------------------------
            ' Kontakt als Visitenkarte speichern
            '-------------------------------------------------------------
            Call objContact.SaveAs(strPath & strFileName, olVCard)
 
            '-------------------------------------------------------------
            ' Visitenkarte bereinigen
            '-------------------------------------------------------------
            Call CleanVcard(strPath & strFileName)
 
        Next
 
    End If
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objContact = Nothing
    Set objFolder = Nothing
 
End Sub
 
Private Sub CleanFileName(ByRef strFileName As String)
 
    '=====================================================================
    ' Bereinigt den Dateinamen von ungültigen Zeichen
    '=====================================================================
    
    strFileName = Replace(strFileName, "\", "")
    strFileName = Replace(strFileName, "/", "")
    strFileName = Replace(strFileName, ":", "")
    strFileName = Replace(strFileName, "*", "")
    strFileName = Replace(strFileName, "?", "")
    strFileName = Replace(strFileName, """", "")
    strFileName = Replace(strFileName, "<", "")
    strFileName = Replace(strFileName, ">", "")
    strFileName = Replace(strFileName, "|", "")
 
End Sub
 
Private Sub CleanVcard(ByVal strFileName As String)
 
    '=====================================================================
    ' Entfernt nicht kompatible Outlook-Elemente aus der Vcard
    '=====================================================================

    Dim strLine As String
    Dim strVCARD As String
    Dim lngFF As Long
 
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Freie Dateinummer ermitteln
    '---------------------------------------------------------------------
    lngFF = FreeFile
 
    '---------------------------------------------------------------------
    ' Datei erneut öffnen
    '---------------------------------------------------------------------
    Open strFileName For Input As #lngFF
 
    '---------------------------------------------------------------------
    ' Vcard zeilenweise bereinigen
    '---------------------------------------------------------------------
    Do While Not EOF(lngFF)
        Line Input #lngFF, strLine
        If InStr(strLine, "X-MS-CARDPICTURE") Then
            Do While strLine <> ""
                Line Input #lngFF, strLine
            Loop
        End If
        If InStr(strLine, "X-MS") = 0 And strLine <> "" Then
            strVCARD = strVCARD & Replace(strLine, ";LANGUAGE=de", "") & vbCrLf
        End If
    Loop
 
    '---------------------------------------------------------------------
    ' Datei wieder schließen
    '---------------------------------------------------------------------
    Close #lngFF
 
    '---------------------------------------------------------------------
    ' Datei löschen
    '---------------------------------------------------------------------
    Call Kill(strFileName)
 
    '---------------------------------------------------------------------
    ' Zeit zum Löschen geben
    '---------------------------------------------------------------------
    DoEvents
 
    '---------------------------------------------------------------------
    ' Neue Datei anlegen
    '---------------------------------------------------------------------
    Open strFileName For Output As #lngFF
 
    '---------------------------------------------------------------------
    ' Vcard schreiben
    '---------------------------------------------------------------------
    Print #lngFF, strVCARD
 
    '---------------------------------------------------------------------
    ' Datei wieder schließen
    '---------------------------------------------------------------------
    Close #lngFF
 
End Sub