Vcf Dosyasını Excel'e Dönüştürmek

M

meslek5

Katılım
19 Eylül 2012
Mesajlar
303
Excel Vers. ve Dili
2010 türkçe
Merhaba değerli üstatlar
Telefonumdan dışa aktardığım 1800 kişilik kişiler.vcf dosyasını hiçbir veri kaybı olmadan Türkçe uyumlu olarak Excel dosyasına dönüştürmem gerekiyor.
Birçok program denedim ama ne dönüştürebiliyor nede düzgün aktarabiliyor. Bunu makro ile yapmak mümkün ise yardımınızı bekliyorum.

Telefonumun rehberi aşağıdaki başlıkları içeriyor. Bu başlıklara göre Excel'e aktarabilir miyiz? Şimdiden emeği geçenlere teşekkür ederim.

1-Adı-Soyadı
2-Telefonu-Ev
3-Telefonu-İş
4-Telefonu-İş Faksı
5-Telefonu-Ev Faksı
6-Telefonu-Çağrı Cihazı
7-Telefonu-Diğer
8-Telefonu-Geri Arama
9-Telefonu-Özel
10-E-Posta
11-Gruplar
12-İş Bilgisi
13-Adres
14-Notlar
 
cems

cems

Altın Üye
Katılım
2 Eylül 2005
Mesajlar
2,496
Excel Vers. ve Dili
office 2010 tr 32bit
Altın Üyelik Bitiş Tarihi
13-06-2029
Yapay zeka cevabıdır ve sizden başkasının deneme imkanı dosya sizde oldugundan yok, deneyiniz


1800 kişilik .vcf dosyasını Excel dosyasına dönüştürmek için bir makro oluşturmak mümkün. Öncelikle, .vcf dosyasının içeriğini okuyup gerekli bilgileri çıkarmamız gerekiyor. Ardından bu verileri Excel’e uygun bir formatta yerleştireceğiz.
Aşağıda, bu işlemi gerçekleştirecek bir Excel makrosu örneği veriyorum. Öncelikle, .vcf dosyanızı uygun bir dizine kaydedin ve ardından Excel'de aşağıdaki adımları izleyin:
  1. Excel'i açın.
  2. Alt + F11 tuşlarına basarak VBA editörünü açın.
  3. Insert menüsünden Module seçeneğine tıklayın.
  4. Aşağıdaki kodu kopyalayın ve yeni modül penceresine yapıştırın:


Sub VCFtoExcel()
Dim vcfFile As String
Dim fileContent As String
Dim lines() As String
Dim i As Long
Dim j As Long
Dim currentRow As Long
Dim dict As Object
Dim key As Variant

' VCF dosyanızın yolu
vcfFile = Application.GetOpenFilename("VCF Files (*.vcf), *.vcf", , "VCF Dosyasını Seçin")
If vcfFile = "False" Then Exit Sub

