批量自动导入VCF格式名片文件到Outlook通讯录

Sub massImport()
 
    ' Initialise Variables
    Dim objWSHShell
    Dim objOutlook 
    Dim objActiveInspector
    Dim strVCFilename 
    Dim objFileSystemObject 
    Dim objFSOFile 
    Dim objItem
    Dim lngReturnValue 
    Dim olDiscard
    Dim cntImported As Integer
 
    'change current working directory
    ChDrive ThisWorkbook.Path
    ChDir ThisWorkbook.Path
    sWorkingDirectory = ThisWorkbook.Path & "\"
    impWorkBookName = ThisWorkbook.Name
    Application.Visible = False
 
    'create object
    Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")       
    Set objWSHShell = CreateObject("WScript.Shell")       
 
    vcfFile = Dir(sWorkingDirectory & "*.vcf")
    Do While vcfFile <> ""
 
        'get full name with path
        strVCFilename = sWorkingDirectory & vcfFile
 
        'connect outlook
        Set objOutlook = CreateObject("Outlook.Application")
        If Not(objOutlook Is Nothing) Then
            'handle file name with space
            lngReturnValue = objWSHShell.Run (Chr(34) & strVCFilename & Chr(34), 0, True)
 
            Set objActiveInspector = objOutlook.ActiveInspector
            Set objItem = objActiveInspector.CurrentItem
 
            'save and close if outlook contact card object
            If (objItem.Class = olContact) Then
                objActiveInspector.CurrentItem.Save
                objActiveInspector.CurrentItem.Close olDiscard
                cntImported = cntImported + 1
            End If
 
            'clear
            Set objItem  = Nothing
            Set objActiveInspector  = Nothing
            Set objOutlook = Nothing
        Else
            MsgBox "Outlook连接错误," & strVCFilename & "不能导入"
        End If
        vcfFile = Dir
    Loop
 
    'clear
    Set objFileSystemObject = Nothing    
    Set objWSHShell = Nothing
    Application.Visible = True
    Workbooks(impWorkBookName).Activate
 
    MsgBox "共导入联系人数:" & cntImported
 
End Sub