手机通讯录导入工具

在写文章之前我想先说一句，希望尊重别人的劳动成果，转载或者抄袭后在末尾加上原文的链接是对作者的尊重，也是鼓励作者再接再厉发帖的动力。

现在的手机五花八门，手机系统也多种多样，联系人的导入导出成了问题。为了自己，也为了身边的朋友，花了2天时间用VB做了一个小工具，大致原理如下：

不管什么系统安卓，windows，塞班，还是国产（爱疯由于没那个资金投入没做测试）都是支持国际通用的vcf格式，所以只需要将你的联系人做成这种格式就可以在很多手机上通用，VCF本身支持很多参数，以下是一个标准的VCF文件内容

 
 


  
  
BEGIN:VCARD  

  
  
VERSION:3.0  

  
  
N:Lastname;Firstname;;;  

  
  
FN:Fullname  

  
  
NICKNAME:Alias  

  
  
TEL;CELL;VOICE:PrimaryCell  

  
  
TEL;CELL;VOICE:SecondaryCell  

  
  
TEL;WORK;VOICE:WorkNum1  

  
  
TEL;WORK;VOICE:WorkNum2  

  
  
TEL;HOME;VOICE:HomeNum1  

  
  
TEL;HOME;VOICE:HomeNum2  

  
  
TEL;HOME;VOICE:RadioNum  

  
  
TEL;WORK;FAX:WorkFax  

  
  
TEL;HOME;FAX:HomeFax  

  
  
TEL;TYPE=ISDN:ISDNNum  

  
  
EMAIL;PREF;INTERNET:Email1  

  
  
EMAIL;INTERNET:Email2  

  
  
EMAIL;INTERNET:Email3  

  
  
URL:Website  

  
  
ORG:Organization  

  
  
TITLE:Grade  

  
  
BDAY:Birthday  

  
  
ADR;TYPE=WORK;CHARSET=UTF-8:WorkStreet3;WorkStreet2;WorkStreet1;WorkCity;WorkProvince;WorkPostalcode;WorkState  

  
  
ADR;TYPE=HOME;CHARSET=UTF-8:HomeStreet3;HomeStreet2;HomeStreet1;HomeCity;HomeProvince;HomePostalcode;HomeState  

  
  
END:VCARD 
 
 

语法很简单，根据英文简写就能猜到是什么东东。

只需要在上面的内容中输入自己联系人信息就可以了，但是一个个输入工作量太大也不太现实，所以就想到了做一个小脚本从Excel表格中一个个去“拿”数据，并且自动做成一个个vCards文件将这些文件拷贝到手机卡就可以导入了，非安卓手机必须一个个导入，安卓可以支持合并的联系人文件导入（批量导入），并且安卓系统支持VCF LABEL字段，所以整个程序设计起来就分为了安卓与非安卓两个方案。

实现过程：

1.数据源：就一个Excel表格，第一次可能需要自己花些时间将自己的联系人输入到程序指定的Excel中。

2.VCF模板

通过复制VCF标准模板，程序将读取到得数据替换模板的内容，最终保存为VCF联系人。

3.读取Excel数据并制成VCF的脚本

 
 


  
  
Const ForReading=1 

  
  
Const ForWriting=2 

  
  
Const ForAppending=8 

  
  
Const OverwriteExisting = True 

  
  
Const DeleteReadOnly = True 

  
  
 

  
  
Varsystem = UCase(InputBox("请选择你的手机系统."  & VbCrLf & "1.Android."  & VbCrLf & "2.Other."))  

  
  
 

  
  
If Varsystem = "" then  

  
  
wscript.quit  

  
  
End If  

  
  
 

  
  
If Not IsNumeric(Varsystem) then  

  
  
wscript.echo "你的输入有误"  

  
  
wscript.quit  

  
  
End If  

  
  
 

  
  
If Varsystem >=3 then  

  
  
wscript.echo "请输入数字1-2"  

  
  
wscript.quit  

  
  
End If  

  
  
 

  
  
    Select Case Varsystem  

  
  
    Case 1  

  
  
        strStatus = "Android" 

  
  
    Case 2  

  
  
        strStatus = "Other" 

  
  
    End Select  

  
  
 

  
  
'Define VcfFolder Path  

  
  
StrVcfFolder = "vCards" 

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
If not objFSO.FolderExists(StrVcfFolder) Then  

  
  
    Set objFolder = objFSO.CreateFolder(StrVcfFolder)  

  
  
End If  

  
  
 

  
  
'Define data and path  

  
  
Set objShell = CreateObject("Wscript.Shell")  

  
  
strCurPath = objShell.CurrentDirectory  

  
  
strDataPath = strCurPath & "\Data"  

  
  
strxlsfile = strDataPath & "\Contact.xls"  

  
  
