Sub OutlookKontakte_vCard()
    Dim oOutlook As Object ' Outlook.Application
    Dim oNameSpace As Object 'Outlook.Namespace
    Dim oOrdner As Object 'Outlook.Ordner
    Dim oItem As Object
    Dim oPrp As Object
    Dim temp As String
    Dim counter As Integer

    Set oOutlook = GetObject(, "Outlook.Application") ' Outlook verbinden
    Set oNameSpace = oOutlook.GetNamespace("MAPI")
    Set oOrdner = oNameSpace.GetDefaultFolder(10) ' 10 = Ordner Kontakte

    counter = 1
    For Each oItem In oOrdner.items
        With oItem
            If .Class = 40 Then ' 40 = Kontakt
                Set fs = CreateObject("ADODB.Stream")
                fs.Type = 2 ' text
                fs.Charset = "utf-8"
                fs.Open
                temp = "BEGIN:VCARD" + vbCrLf
                temp = temp + "VERSION:3.0" + vbCrLf
                temp = temp + "N:" + .LastName + ";" + .FirstName + vbCrLf
                temp = temp + "FN:" + .FullName + vbCrLf
                If .CompanyName > "" Then
                    temp = temp + "ORG:" + .CompanyName
                    If .Department > "" Then temp = temp + ";" + .Department
                    temp = temp + vbCrLf
                End If
                If .JobTitle > "" Then temp = temp + "TITLE:" + .JobTitle + vbCrLf
                If .NickName > "" Then temp = temp + "NICKNAME:" + .NickName + vbCrLf
                If .Body > "" Then temp = temp + "NOTE:" + Replace(.Body, vbCrLf, "\n") + vbCrLf
                If .BusinessTelephoneNumber > "" Then temp = temp + "TEL;WORK;VOICE:" + .BusinessTelephoneNumber + vbCrLf
                If .Business2TelephoneNumber > "" Then temp = temp + "TEL;WORK;VOICE:" + .Business2TelephoneNumber + vbCrLf
                If .HomeTelephoneNumber > "" Then temp = temp + "TEL;HOME;VOICE:" + .HomeTelephoneNumber + vbCrLf
                If .MobileTelephoneNumber > "" Then temp = temp + "TEL;CELL;VOICE:" + .MobileTelephoneNumber + vbCrLf
                If .OtherTelephoneNumber > "" Then temp = temp + "TEL;VOICE:" + .OtherTelephoneNumber + vbCrLf
                If .BusinessAddressCity > "" Then
                    temp = temp + "ADR;WORK:;;"
                    If .BusinessAddressStreet > "" Then temp = temp + .Replace(.BusinessAddressStreet, vbCrLf, ", ")
                    temp = temp + ";"
                    If .BusinessAddressCity > "" Then temp = temp + .BusinessAddressCity
                    temp = temp + ";"
                    If .BusinessAddressState > "" Then temp = temp + .BusinessAddressState
                    temp = temp + ";"
                    If .BusinessAddressPostalCode > "" Then temp = temp + .BusinessAddressPostalCode
                    temp = temp + ";"
                    If .BusinessAddressCountry > "" Then temp = temp + .BusinessAddressCountry
                    temp = temp + vbCrLf
                End If
                If .HomeAddressCity > "" Then
                    temp = temp + "ADR;HOME;PREF:;;"
                    If .HomeAddressStreet > "" Then temp = temp + .Replace(.HomeAddressStreet, vbCrLf, ", ")
                    temp = temp + ";"
                    If .HomeAddressCity > "" Then temp = temp + .HomeAddressCity
                    temp = temp + ";"
                    If .HomeAddressState > "" Then temp = temp + .HomeAddressState
                    temp = temp + ";"
                    If .HomeAddressPostalCode > "" Then temp = temp + .HomeAddressPostalCode
                    temp = temp + ";"
                    If .HomeAddressCountry > "" Then temp = temp + .HomeAddressCountry
                    temp = temp + vbCrLf
                End If
                If .OtherAddressCity > "" Then
                    temp = temp + "ADR;POSTAL:;;"
                    If .OtherAddressStreet > "" Then temp = temp + .Replace(.OtherAddressStreet, vbCrLf, ", ")
                    temp = temp + ";"
                    If .OtherAddressCity > "" Then temp = temp + .OtherAddressCity
                    temp = temp + ";"
                    If .OtherAddressState > "" Then temp = temp + .OtherAddressState
                    temp = temp + ";"
                    If .OtherAddressPostalCode > "" Then temp = temp + .OtherAddressPostalCode
                    temp = temp + ";"
                    If .OtherAddressCountry > "" Then temp = temp + .OtherAddressCountry
                    temp = temp + vbCrLf
                End If
                If .Email1Address > "" Then temp = temp + "EMAIL;PREF;INTERNET:" + .Email1Address + vbCrLf
                If .Email2Address > "" Then temp = temp + "EMAIL;INTERNET:" + .Email2Address + vbCrLf
                If .Email3Address > "" Then temp = temp + "EMAIL;INTERNET:" + .Email3Address + vbCrLf
                If .Birthday > "" Then ' Format in Germany: 13.08.1960
                    If Len(.Birthday) = 10 And InStr(.Birthday, ".") Then
                        If CInt(Right(.Birthday, 4) > 1900) And CInt(Right(.Birthday, 4) < 2030) Then temp = temp + "BDAY:" + Right(.Birthday, 4) + "-" + Mid(.Birthday, 4, 2) + "-" + Left(.Birthday, 2) + vbCrLf
                    End If
                End If
                temp = temp + "END:VCARD" + vbCrLf
                fs.WriteText temp
                fs.SaveToFile "C:\_\vcards\" + .FullName + " (" + Trim(Str(counter)) + ").vcf", 2
                counter = counter + 1
                fs.Close
            End If
        End With
    Next oItem
End Sub