Importation de plusieures Vcard dans outlook 2003

[flavioteca]

Bonjour,

Comment peut on importer plusieurs Vcard (3680) en une seule fois dans mon dossier contact ?

Outlook 2003 propose l'importation une par une

Merci de votre aide.

Flavio.

[Dolphy35]

Salut,

Il te faut passer par le VBA

ci-joint un code permettant de faire cela :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Sub Save_vCard()
'---------------------------------------------------------------------------------------
' Procédure : Save_vCard
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 20/04/2008
' Détail    : Permet d'importer en masse des vCard vers le dossier Contact
'---------------------------------------------------------------------------------------
'
'Déclarations des variables
    Dim fsoObject As Scripting.FileSystemObject
    Dim fldDossier As Scripting.Folder
    Dim fleFichier As Scripting.File
    Dim MavCard As ContactItem
    Dim MonDossier As Folder
    Dim MonApp As New Outlook.Application
    Dim MonNamespace As Outlook.namespace
    'charge le répertoire dans la variable
    strRepertoire = "C:\temp"
    'instancie les FSO
    Set fsoObject = CreateObject("Scripting.FileSystemObject")
    Set fldDossier = fsoObject.GetFolder(strRepertoire)
    'Instancie l'espace "MAPI" - Session
    Set MonNamespace = MonApp.GetNamespace("MAPI")
    'Test si fichier *.vcf dans le dossier et ajout de celui-ci
    If (fldDossier.Files.Count > 0) Then
        For Each fleFichier In fldDossier.Files
            If (InStr(1, fleFichier.Name, ".vcf", 1) > 0) Then
                Set MavCard = MonNamespace.OpenSharedItem(strRepertoire & "\" & fleFichier.Name)
                MavCard.Save
            End If
        Next
    End If
    'Récupère le dossier Contacts par défaut
    Set MonDossier = MonNamespace.GetDefaultFolder(olFolderContact)
    'Affichage d'outlook dans le dossier
    MonDossier.Display
    'Vide les instances
    Set fsoObject = Nothing
    Set fldDossier = Nothing
    Set MonNamespace = Nothing
    Set MavCard = Nothing
    Set MonDossier = Nothing
End Sub