strTempPath = strCurPath & "\templet"  

  
  
strTempfile = strTempPath & "\" & strStatus & ".vcf"  

  
  
stroldvcfs = strCurPath & "\vCards\*.*"  

  
  
 

  
  
'Delete old vcf files  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
objFSO.DeleteFile(stroldvcfs), DeleteReadOnly  

  
  
 

  
  
'locate source data file  

  
  
Set objExcel = CreateObject("Excel.Application")  

  
  
Set objWorkbook = objExcel.Workbooks.Open(strxlsfile)  

  
  
Set objWorksheet = objWorkbook.Worksheets(1)  

  
  
 

  
  
Dim i, count  

  
  
i = 3 

  
  
count = 0 

  
  
 

  
  
Do Until objExcel.Cells(i, 1).Value = "" 

  
  
strFullname = objExcel.Cells(i, 1).Value  

  
  
strLastname = objExcel.Cells(i, 2).Value  

  
  
strFirstname = objExcel.Cells(i, 3).Value  

  
  
strAlias = objExcel.Cells(i, 4).Value  

  
  
strPrimaryCell = objExcel.Cells(i, 5).Value  

  
  
strSecondaryCell = objExcel.Cells(i, 6).Value  

  
  
strWorkNum1 = objExcel.Cells(i, 7).Value  

  
  
strWorkNum2 = objExcel.Cells(i, 8).Value  

  
  
strWorkFax = objExcel.Cells(i, 9).Value  

  
  
strHomeNum1 = objExcel.Cells(i, 10).Value  

  
  
strHomeNum2 = objExcel.Cells(i, 11).Value  

  
  
strHomeFax = objExcel.Cells(i, 12).Value  

  
  
strRadioNum = objExcel.Cells(i, 13).Value  

  
  
strISDNNum = objExcel.Cells(i, 14).Value  

  
  
strEmail1 = objExcel.Cells(i, 15).Value  

  
  
strEmail2 = objExcel.Cells(i, 16).Value  

  
  
strEmail3 = objExcel.Cells(i, 17).Value  

  
  
strWebsite = objExcel.Cells(i, 18).Value  

  
  
strOrganization = objExcel.Cells(i, 19).Value  

  
  
strGrade = objExcel.Cells(i, 20).Value  

  
  
strQQnum = objExcel.Cells(i, 21).Value  

  
  
strMSNum = objExcel.Cells(i, 22).Value  

  
  
strGoogletalk = objExcel.Cells(i, 23).Value  

  
  
strBirthday = objExcel.Cells(i, 24).Value  

  
  
strWorkStreet3 = objExcel.Cells(i, 25).Value  

  
  
strWorkStreet2 = objExcel.Cells(i, 26).Value  

  
  
strWorkStreet1 = objExcel.Cells(i, 27).Value  

  
  
strWorkCity = objExcel.Cells(i, 28).Value  

  
  
strWorkProvince = objExcel.Cells(i, 29).Value  

  
  
strWorkPostalcode = objExcel.Cells(i, 30).Value  

  
  
strWorkState = objExcel.Cells(i, 31).Value  

  
  
strHomeStreet3 = objExcel.Cells(i, 32).Value  

  
  
strHomeStreet2 = objExcel.Cells(i, 33).Value  

  
  
strHomeStreet1 = objExcel.Cells(i, 34).Value  

  
  
strHomeCity = objExcel.Cells(i, 35).Value  

  
  
strHomeProvince = objExcel.Cells(i, 36).Value  

  
  
strHomePostalcode = objExcel.Cells(i, 37).Value  

  
  
strHomeState = objExcel.Cells(i, 38).Value  

  
  
 

  
  
'copy from templet.vcf  

  
  
strFilename = objExcel.Cells(i, 1).Value & ".vcf"  

  
  
strDstPathfile = strCurPath & "\" & StrVcfFolder & "\" & strFilename  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
objFSO.CopyFile strTempfile, strDstPathfile, OverwriteExisting  

  
  
 

  
  
