DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Haluk Hocam Türkçe Karakter Desteği Yok acaba yardımcı olabilir misiniz ?
Sub Test2()
'Haluk - 21/08/2018
'
Dim objShell As Object
Dim strDesktop As String, i As Long, NoA As Long
Dim Name As Variant, lastName As String, firstName As String
Set objShell = CreateObject("Wscript.Shell")
strDesktop = objShell.SpecialFolders("Desktop")
Open strDesktop & "\DemoVCF.vcf" For Output As #1
NoA = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To NoA
Name = Split(Trim(Range("A" & i).Text), " ")
lastName = Name(UBound(Name))
firstName = Trim(Replace(Range("A" & i).Text, lastName, ""))
myStr = "BEGIN:VCARD" & vbCrLf
myStr = myStr & "VERSION:3.0" & vbCrLf
myStr = myStr & "N;CHARSET=UTF-8;:" & lastName & ";" & firstName & ";;;" & vbCrLf
myStr = myStr & "FN;CHARSET=UTF-8;:" & Range("A" & i) & vbCrLf
myStr = myStr & "TEL;type=CELL;type=VOICE;type=pref:" & Range("B" & i) & vbCrLf
myStr = myStr & "TEL;type=HOME;type=VOICE:" & Range("C" & i) & vbCrLf
myStr = myStr & "EMAIL;TYPE=HOME,TYPE=pref;TYPE=INTERNET:" & Range("D" & i) & vbCrLf
myStr = myStr & "END:VCARD" & vbCrLf
Name = ""
Print #1, myStr
Next
Close #1
Set objShell = Nothing
End Sub
Hocam revize ettiğiniz kodda da Türkçe karakter sorunu var malesef
15 No'lu mesajın ekindeki dosyaya bakınız....