EXCEL通讯录 导入手机联系人

ldy

自用多年的很实用的代码，稍微整理一下开起来更加简洁

作用生成VCF 文件 两种格式 1种是用于 360手机助手的（其他的手机助手也许通用，没测试过）
1种是 存入手机TF卡中，用手机的文件浏览器找到点击自动导入的
格式支持4个电话 一个邮箱，一个地址，一个分组信息，对于大多数人来说足够用了

贴个代码放这，注视中也有一些说明

1. Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
   
2. Function VbStrToMultiByte(VbStr As String) As Byte()
   
3.     Dim bufSize As Long
   
4.     Dim arr() As Byte
   
5.     bufSize = WideCharToMultiByte(65001, 0&, StrPtr(VbStr), Len(VbStr), 0, 0, 0, 0)
   
6.     ReDim arr(bufSize - 1)
   
7.     WideCharToMultiByte 65001, 0&, StrPtr(VbStr), Len(VbStr), arr(0), bufSize, 0, 0
   
8.     VbStrToMultiByte = arr
   
9.     '这几行代码以及上述API所起到的作用就是 手工另存为 UTF-8格式
   
10. End Function
    
11. 
    
12. Sub toANSI()                           '360助手 安卓系统 ANSI格式通过手机助手导入
    
13.     Dim s As String, b() As Byte, b1() As Byte, s1 As String
    
14. 
    
15.        For i = 2 To 6 '从第二行开始到第六行，根据实际情况修改
    
16. 
    
17.         s1 = s1 & "BEGIN:VCARD" & vbCrLf & "VERSION:3.0" & vbCrLf
    
18.         s1 = s1 & "CATEGORIES:" & Cells(i, 8) & vbCrLf
    
19.         s1 = s1 & "N:" & Cells(i, 1) & vbCrLf
    
20.         s1 = s1 & "TEL;TYPE=CELL:" & Cells(i, 2) & vbCrLf
    
21.         s1 = s1 & "TEL;TYPE=CELL:" & Cells(i, 3) & vbCrLf
    
22.         s1 = s1 & "TEL;TYPE=WORK:" & Cells(i, 4) & vbCrLf
    
23.         s1 = s1 & "TEL;TYPE=HOME:" & Cells(i, 5) & vbCrLf
    
24.         s1 = s1 & "EMAIL;TYPE=PREF:" & Cells(i, 6) & vbCrLf
    
25.         s1 = s1 & "ADR;TYPE=WORK:" & Cells(i, 7) & vbCrLf
    
26.         s1 = s1 & "END:VCARD" & vbCrLf
    
27.     Next
    
28.     b1 = StrConv(s1, 128)
    
29.     s = "c:\360手机助手导入.vcf"
    
30.     If Dir(s) <> "" Then Kill s
    
31.     Open s For Binary As 1
    
32.     Put 1, , b1
    
33.     Close
    
34. MsgBox s
    
35. 
    
36. End Sub
    
37. Sub toUTH8()   '' 安卓系统 Utf-8格式，直接存在手机卡中导入
    
38.     Dim s As String, b() As Byte, b1() As Byte, s1 As String
    
39.     For i = 2 To 6 '从第二行开始到第六行，根据实际情况修改
    
40. 
    
41.         s1 = s1 & "BEGIN:VCARD" & vbCrLf & "VERSION:3.0" & vbCrLf
    
42.         s1 = s1 & "CATEGORIES:" & Cells(i, 8) & vbCrLf '分组信息，某些机型会忽略此项，如果重要最好用手机助手导入
    
43.         s1 = s1 & "N:" & Cells(i, 1) & vbCrLf
    
44.         s1 = s1 & "TEL;TYPE=CELL:" & Cells(i, 2) & vbCrLf
    
45.         s1 = s1 & "TEL;TYPE=CELL:" & Cells(i, 3) & vbCrLf
    
46.         s1 = s1 & "TEL;TYPE=WORK:" & Cells(i, 4) & vbCrLf
    
47.         s1 = s1 & "TEL;TYPE=HOME:" & Cells(i, 5) & vbCrLf
    
48.         s1 = s1 & "EMAIL;TYPE=PREF:" & Cells(i, 6) & vbCrLf
    
49.         s1 = s1 & "ADR;TYPE=WORK:" & Cells(i, 7) & vbCrLf
    
50.         s1 = s1 & "END:VCARD" & vbCrLf
    
51.     Next
    
52.     b1 = VbStrToMultiByte(s1)  '
    
53.     '所有语句都相同，只是在这里进行格式转换 ，相当于手工另存为UTF-8格式
    
54. 
    
55.     s = "c:\直接存在手机卡中导入.vcf"
    
56.     If Dir(s) <> "" Then Kill s
    
57.     Open s For Binary As 1
    
58.     Put 1, , b1
    
59.     Close
    
60. MsgBox s
    
61. 
    
62. End Sub

复制代码

手机联系人.rar (9.79 KB, 下载次数: 668)

2013-5-22 21:47 上传

点击文件名下载附件

ldy

忘了说，这个代码是基于 安卓系统的，其他系统的没试过，有实验成功其他系统的请说一下

yj0715

支持版主大作

hank2611

留名，我也做了一个类似的。正想发呢。修整下再发来。。

llfccc

你好，我用了这个代码，用你的文档测试没问题，但是我复制代码到其他文档会发现无法控制控制名片输出我指定的那个表，我不希望他输出sheet1这个表，请问在哪里可以自定义这个表，谢谢

ldy

llfccc 发表于 2013-10-10 20:39
你好，我用了这个代码，用你的文档测试没问题，但是我复制代码到其他文档会发现无法控制控制名片输出我指定 ...

你把全部代码复制到你希望要的表的代码窗口中就行了

jiangdong110

谢谢分享，收下了！

rifl

可能会用到，谢谢分享

采购的艳子

谢谢分享，收下了！

cys110

ldy 发表于 2013-10-10 22:11
你把全部代码复制到你希望要的表的代码窗口中就行了

版主，能帮忙看一下我这个如何能实现http://club.excelhome.net/thread-1091513-1-1.html