Comment importer plusieurs fichiers de contact vCard VCF dans Outlook 2007 en utilisant VBA

Question

Comment importer plusieurs fichiers de contact vCard VCF dans Outlook 2007 en utilisant 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

Ceci est basé sur des http://www.outlookcode.com/codedetail.aspx?id=212. Assurez-vous que seule la fenêtre Outlook principale est ouverte.

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 

Answer 3

J'ai fait face à quelques erreurs, ci-dessous est le celui qui a fonctionné pour moi. Il suffit de changer le chemin du répertoire, cela va fonctionner. Le répertoire devrait contenir des fichiers ".vcf" (n'importe quel nombre au dessus de centaines/thons).

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