从 Excel 导出 联系人名片文件（.vcf）

手动在手机上一个一个存电话号略微费劲，故借助 Excel 管理通讯录，利用 VBA 实现将姓名、电话号码等信息导出为 vcf 文件(iOS 系统联系人导出的格式)

第一次从某钉上给别人打电话知道是给谁打，但接听别人的电话，来电显示号码的情况下不知道是谁打过来的，有保存为联系人的必要

如果有其他好的解决办法(iOS 系统)，欢迎评论留言讨论

".xlsm" 文件链接在下面，有需要自取

https://jey.lanzouw.com/iozmx1367fng

Sub Save_to_iOS_vcf()
 
Dim ChooseFolder As String
    '定义并新建一个对话框对象
    Dim dlgOpen As FileDialog
    Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
    '如果当前没有对话框显示，就让它弹出对话框
    If dlgOpen.Show = -1 Then ChooseFolder = dlgOpen.SelectedItems(1)
    'MsgBox (ChooseFolder)   '弹出选择的文件夹
 
Dim FileName, VcardText As String
FileName = Application.InputBox("请输入导出文件名：", "输入 vcf 文件名")
VcardText = ""
 
For i = 1 To [A65535].End(xlUp).Row()
VcardText = VcardText & Cells(i, 1).Text
Next
VcardText = VcardText & Chr(13) & Chr(10)
Open ChooseFolder & "\" & FileName & ".vcf" For Output As #1
Print #1, VcardText
Close #1
 
Dim WriteStream, BinStream As Object
Set WriteStream = CreateObject("ADODB.Stream")
Set BinStream = CreateObject("ADODB.Stream")
With WriteStream
    .Open
    .Charset = "UTF-8"
    .Type = 2
    .WriteText VcardText
    .SaveToFile ChooseFolder & "\" & FileName & ".vcf", 2
    .Position = 3
End With
With BinStream
    .Open
    .Type = 1
End With
  WriteStream.CopyTo BinStream '数据复制
With BinStream
    .SaveToFile ChooseFolder & "\" & FileName & ".vcf", 2   '保存文件
    .Close
End With
WriteStream.Close
Set WriteStream = Nothing
Set BinStream = Nothing
Application.ScreenUpdating = True
 
If MsgBox("导出成功，是否打开文件路径?", vbYesNo + vbQuestion, "打开文件资源管理器") = vbYes Then
Shell "explorer.exe /select," & ChooseFolder & "\" & FileName & ".vcf", vbNormalFocus
Else
'do nothing
End If
 
End Sub