How to import multiple vCard VCF contact files into Outlook 2007 using VBA

How to开发者_JS百科 import multiple vCard VCF contact files into Outlook 2007 using VBA

Sub OpenSaveVCard()

    Dim objWSHShell As Object
    Dim objOL As Outlook.Application
    Dim colInsp As Outlook.Inspectors
    Dim strVCName As String
    Dim vCounter As Integer
    Dim ff As String

    ff = Dir("d:\contacts\*.vcf")

    Do While Len(ff)

        strVCName = "d:\contacts\" & ff
        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

        ff = Dir

    Loop

End Sub

I have faced few errors, below is the the one which worked for me. Just change the path of the directory, it will work. Directory should contain ".vcf" files(any number above hundreds / thounsands) .

Sub OpenSaveVCard()

    Dim objWSHShell As Object
    'Dim objOL As Outlook.Application
    'Dim colInsp As Outlook.Inspectors
    Dim strVCName As String
    Dim vCounter As Integer
    Dim ff As String

    ff = Dir("D:\Contacts\*.vcf")
    Do While Len(ff)
        On Error Resume Next
        strVCName = "D:\Upender\Contacts\" & ff
        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
            End If
        End If

        ff = Dir()
    Loop
    Set colInsp = Nothing
    Set objOL = Nothing
    Set objWSHShell = Nothing
End Sub

This is based off of http://www.outlookcode.com/codedetail.aspx?id=212. Make sure only the main Outlook window is open.

Sub OpenSaveVCard()

Dim objWSHShell As Object
Dim objOL As Outlook.Application
Dim colInsp As Outlook.Inspectors
Dim strVCName As String
Dim vCounter As Integer
Dim ff As String

ff = Dir("C:\Contacts\*.vcf")

Do While Len(ff)

    strVCName = "C:\Contacts\" & ff
    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

    ff = Dir

Loop

End Sub