Macro to bulk import vcards

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

'original code
'strVCName = "C:\vcards\" & fsFile.Name

'Zeda's fix for spaces in filenames
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