Rempir un répertoire Contacts dans Outlook avec le contenu d'un table

[Heureux-oli]

Voilà le code complet que j'ai mis dans un module Access.
La table s'appelle "tbl_Contacts"

Je l'ai testé et il fonctionne.

Le principe, c'est de supprimer le répertoire "Mes Contacts".
Je crée un répertoire "Mes Contacts" vide.

Ensuite, à l'aide d'un RecordSet, je vais remplir ce répertoire avec les contacts qui se trouvent dans ma table.
[edit]Ne pas oublier d'ajouter la référence MicrosoftOutlook[/edit]

Ma table, je l'obtiens avec ce SQL

Code sql :

1
2
SELECT Contacts.First, Contacts.Last, Contacts.Title, Contacts.Company, Contacts.Department, Contacts.Office, Contacts.[Post Office Box], Contacts.Address, Contacts.City, Contacts.State, Contacts.[Zip/Postal Code], Contacts.Country, Contacts.Phone, Contacts.[Mobile Phone], Contacts.[Pager Phone], Contacts.[Home2 Phone], Contacts.[Assistant Phone Number], Contacts.[Business Fax], Contacts.[Home Fax], Contacts.[Other Fax], Contacts.[Telex Number], Contacts.[Display name], Contacts.[E-mail type], Contacts.[E-mail address], Contacts.Account, Contacts.Assistant, Contacts.[Send Rich Text], Contacts.PRIMARY INTO tbl_Contacts
FROM Contacts;

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
Sub AjouterContacts()
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Dim SQL As String
Dim oNS As NameSpace
Dim oFod As MAPIFolder
Dim oFod2 As MAPIFolder
Dim ctItem As ContactItem
Dim oApp As New Outlook.Application
Dim myIt As ContactItem
 
SQL = "select * from tbl_Contacts"
 
Set DB = Application.CurrentDb
Set RS = DB.OpenRecordset(SQL)
Set oNS = oApp.GetNamespace("MAPI")
Set oFod = oNS.GetDefaultFolder(olFolderContacts)
Set oFod2 = oFod.Folders("Mes Contacts")
oFod2.Delete
 
Set oFod2 = oFod.Folders.Add("Mes Contacts")
 
While Not RS.EOF
 
Set myIt = oFod2.Items.Add
With myIt
    .FirstName = Nz(RS.Fields("first"), "")
    .LastName = Nz(RS.Fields("last"), "")
    .Email1Address = Nz(RS.Fields("E-mail ADDRESS"), "")
 
    .Save
End With
RS.MoveNext
 
Wend
Set oApp = Nothing
Set DB = Nothing
 
End Sub