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

自动在当前目录搜索vcf文件并批量导入,不需要在VBA工程中引用Scripting Host什么的,比较方便