Excel 转通讯录 vcf 格式 vb 代码

Myein

July 29, 2024

由于工作原因要添加挺多的联系人电话，一个个弄就太麻烦了，上网搜了一下 Excel 格式转 vcf 的教程，发现用 excel 的 vb 代码就可以完成转换，在这里贴一下代码，第一个代码是我用 ChatGPT 生成的，第二个是来自一个国外网友的代码，我用的是第二个，直接用 xlsx 格式也可以食用。代码内的 ORG;CHARSET=UTF-8: 是公司（UTF-8）、TITLE;CHARSET=UTF-8: 是职位（UTF-8）、FN: 是名字、TEL;TYPE=CELL;TYPE=PREF: 是手机号。另外，为了导入的联系人的正确性和不乱码，请将生成的vcf 用记事本打开后另存为 UTF-8 格式。 1：

Sub CreateVCFFromExcel()
    Dim mn_File_Num As Integer
    Dim mn_start_row As Long ' 使用Long类型更合适
    Dim mn_Output_Path As String
    Dim mn_Name As String
    Dim mn_org As String
    Dim mn_title As String
    Dim mn_Mobile_Number As String
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' 确认工作表存在
    
    mn_start_row = 2
    mn_File_Num = FreeFile
    mn_Output_Path = ThisWorkbook.Path & "\PhoneAndEmail.VCF"
    Open mn_Output_Path For Output As mn_File_Num
    
    ' 确认访问的行在工作表的有效范围内
    Do While mn_start_row <= ws.UsedRange.Rows.Count And VBA.Trim(ws.Cells(mn_start_row, 1).Value) <> ""
        mn_Name = VBA.Trim(ws.Cells(mn_start_row, 1).Value)
        mn_org = VBA.Trim(ws.Cells(mn_start_row, 2).Value)
        mn_title = VBA.Trim(ws.Cells(mn_start_row, 3).Value)
        mn_Mobile_Number = VBA.Trim(ws.Cells(mn_start_row, 4).Value) ' Sheet3 修改为 ws
        
        Print #mn_File_Num, "BEGIN:VCARD"
        Print #mn_File_Num, "VERSION:3.0"
        Print #mn_File_Num, "FN:" & mn_Name
        Print #mn_File_Num, "TEL;TYPE=CELL;TYPE=PREF:" & mn_Mobile_Number
        Print #mn_File_Num, "ORG;CHARSET=UTF-8:" & mn_org
        Print #mn_File_Num, "TITLE;CHARSET=UTF-8:" & mn_title
        Print #mn_File_Num, "END:VCARD"
        
        mn_start_row = mn_start_row + 1
    Loop
    
    Close #mn_File_Num
    MsgBox "The Contacts are Saved To: " & mn_Output_Path
End Sub

2：

Sub CreateVCFFromExcel()
    Dim mn_File_Num As Integer
    Dim mn_start_row As Double
    mn_start_row = 2
    mn_File_Num = FreeFile
    mn_Output_Path = ThisWorkbook.Path & "\PhoneAndEmail.VCF"
    Open mn_Output_Path For Output As mn_File_Num
    While VBA.Trim(Sheets("Sheet1").Cells(mn_start_row, 1)) <> ""
        mn_Name = VBA.Trim(Sheets("Sheet1").Cells(mn_start_row, 1))
        mn_org = VBA.Trim(Sheets("Sheet1").Cells(mn_start_row, 2))
        mn_title = VBA.Trim(Sheets("Sheet1").Cells(mn_start_row, 3))
        mn_Mobile_Number = VBA.Trim(Sheets("Sheet1").Cells(mn_start_row, 4))
        Print #mn_File_Num, "BEGIN:VCARD"
        Print #mn_File_Num, "VERSION:3.0"
        Print #mn_File_Num, "FN:" & mn_Name
        Print #mn_File_Num, "TEL;TYPE=CELL;TYPE=PREF:" & mn_Mobile_Number
        Print #mn_File_Num, "ORG;CHARSET=UTF-8:" & mn_org
        Print #mn_File_Num, "TITLE;CHARSET=UTF-8:" & mn_title
        Print #mn_File_Num, "END:VCARD"
        mn_start_row = mn_start_row + 1
    Wend
    Close #mn_File_Num
    MsgBox "The Contacts are Saved To: " & mn_Output_Path
End Sub