' Dosyayı aç ve içeriğini oku
Open vcfFile For Input As #1
fileContent = Input(LOF(1), #1)
Close #1

' Satırları ayır
lines = Split(fileContent, vbLf)

' Başlıkları ekle
Cells(1, 1).Value = "Adı-Soyadı"
Cells(1, 2).Value = "Telefonu-Ev"
Cells(1, 3).Value = "Telefonu-İş"
Cells(1, 4).Value = "Telefonu-İş Faksı"
Cells(1, 5).Value = "Telefonu-Ev Faksı"
Cells(1, 6).Value = "Telefonu-Çağrı Cihazı"
Cells(1, 7).Value = "Telefonu-Diğer"
Cells(1, 8).Value = "Telefonu-Geri Arama"
Cells(1, 9).Value = "Telefonu-Özel"
Cells(1, 10).Value = "E-Posta"
Cells(1, 11).Value = "Gruplar"
Cells(1, 12).Value = "İş Bilgisi"
Cells(1, 13).Value = "Adres"
Cells(1, 14).Value = "Notlar"

currentRow = 2

' VCF verilerini işle
Set dict = CreateObject("Scripting.Dictionary")

For i = LBound(lines) To UBound(lines)
If InStr(lines(i), "BEGIN:VCARD") > 0 Then
dict.RemoveAll
ElseIf InStr(lines(i), "END:VCARD") > 0 Then
' Verileri yaz
For j = 1 To 14
If dict.Exists(Cells(1, j).Value) Then
Cells(currentRow, j).Value = dict(Cells(1, j).Value)
End If
Next j
currentRow = currentRow + 1
ElseIf InStr(lines(i), "FN:") > 0 Then
dict("Adı-Soyadı") = Mid(lines(i), 4)
ElseIf InStr(lines(i), "TEL;TYPE=HOME:") > 0 Then
dict("Telefonu-Ev") = Mid(lines(i), 16)
ElseIf InStr(lines(i), "TEL;TYPE=WORK:") > 0 Then
dict("Telefonu-İş") = Mid(lines(i), 16)
ElseIf InStr(lines(i), "TEL;TYPE=FAX:") > 0 Then
dict("Telefonu-İş Faksı") = Mid(lines(i), 15)
ElseIf InStr(lines(i), "EMAIL:") > 0 Then
dict("E-Posta") = Mid(lines(i), 7)
' Burada diğer alanlar için benzer kontroller ekleyebilirsiniz
End If
Next i

MsgBox "Dönüştürme tamamlandı!", vbInformation
End Sub

  1. Kodun çalıştırılması için F5 tuşuna basın veya Run menüsünden Run Sub/UserForm seçeneğini seçin.
  2. VCF dosyanızı seçin ve makro çalışacaktır.
Önemli Notlar:
  • Bu kod sadece temel alanları işler. Diğer telefon türleri, adres ve notlar için benzer mantıkla eklemeler yapmanız gerekecek.
  • Dönüşüm sonrası verilerinizi kontrol edin ve gerektiğinde düzeltmeler yapın.
 
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
171
Excel Vers. ve Dili
Excel 2021 Türkçe
Kod: 
Sub ImportVCFFile()
    Dim fso As Object
    Dim txtStream As Object
    Dim filePath As String
    Dim fileContent As String
    Dim lines() As String
    Dim i As Long
    Dim rowIndex As Long
    Dim line As String
    Dim propName As String, propValue As String
    Dim phoneType As String
    Dim types() As String
    Dim n As Long
    Dim typePart As String

    Dim nameFull As String
    Dim phoneHome As String
    Dim phoneWork As String
    Dim phoneWorkFax As String
    Dim phoneHomeFax As String
    Dim phonePager As String
    Dim phoneOther As String
    Dim phoneCallback As String
    Dim phonePrivate As String
    Dim email As String
    Dim groups As String
    Dim jobInfo As String
    Dim address As String
    Dim notes As String

    filePath = "C:\DosyaYolu\kisiler.vcf" ' Buraya .vcf dosyanızın tam yolunu yazın
    

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set txtStream = fso.OpenTextFile(filePath, 1, False, -1) ' -1 UTF-8 anlamına gelir
    fileContent = txtStream.ReadAll
    txtStream.Close
    

    lines = Split(fileContent, vbCrLf)
    

    With Sheets("Sheet1")
        .Cells(1, 1).Value = "Adı-Soyadı"
        .Cells(1, 2).Value = "Telefonu-Ev"
        .Cells(1, 3).Value = "Telefonu-İş"
        .Cells(1, 4).Value = "Telefonu-İş Faksı"
        .Cells(1, 5).Value = "Telefonu-Ev Faksı"
        .Cells(1, 6).Value = "Telefonu-Çağrı Cihazı"
        .Cells(1, 7).Value = "Telefonu-Diğer"
        .Cells(1, 8).Value = "Telefonu-Geri Arama"
        .Cells(1, 9).Value = "Telefonu-Özel"
        .Cells(1, 10).Value = "E-Posta"
        .Cells(1, 11).Value = "Gruplar"
        .Cells(1, 12).Value = "İş Bilgisi"
        .Cells(1, 13).Value = "Adres"
        .Cells(1, 14).Value = "Notlar"
    End With
    

    rowIndex = 2
    

    For i = 0 To UBound(lines)
        line = lines(i)
        
        If line = "BEGIN:VCARD" Then

            nameFull = ""
            phoneHome = ""
            phoneWork = ""
            phoneWorkFax = ""
            phoneHomeFax = ""
            phonePager = ""
            phoneOther = ""
            phoneCallback = ""
            phonePrivate = ""
            email = ""
            groups = ""
            jobInfo = ""
            address = ""
            notes = ""
        ElseIf line = "END:VCARD" Then

            With Sheets("Sheet1")
                .Cells(rowIndex, 1).Value = nameFull
                .Cells(rowIndex, 2).Value = phoneHome
                .Cells(rowIndex, 3).Value = phoneWork
                .Cells(rowIndex, 4).Value = phoneWorkFax
                .Cells(rowIndex, 5).Value = phoneHomeFax
                .Cells(rowIndex, 6).Value = phonePager
                .Cells(rowIndex, 7).Value = phoneOther
                .Cells(rowIndex, 8).Value = phoneCallback
                .Cells(rowIndex, 9).Value = phonePrivate
                .Cells(rowIndex, 10).Value = email
                .Cells(rowIndex, 11).Value = groups
                .Cells(rowIndex, 12).Value = jobInfo
                .Cells(rowIndex, 13).Value = address
                .Cells(rowIndex, 14).Value = notes
            End With
            rowIndex = rowIndex + 1
        Else
            ' Satırı işle
            If InStr(line, ":") > 0 Then
                propName = Trim(Left(line, InStr(line, ":") - 1))
                propValue = Trim(Mid(line, InStr(line, ":") + 1))
                

                Do While i + 1 <= UBound(lines) And (Left(lines(i + 1), 1) = " " Or Left(lines(i + 1), 1) = vbTab)
                    i = i + 1
                    propValue = propValue & Trim(Mid(lines(i), 2))
                Loop
                

                If InStr(propName, "ENCODING=QUOTED-PRINTABLE") > 0 Then
                    propValue = DecodeQuotedPrintable(propValue)
                End If
                

                If propName Like "FN*" Then
                    nameFull = propValue
                ElseIf Left(propName, 4) = "TEL;" Or propName = "TEL" Then
                    phoneType = "OTHER" ' Varsayılan değer
                    typePart = ""
                    If InStr(propName, ";TYPE=") > 0 Then
                        typePart = Mid(propName, InStr(propName, ";TYPE=") + 6)
                        If InStr(typePart, ";") > 0 Then
                            typePart = Left(typePart, InStr(typePart, ";") - 1)
                        End If
                        phoneType = UCase(typePart)
                    End If
                    Select Case phoneType
                        Case "HOME"
                            phoneHome = propValue
                        Case "WORK"
                            phoneWork = propValue
                        Case "WORK;FAX", "FAX;WORK"
                            phoneWorkFax = propValue
                        Case "HOME;FAX", "FAX;HOME"
                            phoneHomeFax = propValue
                        Case "PAGER"
                            phonePager = propValue
                        Case "CALLBACK"
                            phoneCallback = propValue
                        Case "PRIVATE"
                            phonePrivate = propValue
                        Case Else
                            phoneOther = propValue
                    End Select
                ElseIf propName Like "EMAIL*" Then
                    email = propValue
                ElseIf propName Like "ADR*" Then
                    address = propValue
                ElseIf propName = "NOTE" Then
                    notes = propValue
                ElseIf propName = "ORG" Then
                    jobInfo = propValue
                ElseIf propName = "TITLE" Then
                    If jobInfo <> "" Then
                        jobInfo = jobInfo & ", " & propValue
                    Else
                        jobInfo = propValue
                    End If
                ElseIf propName = "CATEGORIES" Then
                    groups = propValue
                End If
            End If
        End If
    Next i
    
    MsgBox "Aktarım tamamlandı!", vbInformation
End Sub

Function DecodeQuotedPrintable(ByVal strEncoded As String) As String
    Dim strDecoded As String
    Dim i As Long
    Dim strChar As String
    Dim intCharCode As Integer
    
    i = 1
    Do While i <= Len(strEncoded)
        strChar = Mid$(strEncoded, i, 1)
        If strChar = "=" Then
            If Mid$(strEncoded, i + 1, 1) = vbCr Or Mid$(strEncoded, i + 1, 1) = vbLf Then
                ' Yumuşak satır sonu, yok say
                i = i + 1
            Else
                intCharCode = Val("&H" & Mid$(strEncoded, i + 1, 2))
                strDecoded = strDecoded & ChrW(intCharCode)
                i = i + 2
            End If
        Else
            strDecoded = strDecoded & strChar
        End If
        i = i + 1
    Loop
    DecodeQuotedPrintable = strDecoded
End Function
-
  • Kodda yer alan filePath değişkenini kendi .vcf dosyanızın tam dosya yoluyla değiştirin.
Bu şekilde deneyip sonucu paylaşabilir misiniz?
 
M

meslek5

Katılım
19 Eylül 2012
Mesajlar
303
Excel Vers. ve Dili
2010 türkçe
pitchoute' Alıntı:
Kod: 
Sub ImportVCFFile()
    Dim fso As Object
    Dim txtStream As Object
    Dim filePath As String
    Dim fileContent As String
    Dim lines() As String
    Dim i As Long
    Dim rowIndex As Long
    Dim line As String
    Dim propName As String, propValue As String
    Dim phoneType As String
    Dim types() As String
    Dim n As Long
    Dim typePart As String

    Dim nameFull As String
    Dim phoneHome As String
    Dim phoneWork As String
    Dim phoneWorkFax As String
    Dim phoneHomeFax As String
    Dim phonePager As String
    Dim phoneOther As String
    Dim phoneCallback As String
    Dim phonePrivate As String
    Dim email As String
    Dim groups As String
    Dim jobInfo As String
    Dim address As String
    Dim notes As String

    filePath = "C:\DosyaYolu\kisiler.vcf" ' Buraya .vcf dosyanızın tam yolunu yazın
   

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set txtStream = fso.OpenTextFile(filePath, 1, False, -1) ' -1 UTF-8 anlamına gelir
    fileContent = txtStream.ReadAll
    txtStream.Close
   

    lines = Split(fileContent, vbCrLf)
   

    With Sheets("Sheet1")
        .Cells(1, 1).Value = "Adı-Soyadı"
        .Cells(1, 2).Value = "Telefonu-Ev"
        .Cells(1, 3).Value = "Telefonu-İş"
        .Cells(1, 4).Value = "Telefonu-İş Faksı"
        .Cells(1, 5).Value = "Telefonu-Ev Faksı"
        .Cells(1, 6).Value = "Telefonu-Çağrı Cihazı"
        .Cells(1, 7).Value = "Telefonu-Diğer"
        .Cells(1, 8).Value = "Telefonu-Geri Arama"
        .Cells(1, 9).Value = "Telefonu-Özel"
        .Cells(1, 10).Value = "E-Posta"
        .Cells(1, 11).Value = "Gruplar"
        .Cells(1, 12).Value = "İş Bilgisi"
        .Cells(1, 13).Value = "Adres"
        .Cells(1, 14).Value = "Notlar"
    End With
   

    rowIndex = 2
   

    For i = 0 To UBound(lines)
        line = lines(i)
       
        If line = "BEGIN:VCARD" Then

            nameFull = ""
            phoneHome = ""
            phoneWork = ""
            phoneWorkFax = ""
            phoneHomeFax = ""
            phonePager = ""
            phoneOther = ""
            phoneCallback = ""
            phonePrivate = ""
            email = ""
            groups = ""
            jobInfo = ""
            address = ""
            notes = ""
        ElseIf line = "END:VCARD" Then

            With Sheets("Sheet1")
                .Cells(rowIndex, 1).Value = nameFull
                .Cells(rowIndex, 2).Value = phoneHome
                .Cells(rowIndex, 3).Value = phoneWork
                .Cells(rowIndex, 4).Value = phoneWorkFax
                .Cells(rowIndex, 5).Value = phoneHomeFax
                .Cells(rowIndex, 6).Value = phonePager
                .Cells(rowIndex, 7).Value = phoneOther
                .Cells(rowIndex, 8).Value = phoneCallback
                .Cells(rowIndex, 9).Value = phonePrivate
                .Cells(rowIndex, 10).Value = email
                .Cells(rowIndex, 11).Value = groups
                .Cells(rowIndex, 12).Value = jobInfo
                .Cells(rowIndex, 13).Value = address
                .Cells(rowIndex, 14).Value = notes
            End With
            rowIndex = rowIndex + 1
        Else
            ' Satırı işle
            If InStr(line, ":") > 0 Then
                propName = Trim(Left(line, InStr(line, ":") - 1))
                propValue = Trim(Mid(line, InStr(line, ":") + 1))
               

                Do While i + 1 <= UBound(lines) And (Left(lines(i + 1), 1) = " " Or Left(lines(i + 1), 1) = vbTab)
                    i = i + 1
                    propValue = propValue & Trim(Mid(lines(i), 2))
                Loop
               

                If InStr(propName, "ENCODING=QUOTED-PRINTABLE") > 0 Then
                    propValue = DecodeQuotedPrintable(propValue)
                End If
               

                If propName Like "FN*" Then
                    nameFull = propValue
                ElseIf Left(propName, 4) = "TEL;" Or propName = "TEL" Then
                    phoneType = "OTHER" ' Varsayılan değer
                    typePart = ""
                    If InStr(propName, ";TYPE=") > 0 Then
                        typePart = Mid(propName, InStr(propName, ";TYPE=") + 6)
                        If InStr(typePart, ";") > 0 Then
                            typePart = Left(typePart, InStr(typePart, ";") - 1)
                        End If
                        phoneType = UCase(typePart)
                    End If
                    Select Case phoneType
                        Case "HOME"
                            phoneHome = propValue
                        Case "WORK"
                            phoneWork = propValue
                        Case "WORK;FAX", "FAX;WORK"
                            phoneWorkFax = propValue
                        Case "HOME;FAX", "FAX;HOME"
                            phoneHomeFax = propValue
                        Case "PAGER"
                            phonePager = propValue
                        Case "CALLBACK"
                            phoneCallback = propValue
                        Case "PRIVATE"
                            phonePrivate = propValue
                        Case Else
                            phoneOther = propValue
                    End Select
                ElseIf propName Like "EMAIL*" Then
                    email = propValue
                ElseIf propName Like "ADR*" Then
                    address = propValue
                ElseIf propName = "NOTE" Then
                    notes = propValue
                ElseIf propName = "ORG" Then
                    jobInfo = propValue
                ElseIf propName = "TITLE" Then
                    If jobInfo <> "" Then
                        jobInfo = jobInfo & ", " & propValue
                    Else
                        jobInfo = propValue
                    End If
                ElseIf propName = "CATEGORIES" Then
                    groups = propValue
                End If
            End If
        End If
    Next i
   
    MsgBox "Aktarım tamamlandı!", vbInformation
End Sub

Function DecodeQuotedPrintable(ByVal strEncoded As String) As String
    Dim strDecoded As String
    Dim i As Long
    Dim strChar As String
    Dim intCharCode As Integer
   
    i = 1
    Do While i <= Len(strEncoded)
        strChar = Mid$(strEncoded, i, 1)
        If strChar = "=" Then
            If Mid$(strEncoded, i + 1, 1) = vbCr Or Mid$(strEncoded, i + 1, 1) = vbLf Then
                ' Yumuşak satır sonu, yok say
                i = i + 1
            Else
                intCharCode = Val("&H" & Mid$(strEncoded, i + 1, 2))
                strDecoded = strDecoded & ChrW(intCharCode)
                i = i + 2
            End If
        Else
            strDecoded = strDecoded & strChar
        End If
        i = i + 1
    Loop
    DecodeQuotedPrintable = strDecoded
End Function
-
  • Kodda yer alan filePath değişkenini kendi .vcf dosyanızın tam dosya yoluyla değiştirin.
Bu şekilde deneyip sonucu paylaşabilir misiniz?
Genişletmek için tıkla ...
Emeğiniz ve ilginiz için çok teşekkür ederim. Denedim ama sadece 1. satıra başlıkları yazıyor diğer bilgilerin hiçbiri gelmiyor.
 
Zeki Gürsoy

Zeki Gürsoy

Uzman
Uzman
Katılım
31 Aralık 2005
Mesajlar
4,354
Excel Vers. ve Dili
Office 365 (64 bit) - Türkçe
VCF dosyalarında işletim sistemi versiyonuna göre bazen ufak tefek farklılıklar olabiliyor. En azından içeriğini değiştirerek bir görsel ekleyin ki, isabetli bir cevap gelsin.

.
 
M

meslek5

Katılım
19 Eylül 2012
Mesajlar
303
Excel Vers. ve Dili
2010 türkçe
Zeki Gürsoy' Alıntı:
VCF dosyalarında işletim sistemi versiyonuna göre bazen ufak tefek farklılıklar olabiliyor. En azından içeriğini değiştirerek bir görsel ekleyin ki, isabetli bir cevap gelsin.

.
Genişletmek için tıkla ...

Kusura bakmayın örnek 1 kişi rehberi oluşturmak aklıma gelmedi. Aşağıdaki linkte 1 kişilik örnek Kişiler.vcf dosyası mevcut rehberimdeki herkes bu başlıklarda kayıtlı. NOT: Ekli olan 1 kişinin adı Hakan TAŞKIN ama dışa vcf oluştururken Türkçe karakterleri bozdu

1 Kişilik vcf

İndir Kişiler

Dosyayı indir Kişiler
dosya.co

3 Kişilik vcf

İndir Kişiler

Dosyayı indir Kişiler
dosya.co
 
Son düzenleme:
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,647
Excel Vers. ve Dili
Pro Plus 2021
Kod: 
Sub ImportVCFFile()
    Dim fso As Object
    Dim txtStream As Object
    Dim filePath As String
    Dim fileContent As String
    Dim lines() As String
    Dim i As Long
    Dim rowIndex As Long
    Dim line As String
    Dim propName As String, propValue As String
    Dim phoneType As String
    Dim types() As String
    Dim n As Long
    Dim typePart As String

    Dim nameFull As String
    Dim phoneHome As String
    Dim phoneWork As String
    Dim phoneWorkFax As String
    Dim phoneHomeFax As String
    Dim phonePager As String
    Dim phoneOther As String
    Dim phoneCallback As String
    Dim phonePrivate As String
    Dim email As String
    Dim groups As String
    Dim jobInfo As String
    Dim address As String
    Dim notes As String

    filePath = "c:\users\emre\downloads\Kişiler.vcf" ' Buraya .vcf dosyanızın tam yolunu yazın
    

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set txtStream = fso.OpenTextFile(filePath, 1, False) ' -1 UTF-8 anlamına gelir
    fileContent = txtStream.ReadAll
    txtStream.Close
    

    lines = Split(fileContent, vbCrLf)
    

    With Sheets("Sheet1")
        .Cells(1, 1).Value = "Adı-Soyadı"
        .Cells(1, 2).Value = "Telefonu-Ev"
        .Cells(1, 3).Value = "Telefonu-İş"
        .Cells(1, 4).Value = "Telefonu-İş Faksı"
        .Cells(1, 5).Value = "Telefonu-Ev Faksı"
        .Cells(1, 6).Value = "Telefonu-Çağrı Cihazı"
        .Cells(1, 7).Value = "Telefonu-Diğer"
        .Cells(1, 8).Value = "Telefonu-Geri Arama"
        .Cells(1, 9).Value = "Telefonu-Özel"
        .Cells(1, 10).Value = "E-Posta"
        .Cells(1, 11).Value = "Gruplar"
        .Cells(1, 12).Value = "İş Bilgisi"
        .Cells(1, 13).Value = "Adres"
        .Cells(1, 14).Value = "Notlar"
    End With
    

    rowIndex = 2
    

    For i = 0 To UBound(lines)
        line = lines(i)
        
        If line = "BEGIN:VCARD" Then

            nameFull = ""
            phoneHome = ""
            phoneWork = ""
            phoneWorkFax = ""
            phoneHomeFax = ""
            phonePager = ""
            phoneOther = ""
            phoneCallback = ""
            phonePrivate = ""
            email = ""
            groups = ""
            jobInfo = ""
            address = ""
            notes = ""
        ElseIf line = "END:VCARD" Then

            With Sheets("Sheet1")
                .Cells(rowIndex, 1).Value = nameFull
                .Cells(rowIndex, 2).Value = phoneHome
                .Cells(rowIndex, 3).Value = phoneWork
                .Cells(rowIndex, 4).Value = phoneWorkFax
                .Cells(rowIndex, 5).Value = phoneHomeFax
                .Cells(rowIndex, 6).Value = phonePager
                .Cells(rowIndex, 7).Value = phoneOther
                .Cells(rowIndex, 8).Value = phoneCallback
                .Cells(rowIndex, 9).Value = phonePrivate
                .Cells(rowIndex, 10).Value = email
                .Cells(rowIndex, 11).Value = groups
                .Cells(rowIndex, 12).Value = jobInfo
                .Cells(rowIndex, 13).Value = address
                .Cells(rowIndex, 14).Value = notes
            End With
            rowIndex = rowIndex + 1
        Else
            ' Satırı işle
            If InStr(line, ":") > 0 Then
                propName = Trim(Left(line, InStr(line, ":") - 1))
                propValue = Trim(Mid(line, InStr(line, ":") + 1))
                

                Do While i + 1 <= UBound(lines) And (Left(lines(i + 1), 1) = " " Or Left(lines(i + 1), 1) = vbTab)
                    i = i + 1
                    propValue = propValue & Trim(Mid(lines(i), 2))
                Loop
                

                If InStr(propName, "ENCODING=QUOTED-PRINTABLE") > 0 Then
                    propValue = QuotedPrintableDecode(propValue)
                End If
                

                If propName Like "FN*" Then
                    nameFull = propValue
                ElseIf Left(propName, 4) = "TEL;" Or propName = "TEL" Then
                    phoneType = "OTHER" ' Varsayılan değer
                    typePart = ""
                    If InStr(propName, ";TYPE=") > 0 Then
                        typePart = Mid(propName, InStr(propName, ";TYPE=") + 6)
                        If InStr(typePart, ";") > 0 Then
                            typePart = Left(typePart, InStr(typePart, ";") - 1)
                        End If
                        phoneType = UCase(typePart)
                    End If
                    Select Case phoneType
                        Case "HOME"
                            phoneHome = propValue
                        Case "WORK"
                            phoneWork = propValue
                        Case "WORK;FAX", "FAX;WORK"
                            phoneWorkFax = propValue
                        Case "HOME;FAX", "FAX;HOME"
                            phoneHomeFax = propValue
                        Case "PAGER"
                            phonePager = propValue
                        Case "CALLBACK"
                            phoneCallback = propValue
                        Case "PRIVATE"
                            phonePrivate = propValue
                        Case Else
                            phoneOther = propValue
                    End Select
                ElseIf propName Like "EMAIL*" Then
                    email = propValue
                ElseIf propName Like "ADR*" Then
                    address = propValue
                ElseIf propName = "NOTE" Then
                    notes = propValue
                ElseIf propName = "ORG" Then
                    jobInfo = propValue
                ElseIf propName = "TITLE" Then
                    If jobInfo <> "" Then
                        jobInfo = jobInfo & ", " & propValue
                    Else
                        jobInfo = propValue
                    End If
                ElseIf propName = "CATEGORIES" Then
                    groups = propValue
                End If
            End If
        End If
    Next i
    
    MsgBox "Aktarım tamamlandı!", vbInformation
End Sub


Public Function QuotedPrintableDecode(SourceData)
    Dim str_ As String, i, x, y, byt_, y1, y2, y3, y4, b1, b2, b3, b4, g, fla_
    
    Dim len_ As Integer

    'remove "=" and ";" from SourceData
    SourceData = Replace(SourceData, "=", "")
    SourceData = Replace(SourceData, ";", "")

    'calculate length
    len_ = Len(SourceData)

    'set string ="" and flag
    str_ = ""

    'check characters step=2
    For i = 0 To (len_ / 2 - 1)
        x = Mid(SourceData, 1 + 2 * i, 2)
        'x = Hex$(Val("&H" & x))

        ' 1 byte = 2 hex characters
        'The value of each individual byte indicates its UTF-8 function, as follows:
        '
        '    00 to 7F hex (0 to 127): first and only byte of a sequence.
        ''''''''''''''    80 to BF hex (128 to 191): continuing byte in a multi-byte sequence.
        '    C2 to DF hex (194 to 223): first byte of a two-byte sequence.
        '    E0 to EF hex (224 to 239): first byte of a three-byte sequence.
        '    F0 to FF hex (240 to 255): first byte of a four-byte sequence.

        If x > "00" And x < "7F" Then
            y = Mid(SourceData, 1 + 2 * i, 2)
            byt_ = 1    ' eg 7F
        End If

        If x > "C2" And x < "DF" Then
            y = Mid(SourceData, 1 + 2 * i, 4)
            y1 = Mid(SourceData, 1 + 2 * i, 2)
            y2 = Mid(SourceData, 1 + 2 * (i + 1), 2)
            i = i + 1
            byt_ = 2    ' eg C2 80
        End If

        If x > "E0" And x < "EF" Then
            y = Mid(SourceData, 1 + 2 * i, 6)
            y1 = Mid(SourceData, 1 + 2 * i, 2)
            y2 = Mid(SourceData, 1 + 2 * (i + 1), 2)
            y3 = Mid(SourceData, 1 + 2 * (i + 2), 2)
            i = i + 2
            byt_ = 3    ' eg E0 A0 80
        End If

        If x > "F0" And x < "FF" Then
            y = Mid(SourceData, 1 + 2 * i, 8)
            y1 = Mid(SourceData, 1 + 2 * i, 2)
            y2 = Mid(SourceData, 1 + 2 * (i + 1), 2)
            y3 = Mid(SourceData, 1 + 2 * (i + 2), 2)
            y4 = Mid(SourceData, 1 + 2 * (i + 3), 2)
            i = i + 3
            byt_ = 4    ' eg F0 90 80 80
        End If

        Select Case byt_
            Case 1
                'U = C1
                b1 = Val("&h" & y)
                g = b1
                g = ChrW(g)
                GoTo 10:

            Case 2
                'U = (C1 – 192) * 64 + C2 – 128
                b1 = Val("&h" & y1)
                b2 = Val("&h" & y2)
                g = ChrW((b1 - 192) * 64 + b2 - 128)
                GoTo 10:

            Case 3
                'U = (C1 – 224) * 4,096 + (C2 – 128) * 64 + C3 – 128
                b1 = Val("&h" & y1)
                b2 = Val("&h" & y2)
                b3 = Val("&h" & y3)
                g = ChrW((b1 - 224) * 4096 + (b2 - 128) * 64 + b3 - 128)
                GoTo 10:
            Case 4
                'U = (C1 – 240) * 262,144 + (C2 – 128) * 4,096 + (C3 – 128) * 64 + C4 – 128
                b1 = Val("&h" & y1)
                b2 = Val("&h" & y2)
                b3 = Val("&h" & y3)
                b4 = Val("&h" & y4)
                g = ChrW((b1 - 240) * 262144 + (b2 - 128) * 4096 + (b3 - 128) * 64 + b4 - 128)
                GoTo 10:
        End Select

        If fla_ = 0 Then
            MsgBox ("At least one unknown character found with UTF-8 Code = " & y)
            fla_ = 1
        End If

10:
        str_ = str_ & g
    Next i

    'DecodedString = str_
    QuotedPrintableDecode = str_

End Function
 
M

meslek5

Katılım
19 Eylül 2012
Mesajlar
303
Excel Vers. ve Dili
2010 türkçe
veyselemre' Alıntı:
Kod: 
Sub ImportVCFFile()
    Dim fso As Object
    Dim txtStream As Object
    Dim filePath As String
    Dim fileContent As String
    Dim lines() As String
    Dim i As Long
    Dim rowIndex As Long
    Dim line As String
    Dim propName As String, propValue As String
    Dim phoneType As String
    Dim types() As String
    Dim n As Long
    Dim typePart As String

    Dim nameFull As String
    Dim phoneHome As String
    Dim phoneWork As String
    Dim phoneWorkFax As String
    Dim phoneHomeFax As String
    Dim phonePager As String
    Dim phoneOther As String
    Dim phoneCallback As String
    Dim phonePrivate As String
    Dim email As String
    Dim groups As String
    Dim jobInfo As String
    Dim address As String
    Dim notes As String

    filePath = "c:\users\emre\downloads\Kişiler.vcf" ' Buraya .vcf dosyanızın tam yolunu yazın
  

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set txtStream = fso.OpenTextFile(filePath, 1, False) ' -1 UTF-8 anlamına gelir
    fileContent = txtStream.ReadAll
    txtStream.Close
  

    lines = Split(fileContent, vbCrLf)
  

    With Sheets("Sheet1")
        .Cells(1, 1).Value = "Adı-Soyadı"
        .Cells(1, 2).Value = "Telefonu-Ev"
        .Cells(1, 3).Value = "Telefonu-İş"
        .Cells(1, 4).Value = "Telefonu-İş Faksı"
        .Cells(1, 5).Value = "Telefonu-Ev Faksı"
        .Cells(1, 6).Value = "Telefonu-Çağrı Cihazı"
        .Cells(1, 7).Value = "Telefonu-Diğer"
        .Cells(1, 8).Value = "Telefonu-Geri Arama"
        .Cells(1, 9).Value = "Telefonu-Özel"
        .Cells(1, 10).Value = "E-Posta"
        .Cells(1, 11).Value = "Gruplar"
        .Cells(1, 12).Value = "İş Bilgisi"
        .Cells(1, 13).Value = "Adres"
        .Cells(1, 14).Value = "Notlar"
    End With
  

    rowIndex = 2
  

    For i = 0 To UBound(lines)
        line = lines(i)
      
        If line = "BEGIN:VCARD" Then

            nameFull = ""
            phoneHome = ""
            phoneWork = ""
            phoneWorkFax = ""
            phoneHomeFax = ""
            phonePager = ""
            phoneOther = ""
            phoneCallback = ""
            phonePrivate = ""
            email = ""
            groups = ""
            jobInfo = ""
            address = ""
            notes = ""
        ElseIf line = "END:VCARD" Then

            With Sheets("Sheet1")
                .Cells(rowIndex, 1).Value = nameFull
                .Cells(rowIndex, 2).Value = phoneHome
                .Cells(rowIndex, 3).Value = phoneWork
                .Cells(rowIndex, 4).Value = phoneWorkFax
                .Cells(rowIndex, 5).Value = phoneHomeFax
                .Cells(rowIndex, 6).Value = phonePager
                .Cells(rowIndex, 7).Value = phoneOther
                .Cells(rowIndex, 8).Value = phoneCallback
                .Cells(rowIndex, 9).Value = phonePrivate
                .Cells(rowIndex, 10).Value = email
                .Cells(rowIndex, 11).Value = groups
                .Cells(rowIndex, 12).Value = jobInfo
                .Cells(rowIndex, 13).Value = address
                .Cells(rowIndex, 14).Value = notes
            End With
            rowIndex = rowIndex + 1
        Else
            ' Satırı işle
            If InStr(line, ":") > 0 Then
                propName = Trim(Left(line, InStr(line, ":") - 1))
                propValue = Trim(Mid(line, InStr(line, ":") + 1))
              

                Do While i + 1 <= UBound(lines) And (Left(lines(i + 1), 1) = " " Or Left(lines(i + 1), 1) = vbTab)
                    i = i + 1
                    propValue = propValue & Trim(Mid(lines(i), 2))
                Loop
              

                If InStr(propName, "ENCODING=QUOTED-PRINTABLE") > 0 Then
                    propValue = QuotedPrintableDecode(propValue)
                End If
              

                If propName Like "FN*" Then
                    nameFull = propValue
                ElseIf Left(propName, 4) = "TEL;" Or propName = "TEL" Then
                    phoneType = "OTHER" ' Varsayılan değer
                    typePart = ""
                    If InStr(propName, ";TYPE=") > 0 Then
                        typePart = Mid(propName, InStr(propName, ";TYPE=") + 6)
                        If InStr(typePart, ";") > 0 Then
                            typePart = Left(typePart, InStr(typePart, ";") - 1)
                        End If
                        phoneType = UCase(typePart)
                    End If
                    Select Case phoneType
                        Case "HOME"
                            phoneHome = propValue
                        Case "WORK"
                            phoneWork = propValue
                        Case "WORK;FAX", "FAX;WORK"
                            phoneWorkFax = propValue
                        Case "HOME;FAX", "FAX;HOME"
                            phoneHomeFax = propValue
                        Case "PAGER"
                            phonePager = propValue
                        Case "CALLBACK"
                            phoneCallback = propValue
                        Case "PRIVATE"
                            phonePrivate = propValue
                        Case Else
                            phoneOther = propValue
                    End Select
                ElseIf propName Like "EMAIL*" Then
                    email = propValue
                ElseIf propName Like "ADR*" Then
                    address = propValue
                ElseIf propName = "NOTE" Then
                    notes = propValue
                ElseIf propName = "ORG" Then
                    jobInfo = propValue
                ElseIf propName = "TITLE" Then
                    If jobInfo <> "" Then
                        jobInfo = jobInfo & ", " & propValue
                    Else
                        jobInfo = propValue
                    End If
                ElseIf propName = "CATEGORIES" Then
                    groups = propValue
                End If
            End If
        End If
    Next i
  
    MsgBox "Aktarım tamamlandı!", vbInformation
End Sub


Public Function QuotedPrintableDecode(SourceData)
    Dim str_ As String, i, x, y, byt_, y1, y2, y3, y4, b1, b2, b3, b4, g, fla_
  
    Dim len_ As Integer

    'remove "=" and ";" from SourceData
    SourceData = Replace(SourceData, "=", "")
    SourceData = Replace(SourceData, ";", "")

    'calculate length
    len_ = Len(SourceData)

    'set string ="" and flag
    str_ = ""

    'check characters step=2
    For i = 0 To (len_ / 2 - 1)
        x = Mid(SourceData, 1 + 2 * i, 2)
        'x = Hex$(Val("&H" & x))

        ' 1 byte = 2 hex characters
        'The value of each individual byte indicates its UTF-8 function, as follows:
        '
        '    00 to 7F hex (0 to 127): first and only byte of a sequence.
        ''''''''''''''    80 to BF hex (128 to 191): continuing byte in a multi-byte sequence.
        '    C2 to DF hex (194 to 223): first byte of a two-byte sequence.
        '    E0 to EF hex (224 to 239): first byte of a three-byte sequence.
        '    F0 to FF hex (240 to 255): first byte of a four-byte sequence.

        If x > "00" And x < "7F" Then
            y = Mid(SourceData, 1 + 2 * i, 2)
            byt_ = 1    ' eg 7F
        End If

        If x > "C2" And x < "DF" Then
            y = Mid(SourceData, 1 + 2 * i, 4)
            y1 = Mid(SourceData, 1 + 2 * i, 2)
            y2 = Mid(SourceData, 1 + 2 * (i + 1), 2)
            i = i + 1
            byt_ = 2    ' eg C2 80
        End If

        If x > "E0" And x < "EF" Then
            y = Mid(SourceData, 1 + 2 * i, 6)
            y1 = Mid(SourceData, 1 + 2 * i, 2)
            y2 = Mid(SourceData, 1 + 2 * (i + 1), 2)
            y3 = Mid(SourceData, 1 + 2 * (i + 2), 2)
            i = i + 2
            byt_ = 3    ' eg E0 A0 80
        End If

        If x > "F0" And x < "FF" Then
            y = Mid(SourceData, 1 + 2 * i, 8)
            y1 = Mid(SourceData, 1 + 2 * i, 2)
            y2 = Mid(SourceData, 1 + 2 * (i + 1), 2)
            y3 = Mid(SourceData, 1 + 2 * (i + 2), 2)
            y4 = Mid(SourceData, 1 + 2 * (i + 3), 2)
            i = i + 3
            byt_ = 4    ' eg F0 90 80 80
        End If

        Select Case byt_
            Case 1
                'U = C1
                b1 = Val("&h" & y)
                g = b1
                g = ChrW(g)
                GoTo 10:

            Case 2
                'U = (C1 – 192) * 64 + C2 – 128
                b1 = Val("&h" & y1)
                b2 = Val("&h" & y2)
                g = ChrW((b1 - 192) * 64 + b2 - 128)
                GoTo 10:

            Case 3
                'U = (C1 – 224) * 4,096 + (C2 – 128) * 64 + C3 – 128
                b1 = Val("&h" & y1)
                b2 = Val("&h" & y2)
                b3 = Val("&h" & y3)
                g = ChrW((b1 - 224) * 4096 + (b2 - 128) * 64 + b3 - 128)
                GoTo 10:
            Case 4
                'U = (C1 – 240) * 262,144 + (C2 – 128) * 4,096 + (C3 – 128) * 64 + C4 – 128
                b1 = Val("&h" & y1)
                b2 = Val("&h" & y2)
                b3 = Val("&h" & y3)
                b4 = Val("&h" & y4)
                g = ChrW((b1 - 240) * 262144 + (b2 - 128) * 4096 + (b3 - 128) * 64 + b4 - 128)
                GoTo 10:
        End Select

        If fla_ = 0 Then
            MsgBox ("At least one unknown character found with UTF-8 Code = " & y)
            fla_ = 1
        End If

10:
        str_ = str_ & g
    Next i

    'DecodedString = str_
    QuotedPrintableDecode = str_

End Function
Genişletmek için tıkla ...

VelselEmre hocam çok çok teşekkür ederim istediğim tam olarak buydu hemde Türkçe karakterlerin hepsini alıyor. Fakat küçük 2 problem var.

Birincisi birçok telefon numaralarını almıyor, galiba telefon no girerken Diğer telefon, Cep Telefonu seçeneklerinin en altındaki Özel seçeneğini seçerek o telefon kime aitse başlığa onun adını yazıyorum. Örnek dosyadan bakabilirsiniz.

İkincisi adresleri almış ama yarısından sonrasını siliyor. "Çankaya Örnek Sokak No:1 Çankaya/Ankara" olan adresin sadece "Çankaya Örnek Sokak N" olan kısmını almış.

Bu 2 sorun giderilirse ve düzenleme sonrası Excel'i tekrar VCF'ye dönüştürürse herkesin işine yarayacak çok mükemmel bir Excel uygulaması haline gelir.

Örnek Dosya

İndir KİŞİLER VCF DÖNÜŞTÜR

Dosyayı indir KİŞİLER VCF DÖNÜŞTÜR
dosya.co
 
Son düzenleme:
M

meslek5

Katılım
19 Eylül 2012
Mesajlar
303
Excel Vers. ve Dili
2010 türkçe
Konu günceldir. Kıymetli hocalarım yardımlarınızı bekliyorum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst