Как импортировать несколько файлов контактов vCard VCF в Outlook 2007 с помощью VBA

Question

Как импортировать несколько файлов контактов vCard VCF в Outlook 2007 с помощью VBA

Answer 1

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

Answer 2

Я столкнулся с несколькими ошибками, ниже та, которая работала для меня. Просто измените путь к каталогу, он будет работать. Каталог должен содержать файлы «.vcf» (любое число выше сотен / тысяч).

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

Answer 3

Это основано на http://www.outlookcode.com/codedetail.aspx?id=212. Убедитесь, что открыто только главное окно Outlook.

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