Découvrez une méthode pour partager vos contacts en réseau avec Outlook, mais sans Exchange Server

Public Sub ParcourirContact()
'******************************************************************************
'Déclaration des variables
'******************************************************************************
Dim oCont As ContactItem
Dim oFold As Folder
Dim nM As NameSpace
Dim olApp As Outlook.Application
'******************************************************************************
'Affectation des objets
'******************************************************************************
Set olApp = Outlook.Application
Set nM = olApp.GetNamespace("MAPI")
Set oFold = nM.GetDefaultFolder(olFolderContacts)
'Boucle sur tous les contacts
For Each oCont In oFold.Items
    Debug.Print oCont.LastName
Next oCont
'******************************************************************************
'Libération des objets
'******************************************************************************
Set oFold = Nothing
Set nM = Nothing
Set olApp = Nothing

End Sub

Dim db as DAO.Database

Set db = OpenDatabase("F:\Temp\Contact.mdb")

Public Sub ParcourirContact()
'*************************************************************************
' Routine qui va parcourir les enregistrements présents dans le répertoire
' contacts et copier les enregistrements manquants dans la base de données
' Macro crée pour article DVP par Olivier Lebeau
'*************************************************************************
Dim oCont As ContactItem
Dim oFold As Folder
Dim nM As NameSpace
Dim olApp As Outlook.Application
Dim i As Integer
Dim j As Integer

j = 1
' Affectation des objets
Set olApp = Outlook.Application
Set nM = olApp.GetNamespace("MAPI")
Set oFold = nM.GetDefaultFolder(olFolderContacts)

i = oFold.Items.Count
' Boucle pour parcourir les contacts locaux
For j = 1 To i
    ' Appel à la fonction AccesADB avec comme paramètre le contactItem
    AccesADB (oFold.Items(j))
Next j
End Sub

Public Function AccesADB(mycont As ContactItem)
'**************************************************************************
' Fonction appelée pour envoyer vers la base de données les nouveaux
' contacts
' Fonction écrite pour article DVP par Olivier Lebeau
'**************************************************************************
On Error Resume Next
'******************************************************************************
'Déclaration des variables
'******************************************************************************
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sql As String
sql = "SELECT Contacts.*, Contacts.Nom, Contacts.[Prénom] "
sql = sql & " FROM Contacts "
sql = sql & " Where Contacts.Nom = """ & mycont.LastName
sql = sql & """ AND Contacts.[Prénom] = """ & mycont.FirstName & """;"
' Debug.Print sql
' Vous devez spécifier le chemin complet de votre base de données
' Affectation des objets
Set db = OpenDatabase("f:\temp\contacts.mdb")
Set rs = db.OpenRecordset(sql)
' Debug.Print rs.RecordCount
'**********************************************************************
' La liste des champs traités peut être augmentée en fonction de vos
' besoins. Par facilité, je n'ai volontairement mis que 3 champs
' Si vous rencontrez des problèmes avec les lignes Fields("xxxxx")
' je vous conseille d'utiliser l'index du champ Fields(2)
'**********************************************************************

If rs.RecordCount = 0 Then
    rs.AddNew
    rs.Fields("Nom") = Nz(mycont.LastName, " ")
    rs.Fields("Prénom") = Nz(mycont.FirstName, " ")
    rs.Fields("Adresse de messagerie") = mycont.Email1Address
    rs.Update
End If
'**********************************************************************
' Libération des objets
'**********************************************************************
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
End Function

Public Sub MettreAJourContact()
'******************************************************************************
' Procédure pour récupérer les enregistrements présents dans la base de
' données et les injecter dans le répertoire contact.
'******************************************************************************
'Cette première ligne permet au code d'être exécuté si une 
'erreur se produit.
On Error Resume Next
'******************************************************************************
'Déclaration des variables
'******************************************************************************
Dim oCont As ContactItem
Dim oCo As ContactItem
Dim oFold As Folder
Dim nM As NameSpace
Dim olApp As Outlook.Application
Dim stFilt As String
Dim rs As DAO.Recordset
Dim db As DAO.Database

'******************************************************************************
' Affectation des objets
'******************************************************************************

Set db = OpenDatabase("F:\temp\contacts.mdb")
Set rs = db.OpenRecordset("Select * From Contacts")
Set olApp = Outlook.Application
Set nM = olApp.GetNamespace("MAPI")
Set oFold = nM.GetDefaultFolder(olFolderContacts)
'******************************************************************************
' Boucle pour parcourir les enregistrements de la table
'******************************************************************************

While Not rs.EOF
'Filtre pour recherche des données déjà existantes dans les contacts locaux
stFilt = "[FirstName] = """ & rs.Fields("Prénom")
stFilt = stFilt & """ And [LastName] = """ & rs.Fields("Nom") & """"
' Recherche avec filtre
Set oCo = oFold.Items.Find(stFilt)
' procédure décisionnelle pour copie des données
If oCo = "Nothing" Then
    ' Si pas de données, on les ajoute
    Set oCont = oFold.Items.Add
        oCont.FirstName = rs.Fields("Prénom")
        oCont.LastName = rs.Fields("Nom")
        oCont.Email1Address = rs.Fields("Adresse de messagerie")
        oCont.Save
End If
' Déplacement vers l'enregistrement suivant.
rs.MoveNext
Wend
'******************************************************************************
' Libération des objets
'******************************************************************************
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
End Sub