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 : Sélectionner tout - Visualiser dans une fenêtre à part
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 : 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 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
Partager