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

Sub 数据转换()
Dim Arr, R%, C%
Arr = Sheet1.Range(“A1”).CurrentRegion
ReDim Brr(1 To UBound(Arr) * 8, 1 To 1)
For i = 2 To UBound(Arr)
R = R + 1
Brr(R, 1) = “BEGIN:VCARD”
R = R + 1
Brr(R, 1) = “VERSION:3.0”
R = R + 1
Brr(R, 1) = “N:” & Arr(i, 1) & “;;;;”
R = R + 1
Brr(R, 1) = “FN:” & Arr(i, 1)
For j = 2 To 4
If Len(Arr(i, j)) Then
R = R + 1
Brr(R, 1) = “TEL;TYPE=CELL:” & Arr(i, j)
End If
Next j
If Len(Arr(i, 5)) Then
R = R + 1
Brr(R, 1) = “NOTE;CHARSET=UTF-8:” & Arr(i, 5)
End If
R = R + 1
Brr(R, 1) = “END:VCARD”
Next i
Sheet2.Activate
Sheet2.UsedRange.Clear
Range(“A1”).Resize(R, 1) = Brr
Call 另存为vcf
End Sub
Sub 另存为vcf()
Application.ScreenUpdating = False
Dim ChooseFolder As String
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
If dlgOpen.Show = -1 Then ChooseFolder = dlgOpen.SelectedItems(1)
Dim FileName, VcardText As String
FileName = Application.InputBox(“请输入导出文件名：”, “输入 vcf 文件名”)
VcardText = “”
Sheet2.Activate
Arr = Range(“A1”).CurrentRegion
For i = 1 To UBound(Arr)
VcardText = VcardText & Arr(i, 1) & Chr(13) & Chr(10)
Next
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
If MsgBox(“导出成功，是否打开文件路径?”, vbYesNo + vbQuestion, “打开文件资源管理器”) = vbYes Then
Shell “explorer.exe /select,” & ChooseFolder & “” & FileName & “.vcf”, vbNormalFocus
End If
Application.ScreenUpdating = True
End Sub