关注北京、旅行和地学
如何批量导入vCard格式联系人到Outlook
如何批量导入vCard格式联系人到Outlook

如何批量导入vCard格式联系人到Outlook

网上有从Outlook批量导出Vcard格式的教程说明,但是关于如何将Vcard格式的联系人批量导入到Outlook的教程几乎没有。我在网上找到了以下这些操作步骤,成功了,在这里分享。

1,把所有Vcards文件放在一个文件夹内。C:\VCARDS(这个路径需要和代码中的路径相同)

2,打开Outlook的VBA编辑器。(ALT + F11 呼出)
3,单击“工具”–>“引用”,勾中“Windows Script Host Object Model ”和“Microsoft Scripting Runtime”

4,单击“插入”–>“模块”,把下列代码粘帖进去。保存名字例如“A”。

5,单击“工具”–>“运行”–>“宏”,运行刚才保存的名字“A”。

6,运行….

Sub OpenSaveVCard()

Dim objWSHShell As IWshRuntimeLibrary.IWshShell
Dim objOL As Outlook.Application
Dim colInsp As Outlook.Inspectors
Dim strVCName As String
Dim fso As Scripting.FileSystemObject
Dim fsDir As Scripting.Folder
Dim fsFile As Scripting.File
Dim vCounter As Integer

Set fso = New Scripting.FileSystemObject
Set fsDir = fso.GetFolder(“C:\vcards”)

For Each fsFile In fsDir.Files

strVCName = “C:\vcards\” & fsFile.Name
Set objOL = CreateObject(“Outlook.Application”)
Set colInsp = objOL.Inspectors
If colInsp.Count = 0 Then
Set objWSHShell = CreateObject(“WScript.Shell”)
objWSHShell.Run strVCName
Set colInsp = objOL.Inspectors
If Err = 0 Then
Do Until colInsp.Count = 1
DoEvents
Loop
colInsp.Item(1).CurrentItem.Save
colInsp.Item(1).Close olDiscard
Set colInsp = Nothing
Set objOL = Nothing
Set objWSHShell = Nothing
End If
End If

Next

End Sub

30条评论

  1. peggy

    怎么不行了,是下边这整段复制到宏里啊
    Sub OpenSaveVCard()
    Dim objWSHShell As IWshRuntimeLibrary.IWshShell
    Dim objOL As Outlook.Application
    Dim colInsp As Outlook.Inspectors
    Dim strVCName As String
    Dim fso As Scripting.FileSystemObject
    Dim fsDir As Scripting.Folder
    Dim fsFile As Scripting.File
    Dim vCounter As Integer
    Set fso = New Scripting.FileSystemObject
    Set fsDir = fso.GetFolder(”C:\VCARDS”)
    For Each fsFile In fsDir.Files
    strVCName = “C:\VCARDS\” & fsFile.Name
    Set objOL = CreateObject(”Outlook.Application”)
    Set colInsp = objOL.Inspectors
    If colInsp.Count = 0 Then
    Set objWSHShell = CreateObject(”WScript.Shell”)
    objWSHShell.Run Chr(34) & strVCName & Chr(34)
    Set colInsp = objOL.Inspectors
    If Err = 0 Then
    Do Until colInsp.Count = 1
    DoEvents
    Loop
    colInsp.Item(1).CurrentItem.Save
    colInsp.Item(1).Close olDiscard
    Set colInsp = Nothing
    Set objOL = Nothing
    Set objWSHShell = Nothing
    End If
    End If
    Next
    End Sub

  2. 谢谢,我测试是成功的,但是 (”C:\VCARDS”),这里的双引号用错了中文的,希望大家注意,主人应该是在中文输入法状态下写的代码。

  3. heroaunty

    非常感谢楼主提供的方法。我的问题已经解决。
    其中遇到过一个小问题供后人借鉴:objWSHShell.Run strVCName这行报错
    后来发现是不支持文件名中有空格的原因。文件名修改即好。

    by theway:我用的是outlook2007

  4. shy

    感谢楼主。
    下面的修改可以修正带空格文件名的错误。

    Sub OpenSaveVCard()
    Dim objWSHShell As IWshRuntimeLibrary.IWshShell
    Dim objOL As Outlook.Application
    Dim colInsp As Outlook.Inspectors
    Dim strVCName As String
    Dim fso As Scripting.FileSystemObject
    Dim fsDir As Scripting.Folder
    Dim fsFile As Scripting.File
    Dim vCounter As Integer

    Set fso = New Scripting.FileSystemObject
    Set fsDir = fso.GetFolder(“c:\files\Personal\SD_Backup\moto_backup”)
    For Each fsFile In fsDir.Files
    strVCName = “c:\files\Personal\SD_Backup\moto_backup\” & fsFile.Name
    Set objOL = CreateObject(“Outlook.Application”)
    Set colInsp = objOL.Inspectors
    If colInsp.Count = 0 Then
    Set objWSHShell = CreateObject(“WScript.Shell”)

    If InStr(fsFile.Name, ” “) > 0 Then
    strVCName = “c:\files\Personal\SD_Backup\moto_backup\” & Chr(34) & fsFile.Name & Chr(34)
    objWSHShell.Run (Chr(34) & “c:\files\Personal\SD_Backup\moto_backup\” & fsFile.Name & Chr(34))
    Else
    objWSHShell.Run strVCName
    End If

    Set colInsp = objOL.Inspectors
    If Err = 0 Then
    Do Until colInsp.Count = 1
    DoEvents
    Loop
    colInsp.Item(1).CurrentItem.Save
    colInsp.Item(1).Close olDiscard
    Set colInsp = Nothing
    Set objOL = Nothing
    Set objWSHShell = Nothing
    End If
    End If
    Next
    End Sub

  5. WANGZAI

    SHY的程序不错,但运行时屏闪刷新严重,受不了啊。
    请在程序中增加两行:
    开始运行程序中增加一行,防止运行时屏闪:
    Application.ScreenUpdating = False
    最后面程序结束前增加一行:
    Application.ScreenUpdating = True

发表回复

您的电子邮箱地址不会被公开。 必填项已用*标注