giúp em VBA lỗi Run-Time error '52'

[lala_qn]

chào anh chị!
em lên mạng thấy có đoạn code dùng để chuyển danh bạ từ excel sang *vcf
mà em chạy trên exlcel 2016 nó cứ báo lỗi Run-Time error '52'
đoạn code như sau:

Private Sub Create_VCF()
'Open a File in Specific Path in Output or Append mode
Dim FileNum As Integer
Dim iRow As Double
iRow = 2
FileNum = FreeFile
OutFilePath = ThisWorkbook.Path & "D:\OutputVCF.VCF"
Open OutFilePath For Output As FileNum

'Loop through Excel Sheet each row and write it to VCF File
While VBA.Trim(Sheets("Sheet1").Cells(iRow, 1)) <> ""
LName = VBA.Trim(Sheets("Sheet1").Cells(iRow, 1))
FName = VBA.Trim(Sheets("Sheet1").Cells(iRow, 2))
PhNum = VBA.Trim(Sheets("Sheet1").Cells(iRow, 3))

Print #FileNum, "BEGIN:VCARD"
Print #FileNum, "VERSION:3.0"
Print #FileNum, "N:" & LName & ";" & FName & ";;;"
Print #FileNum, "FN:" & LName & " " & FName
Print #FileNum, "TEL;TYPE=CELL;TYPE=PREF:" & PhNum
Print #FileNum, "END:VCARD"
iRow = iRow + 1
Wend

'Close The File
Close #FileNum
MsgBox "Contacts Converted to Saved To: " & OutFilePath & " - Join Email Subscription To Get Latest Updates"
End Sub

đoạn video hướng dẫn

nhờ anh chị giúp em lỗi này ạ, thanks ạ !

 

[lala_qn]

anh chị giúp dùm em với ạ !

 

[NguyenNgocThuHien]

Thay đoạn:

OutFilePath = ThisWorkbook.Path & "D:\OutputVCF.VCF"

Bằng

If ThisWorkbook.Path = "" Then
    OutFilePath = "D:\OutputVCF.VCF"
Else
    OutFilePath = ThisWorkbook.Path & "\OutputVCF.VCF"
End If

 

[befaint]

A/C

Thấy bạn này vào kiểm tra bài thường xuyên... Nhưng chỉ vì chỗ màu đỏ mà mãi chưa thấy ai xem giúp...

 

[lala_qn]

Thay đoạn:

OutFilePath = ThisWorkbook.Path & "D:\OutputVCF.VCF"

Bằng

If ThisWorkbook.Path = "" Then
    OutFilePath = "D:\OutputVCF.VCF"
Else
    OutFilePath = ThisWorkbook.Path & "\OutputVCF.VCF"
End If

file xuất ra *vcf bị lỗi font Tiếng Việt có cách nào giải quyết ko chị ?
em chạy thấy xuất dc file trong folder cùng với folder tạo file ko xuất dc sang ổ D chị

A/C
Thấy bạn này vào kiểm tra bài thường xuyên... Nhưng chỉ vì chỗ màu đỏ mà mãi chưa thấy ai xem giúp...

dạ em sửa lại rùi anh

 

[NguyenNgocThuHien]

Option Explicit

Private Sub Create_VCF()
    
    Dim FileNum As Integer
    Dim iRow As Double
    Dim OutFilePath  As String
    Dim LName As String, Fname As String, phnum As String
    
    Dim FSO As Object ' Scripting.FileSystemObject
    Dim file As Object 'Scripting.TextStream
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    
    
    iRow = 2
    
    
    If ThisWorkbook.Path = "" Then
        OutFilePath = "D:\OutputVCF.VCF"
    Else
        OutFilePath = ThisWorkbook.Path & "\OutputVCF.VCF"
    End If
    
    
    Set file = FSO.CreateTextFile(OutFilePath, True, True)
    
    
    
    'Loop through Excel Sheet each row and write it to VCF File
    While VBA.Trim(Sheets("Sheet1").Cells(iRow, 1)) <> ""
        LName = VBA.Trim(Sheets("Sheet1").Cells(iRow, 1))
        Fname = VBA.Trim(Sheets("Sheet1").Cells(iRow, 2))
        phnum = VBA.Trim(Sheets("Sheet1").Cells(iRow, 3))
        
        
        file.WriteLine "BEGIN:VCARD"
        file.WriteLine "VERSION:3.0"
        file.WriteLine "N:" & LName & ";" & Fname & ";;;"
        
        file.WriteLine "FN:" & LName & " " & Fname
        file.WriteLine "TEL;TYPE=CELL;TYPE=PREF:" & phnum
        file.WriteLine "END:VCARD"
        
        
        
        iRow = iRow + 1
    Wend
    
    file.Close
    
        
    MsgBox "Contacts Converted to Saved To: " & OutFilePath & " - Join Email Subscription To Get Latest Updates"
End Sub

 

[lala_qn]

Option Explicit

Private Sub Create_VCF()
   
    Dim FileNum As Integer
    Dim iRow As Double
    Dim OutFilePath  As String
    Dim LName As String, Fname As String, phnum As String
   
    Dim FSO As Object ' Scripting.FileSystemObject
    Dim file As Object 'Scripting.TextStream
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
   
   
    iRow = 2
   
   
    If ThisWorkbook.Path = "" Then
        OutFilePath = "D:\OutputVCF.VCF"
    Else
        OutFilePath = ThisWorkbook.Path & "\OutputVCF.VCF"
    End If
   
   
    Set file = FSO.CreateTextFile(OutFilePath, True, True)
   
   
   
    'Loop through Excel Sheet each row and write it to VCF File
    While VBA.Trim(Sheets("Sheet1").Cells(iRow, 1)) <> ""
        LName = VBA.Trim(Sheets("Sheet1").Cells(iRow, 1))
        Fname = VBA.Trim(Sheets("Sheet1").Cells(iRow, 2))
        phnum = VBA.Trim(Sheets("Sheet1").Cells(iRow, 3))
       
       
        file.WriteLine "BEGIN:VCARD"
        file.WriteLine "VERSION:3.0"
        file.WriteLine "N:" & LName & ";" & Fname & ";;;"
       
        file.WriteLine "FN:" & LName & " " & Fname
        file.WriteLine "TEL;TYPE=CELL;TYPE=PREF:" & phnum
        file.WriteLine "END:VCARD"
       
       
       
        iRow = iRow + 1
    Wend
   
    file.Close
   
       
    MsgBox "Contacts Converted to Saved To: " & OutFilePath & " - Join Email Subscription To Get Latest Updates"
End Sub

hình như file *vcf để import lên danh bạ đt thường dùng mã hóa UTF-8 để tránh lỗi font chữ, cái này làm dc ko chị nhỉ