Discussion :

[Razielh]

Bonjour à tous,

Alors à force de chercher, je suis peut être passé à coté, désolé d'avance...

J'aimerai juste importer des contacts de mon carnet d'adresse outlook.
Mais des contacts qui ne se trouve pas dans le dossier contact par défaut, mais par exemple dans un dossier "contact extérieur"

en fouillant j'arrive à pointer mon code vba sur le dossier contact par défaut, mais pas sur un dossier contact de mon choix...
Je bloque, si quelqu'un aurait une piste, merci

[Razielh]

A force de persévérance et de recherche j'ai trouvé !
Donc je poste pour ceux que ça intéresse :

A savoir que :
-Si votre dossier "contact extérieur" est un sous dossier de contact dans outlook faire ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Set oApp = CreateObject("outlook.application")
Set oNS = oApp.GetNamespace("MAPI")
Set oFld = oNS.GetDefaultFolder(olFolderContacts)
Set oCtFld = oFld.Folders("contact extérieur")

- Si votre dossier "contact extérieur" est un dossier de même niveau que contact faire plutôt ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Set oApp = CreateObject("outlook.application")
Set oNS = oApp.GetNamespace("MAPI")
Set octFld = oNS.GetDefaultFolder(olFolderContacts).parent.Folders.item("contact extérieur")

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
44
45
46
'--- Permet d'importer les contacts d'outlook
Function importContact()
 
Set oApp = CreateObject("outlook.application")
Set oNS = oApp.GetNamespace("MAPI")
Set oFld = oNS.GetDefaultFolder(olFolderContacts)
Set oCtFld = oFld.Folders("contact extérieur")
 
Set db = CurrentDb
Set rs = db.OpenRecordset("ListeTest", dbOpenTable)
 
For Each ContactItem In oCtFld.Items
 
        Critere = ""
        'Vérifie si le contact existe déjà dans la base
        Set rs2 = db.OpenRecordset("ListeTest", dbOpenSnapshot)
        Critere = "Mail = '" & ContactItem.Email1Address & "'"
        rs2.FindFirst Critere
 
        If rs2.NoMatch Then 'Ajoute une nouvelle ligne dans la table
            rs.AddNew
            rs!nom = ContactItem.FirstName
            rs!prénom = ContactItem.LastName
            rs!mail = ContactItem.Email1Address
            rs.Update
        Else
            rs.Edit 'Edite la ligne existante dans la table
            rs!nom = ContactItem.FirstName
            rs!prénom = ContactItem.LastName
            rs!mail = ContactItem.Email1Address
            rs.Update
        End If
 
    End If
 
Next ContactItem
 
Set rs = Nothing
Set db = Nothing
Set oCtFld = Nothing
Set oFld = Nothing
Set oNS = Nothing
Set oApp = Nothing
 
 
End Function

Merci !