'=========================================================1  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "Fullname", strFullname)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'=========================================================2  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "Lastname", strLastname)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'=========================================================3  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "Firstname", strFirstname)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'=========================================================4  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "Alias", strAlias)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'=========================================================5  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "PrimaryCell", strPrimaryCell)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'=========================================================6  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "SecondaryCell", strSecondaryCell)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'=========================================================7  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "WorkNum1", strWorkNum1)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'=========================================================8  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "WorkNum2", strWorkNum2)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'=========================================================9  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "WorkFax", strWorkFax)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================10  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "HomeNum1", strHomeNum1)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================11  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "HomeNum2", strHomeNum2)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================12  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "HomeFax", strHomeFax)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================13  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "RadioNum", strRadioNum)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================14  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "ISDNNum", strISDNNum)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================15  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "Email1", strEmail1)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================16  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "Email2", strEmail2)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================17  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "Email3", strEmail3)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================18  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "Website", strWebsite)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================19  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "Organization", strOrganization)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================20  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "Grade", strGrade)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================21  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "QQnum", strQQnum)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================22  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "MSNum", strMSNum)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================23  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "Googletalk", strGoogletalk)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================24  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "Birthday", strBirthday)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================25  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "WorkStreet3", strWorkStreet3)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================26  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "WorkStreet2", strWorkStreet2)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================27  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "WorkStreet1", strWorkStreet1)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================28  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "WorkCity", strWorkCity)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================29  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "WorkProvince", strWorkProvince)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================30  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "WorkPostalcode", strWorkPostalcode)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================31  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "WorkState", strWorkState)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================32  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "HomeStreet3", strHomeStreet3)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================33  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "HomeStreet2", strHomeStreet2)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================34  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "HomeStreet1", strHomeStreet1)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================35  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "HomeCity", strHomeCity)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================36  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "HomeProvince", strHomeProvince)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================37  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "HomePostalcode", strHomePostalcode)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
'========================================================38  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForReading)  

  
  
strText = objFile.ReadAll  

  
  
objFile.Close  

  
  
strNewText = Replace(strText, "HomeState", strHomeState)  

  
  
Set objFile = objFSO.OpenTextFile(strDstPathfile, ForWriting)  

  
  
objFile.WriteLine strNewText  

  
  
objFile.Close  

  
  
 

  
  
ii = i + 1  

  
  
countcount = count + 1  

  
  
Loop  

  
  
 

  
  
objExcel.Quit  

  
  
Wscript.echo "共导入" & count & "个联系人" 
 
 

到此，单个VCF联系人就制作完毕了，拷贝到手机就可以导入了。

4.合并单个联系人为一个

因为安卓系统支持合并的多联系人VCF文件，所以另写了一个脚本合并所有的联系人。

 
 


  
  
Set objShell = CreateObject("Wscript.Shell")  

  
  
strCurPath = objShell.CurrentDirectory  

  
  
strVfolder = strCurPath & "\vCards"  

  
  
stroutfile = strCurPath & "\contacts.vcf"  

  
  
strcmd = "copy /B " & strVfolder & "\*.vcf " & stroutfile  

  
  
objShell.Run("%comspec% /c" & strcmd)  

  
  
wscript.sleep 2000  

  
  
wscript.echo "联系人合成完毕!" 
 
 

5.合并后发现内容中有很多空行和没有实际数值的行，写了个优化脚本，删除多余的空白行和没有值的行。

思路：先将无值行替换成空行再移除空行比较简单。

 
 


  
  
On Error Resume Next  

  
  
 

  
  
Const ForReading=1 

  
  
Const ForWriting=2 

  
  
 

  
  
'Replace all useless line to blank.  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile("contacts.vcf", ForReading)  

  
  
 

  
  
Do Until objFile.AtEndOfStream  

  
  
    strLine = objFile.Readline  

  
  
    strLine = Trim(strLine)  

  
  
    strRline = Right(strLine, 1)  

  
  
    If strRline = ":" Then  

  
  
    strnewline = " " 

  
  
    Else  

  
  
    strnewline = strLine 

  
  
    End if  

  
  
    strNewTextstrNewText = strNewText & strnewline & vbCrLf  

  
  
Loop  

  
  
 

  
  
objFile.Close  

  
  
 

  
  
Set objFile = objFSO.OpenTextFile("contacts.vcf", ForWriting)  

  
  
objFile.Write strNewText  

  
  
objFile.Close  

  
  
 

  
  
'Delete all blank line  

  
  
Set objFSO = CreateObject("Scripting.FileSystemObject")  

  
  
Set objFile = objFSO.OpenTextFile("contacts.vcf", ForReading)  

  
  
 

  
  
Do Until objFile.AtEndOfStream  

  
  
    strLine = objFile.Readline  

  
  
    strLine = Trim(strLine)  

  
  
    If Len(strLine) > 0 Then  

  
  
        strNewContentsstrNewContents = strNewContents & strLine & vbCrLf  

  
  
    End If  

  
  
Loop  

  
  
 

  
  
objFile.Close  

  
  
 

  
  
Set objFile = objFSO.OpenTextFile("contacts.vcf", ForWriting)  

  
  
objFile.Write strNewContents  

  
  
objFile.Close  

  
  
 

  
  
wscript.echo "优化完毕!" 
 
 

优化后的vcf就可以导入安卓系统或者上传到google通讯录了。

本文转自yangye1985 51CTO博客，原文链接：http://blog.51cto.com/yangye/728062，如需转载请自行联系原作者