Excelden Vcard'a çevirme Türkçe karakter destek

[sinnernekolens]

Merhaba arkadaşlar iyi pazarlar,

Aşağıdaki formülde Türkçe karakteri desteklemiyor. Desteklemesi için ne yapabilirim? yardımlarınızı rica ederim

Option Explicit

Public Sub Create_VCF()
'Open a File in Specific Path in Output or Append mode
Dim FileNum As Integer, Filename As String
Dim iRow As Double, OutFilePath As String, vcfVer As Integer
Dim Fname As String, lName As String, PhNum As String, MoNum As String, EmailId As String

iRow = 2
FileNum = FreeFile

Filename = VBA.Trim(ThisWorkbook.Sheets("InputForm").Cells(2, 6))
OutFilePath = ThisWorkbook.Path & "\" & Filename
vcfVer = ThisWorkbook.Sheets("InputForm").Cells(2, 7).Value

If vcfVer = 0 Then vcfVer = 3
If Filename = "" Then OutFilePath = ThisWorkbook.Path & "\OutputVCF.VCF"
Open OutFilePath For Output As FileNum

'Loop through Excel Sheet each row and write it to VCF File
While VBA.Trim(ThisWorkbook.Sheets("InputForm").Cells(iRow, 1)) <> ""
Fname = VBA.Trim(ThisWorkbook.Sheets("InputForm").Cells(iRow, 1))
lName = VBA.Trim(ThisWorkbook.Sheets("InputForm").Cells(iRow, 2))
MoNum = VBA.Trim(ThisWorkbook.Sheets("InputForm").Cells(iRow, 3))
PhNum = VBA.Trim(ThisWorkbook.Sheets("InputForm").Cells(iRow, 4))
EmailId = VBA.Trim(ThisWorkbook.Sheets("InputForm").Cells(iRow, 5))

Print #FileNum, "BEGIN:VCARD"
Print #FileNum, "VERSION:" & vcfVer & ".0"
Print #FileNum, "N:" & lName & ";" & Fname & ";;;"
Print #FileNum, "FN:" & Fname & " " & lName
If MoNum <> "" Then Print #FileNum, "TEL;TYPE=CELL;TYPE=PREF:" & MoNum
If PhNum <> "" Then Print #FileNum, "TEL;TYPE=WORK,VOICE:" & PhNum
If EmailId <> "" Then Print #FileNum, "EMAIL:" & EmailId
Print #FileNum, "END:VCARD"
iRow = iRow + 1
If iRow > 10 Then
End If
Wend
'Close the File
Close #FileNum
MsgBox "Contacts Converted to Saved To: " & OutFilePath
End Sub

#If VBA7 Then
' New VBA7 editor
#If Win64 Then
'Microsoft Office - 64 bit version
Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As LongPtr, ByVal Operation As String, ByVal Filename As String, _
Optional ByVal Parameters As String, Optional ByVal Directory As String, Optional ByVal WindowStyle As Long = vbMinimizedFocus) As LongPtr
#Else
'Microsoft Office - 32 bit version
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal Operation As String, ByVal Filename As String, _
Optional ByVal Parameters As String, Optional ByVal Directory As String,Optional ByVal WindowStyle As Long = vbMinimizedFocus )As Long
#End If
#Else
'VBA version 6 or earlier
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal Operation As String, ByVal Filename As String, _
Optional ByVal Parameters As String, Optional ByVal Directory As String,Optional ByVal WindowStyle As Long = vbMinimizedFocus )As Long
#End If

 

[Asri]

Benim hazırladığım programı deneyebilirsiniz.

http://www.excel.web.tr/f135/excel-vcard-telefon-rehberi-hazyrlama-programy-t144897.html