Synchroniser les contacts entre Access et Outlook

Denis Hulo

Objectif : apprendre à créer un outil Access permettant de synchroniser les contacts entre Access et Outlook.

Niveau requis : avancé.

Commentez cet article : Commentez

- Titre : Synchroniser les contacts entre Access et Outlook

- Auteur : Denis Hulo

- Parution : 29 mars 2018

- Public visé :

- Licence : Copyright ® 2018 Denis Hulo. Aucune reproduction, même partielle, ne peut être faite de ce site et de l'ensemble de son contenu : textes, documents, images, etc. sans l'autorisation expresse de l'auteur. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.

Sommaire

- I. Introduction

- II. La base de données Access

- II-A. Table T_Contact

- II-B. Table T_DossierOutlook

- II-C. Table T_ContactOutlook

- III. Les contacts Outlook

- III-A. Objet ContactItem

- IV. Opérations réalisées

- IV-A. Opérations d'importation

- IV-B. Opérations d'exportation

- IV-C. Opérations de suppression

- V. Formulaire F_ListeContact

- V-A. Bouton de commande CmdImportContacts

- V-B. Bouton de commande CmdExportContacts

- V-C. Listes déroulantes pour le filtrage des contacts

- V-C-1. Procédure RefreshListeContacts

- V-D. Bouton de commande CmdActualiser

- V-E. Bouton de commande CmdInitialiserLiens

- VI. Formulaire F_Contact

- VI-A. Bouton de commande CmdImportContact

- VI-C. Bouton de commande CmdExportContact

- VI-E. Bouton de commande CmdSupprimerContact

- VI-F. Bouton de commande CmdActualiser

- VI-G. Liste déroulante cmbContactOutlook

- VI-H. Liste déroulante cmbDossierOutlook

- VII. Module M_Contact

- VII-A. Fonction isOutLookRunning

- VII-B. Procédure RunOutlook

- VII-C. Fonction Evaluer

- VII-D. Procédure générique AddContactOutlook

- VII-E. Procédure générique UpdateContactAccess

- VII-F. Procédure générique UpdateContactOutlook

- VII-G. Fonction ImportContact

- VII-H. Fonction ImportContacts

- VII-I. Fonction ExportContact

- VII-J. Fonction ExportContacts

- VII-K. Fonction SupprimerContactOutlook

- VII-L. Fonction MajContactsOutlook

- VII-M. Fonction MajDossiersOutlook

- VII-N. Fonction InitialiserLiens

- VIII. Les bases de données à télécharger

- IX. Remerciements

I - Introduction

Après avoir décrit la structure des tables Access et de l'objet ContactItem d'Outlook, on présentera à l'aide de schémas, les différentes opérations permettant de synchrnoniser les contacts entre Access et Outlook :

- opérations d'importation ;

- opérations d'exportation ;

- Opérations de suppression.

Ensuite, on détaillera la structure des différents formulaires et le code VBA de l'application exemple.

Affichage des formulaires

Formulaire F_ListeContact

Formulaire F_Contact

Le code VBA présenté dans cet article utilise la méthode de liaison appelée early binding qui nécessite de cocher la référence Microsoft Outlook xx.x Object Library. Pour éviter les conflits de version au niveau de la référence Outlook, une version 1.2 en late binding, est aussi disponible en téléchargement.

II - La base de données Access

Nous aurons besoin tout d'abord d'enregistrer dans des tables les informations concernant les contacts et les dossiers Outlook.

II-A - Table T_Contact

Table permettant d'enregistrer les différents contacts.

T_Contact

Nom du champ

Type du champ

Description

IdContact

Entier long

Numéro identifiant le contact

NomContact

Texte

Nom du contact

PrenomContact

Texte

Prénom du contact

NomSociete

Texte

Nom de la société

Fonction

Texte

Fonction du contact dans la société

Adresse

Texte

Adresse du contact au bureau

CodePostal

Texte

Code postal de la ville

Ville

Texte

Ville de la société

TelBureau

Texte

Numéro de téléphone au bureau

Telecopie

Texte

Numéro de télécopie

TelDomicile

Texte

Numéro de téléphone au domicile

TelMobile

Texte

Numéro de portable

Email

Texte

E-mail du contact

Categorie

Texte

Catégorie du contact

Notes

Texte

Notes ou commentaires

DateAnniversaire

Date/Heure

Date d'anniversaire

IdDossierOutlook

Texte

Identifiant du dossier Outlook du contact

IdContactOutlook

Texte

Identifiant du contact Outlook

II-B - Table T_DossierOutlook

Table permettant d'enregistrer les différents dossiers de contacts Outlook.

T_DossierOutlook

Nom du champ

Type du champ

Description

IdDossierContacts

Texte

Identifiant du dossier de contacts Outlook

DossierContacts

Texte

Nom du dossier de contacts Outlook

DossierParent

Texte

Nom du dossier parent dans Outlook

II-C - Table T_ContactOutlook

Table permettant d'enregistrer les différents contacts Outlook, pour faire le lien avec la table T_Contact.

T_ContactOutlook

Nom du champ

Type du champ

Description

IdContact

Texte

Identifiant du contact dans Outlook

NomComplet

Texte

Nom complet du contact dans Outlook

IdDossier

Texte

Identifiant du dossier Outlook

III - Les contacts Outlook

Nous présentons ici un résumé de la structure de l'objet ContactItem permettant de gérer les contacts côté Outlook.

III-A - Objet ContactItem

Objet Outlook permettant d'enregistrer les contacts, il est un élément d'un dossier de contacts (Objet Folder). Voici un extrait de ses propriétés :

Objet ContactItem

Nom du champ

Type du champ

Description

EntryID

Texte

Champ identifiant, lié au champ IDContactOutlook de la table Access

LastName

Texte

Nom du contact

FirstName

Texte

Prénom du contact

CompanyName

Texte

Nom de la société

JobTitle

Texte

Fonction du contact dans la société

BusinessAddressStreet

Texte

Adresse ou rue du contact au bureau

BusinessAddressPostalCode

Texte

Code postal de la ville

BusinessAddressCity

Texte

Ville de la société

BusinessTelephoneNumber

Texte

Numéro de téléphone au bureau

BusinessFaxNumber

Texte

Numéro de télécopie

HomeTelephoneNumber

Texte

Numéro de téléphone au domicile

TelMobile

Texte

Numéro de portable

Email1Address

Texte

E-mail du contact

Categorie

Texte

Catégorie du contact

Body

Texte

Notes ou commentaires

Birthday

Date/Heure

Date d'anniversaire

…

…

…

Pour ajouter un contact dans Outlook, on utilise l'objet Application d'Outlook :

Set objContact = objApp.CreateItem(olContactItem)

Pour éditer et sauvegarder les informations dans un objet ContactItem, on peut faire :

objContact.FirstName = "Jean-Louis"
objContact.LastName = "Durand"
...
objContact.save

La propriété EntryID va nous permettre de faire le lien avec le champ IdContactOutlook de la table Access.

IV - Opérations réalisées

Pour mieux comprendre le principe, illustrons par des schémas les opérations d'importation, d'exportation et de suppression des données.

Ces schémas sont valables pour un seul compte de messagerie. L'adresse e-mail du compte de messagerie doit d'ailleurs être enregistrée dans la table T_CompteMessagerie.

IV-A - Opérations d'importation

On vérifie si le contact Outlook est présent dans la base Access, si c'est le cas, on le met à jour côté Access, sinon on l'ajoute :

Mise à jour du contact

Ajout du contact

IV-B - Opérations d'exportation

On vérifie si le contact enregistré dans la table Access est présent dans la base Outlook, si c'est le cas, on le met à jour côté Outlook, sinon on l'ajoute :

Mise à jour du contact

Ajout du contact

IV-C - Opérations de suppression

Si le contact est présent dans Access et Outlook, on le supprime des deux côtés, sinon on le supprime uniquement où il est présent :

Suppression des deux côtés

Suppression dans Access

Suppression dans Outlook

V - Formulaire F_ListeContact

Il permet d'afficher la liste des contacts classée par nom et prénom, et filtrée par dossier Outlook ou par nom de société. Il contient également les deux boutons de commande permettant d'importer ou d'exporter les contacts.

Formulaire F_ListeContact

V-A - Bouton de commande CmdImportContacts

Ce bouton permet l'import des contacts Outlook dans la base Access en remplaçant ceux ayant le même identifiant.

Bouton cmdImportContacts

Déroulé de la procédure événementielle

- On actualise l'enregistrement courant sur le formulaire.

- On importe les contacts Outlook en fonction des choix effectués sur le formulaire.

- On met à jour la liste des dossiers et des contacts Outlook enregistrés respectivement dans les tables T_DossierOutlook et T_ContactOutlook.

- On actualise le sous-formulaire et les listes de choix.

Procédure événementielle CmdImportContacts_Click

Private Sub CmdImportContacts_Click()
' Exécute l'importation des contacts Outlook
On Error GoTo err_CmdImportContacts_Click

' Si l'utilisateur ne souhaite pas importer les contacts, on sort
If MsgBox("Souhaitez-vous importer les contacts Outlook et les mettre à jour dans la base ?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If

' Sinon

' On importe les contacts en fonction du filtre défini sur le formulaire
If ImportContacts() Then
' Si l'import a bien eu lieu
MajDossiersOutlook ' On met à jour la liste des dossiers Outlook dans la base Access
MajContactsOutlook ' On met à jour la liste des contacts Outlook dans la base Access
Me.Refresh ' On actualise le sous-formulaire et les listes de choix
MsgBox ("L'importation des contacts a été réalisée avec succès !") ' Affichage du message de succès
End If

err_CmdImportContacts_Click:
If Err.Number <> 0 Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If

End Sub

V-B - Bouton de commande CmdExportContacts

Ce bouton permet l'export des contacts Access dans Outlook en remplaçant ceux ayant le même identifiant.

Bouton cmdExportContacts

Déroulé de la procédure événementielle

- On actualise l'enregistrement courant sur le formulaire.

- On exporte les contacts en fonction des choix effectués sur le formulaire.

- On met à jour la liste des contacts Outlook enregistrés dans la table T_ContactOutlook.

- On actualise le sous-formulaire.

Procédure événementielle CmdExportContacts_Click

>Private Sub CmdExportContacts_Click()
' Exécute l'exportation des contacts dans Outlook
On Error GoTo err_CmdExportContacts_Click

' Si l'utilisateur ne souhaite pas exporter les contacts, on sort
If MsgBox("Souhaitez-vous exporter les contacts de la base et les mettre à jour dans Outlook ?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If

' Sinon

' On importe les contacts en fonction du filtre défini sur le formulaire
If ExportContacts() Then
'Si l'export a réussi
MajContactsOutlook ' On met à jour la liste des contacts Outlook dans la base Access
Me.SF_ListeContact.Requery ' On actualise le sous-formulaire
MsgBox ("L'exportation des contacts a été réalisée avec succès !") ' Affichage du message de succès
End If

err_CmdExportContacts_Click:
If Err.Number <> 0 Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If

End Sub

V-C - Listes déroulantes pour le filtrage des contacts

Ces listes déroulantes cmbDossierOutlook et cmbSociete permettent de filtrer les contacts dans le sous-formulaire Access.

Zone de filtrage

V-C-1 - Procédure RefreshListeContacts

Déroulé de la procédure

- Définition du critère de la requête en fonction des choix effectués dans les listes déroulantes ;

- Constitution de la chaîne SQL avec le critère précédent ;

- Affectation de la chaîne SQL à la source du sous-formulaire.

Procédure RefreshListeContacts

Public Sub RefreshListeContacts()
' Permet de filtrer les contacts en fonction de la société ou du dossier choisis sur le formulaire
Dim leSQL As String
Dim leWhere As String

' Définition du critère de filtrage en fonction de la société ou du dossier choisis sur le formulaire
leWhere = "True"

If (Nz(Me.cmbDossierOutlook, "") <> "[Tous]") And (Nz(Me.cmbDossierOutlook, "") <> "") Then
' Si un dossier a été choisi dans la liste
leWhere = leWhere & " and IdDossierOutlook like '" & Me.cmbDossierOutlook.Value & "'"
Else
Me.cmbDossierOutlook = "[Tous]"
End If

If (Nz(Me.cmbSociete, "") <> "[Toutes]") And (Nz(Me.cmbSociete, "") <> "") Then
' Si un nom de société a été choisi dans la liste
leWhere = leWhere & " and NomSociete like '" & Replace(Me.cmbSociete, "'", "''") & "'"
Else
Me.cmbSociete = "[Toutes]"
End If

' Constitution de la chaîne SQL
leSQL = "Select * From R_ListeContact where " & leWhere & " order by Contact;"

' Affectation de la chaîne SQL à la propriété RecordSource du sous-formulaire
Me.SF_ListeContact.Form.RecordSource = leSQL

End Sub

V-D - Bouton de commande CmdActualiser

Ce bouton permet d'actualiser le formulaire.

Bouton cmdActualiser

Déroulé de la procédure événementielle

- On met à jour la liste des contacts et des dossiers Outlook enregistrés dans les tables T_ContactOutlook, T_DossierOutlook.

- On rafraîchit le formulaire et les listes déroulantes.

Procédure événementielle CmdActualiser_Click

Private Sub CmdActualiser_Click()
' Procédure d'actualisation du formulaire et de ses listes
On Error GoTo err_CmdActualiser_Click

' Si l'utilisateur ne souhaite pas actualiser le contact, on sort
If MsgBox("Souhaitez-vous actualiser le formulaire Access ?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If

If Not IsOutLookRunning() Then ' Si Outlook n'est pas déjà ouvert
RunOutlook
MsgBox ("Ouverture d'Outlook !")
End If

MajDossiersOutlook ' On met a jour la liste des dossiers Outlook
MajContactsOutlook ' On met a jour la liste des contacts Outlook

Me.Refresh ' On actualise l'enregistrement en cours

' Partie gestion de l'erreur
err_CmdActualiser_Click:
If Err.Number <> 0 Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If

End Sub

V-E - Bouton de commande CmdInitialiserLiens

Ce bouton permet, lors d'une réinstallation ou d'un changement d'ordinateur, et en cas de récupération des données Outlook à partir du fichier .pst, de mettre à jour les liens entre le champ IdContactOutlook de la base Access et la propriété EntryID des contacts Outlook.

Bouton cmdInitialiserLiens

Déroulé de la procédure événementielle

- Si le contact Outlook est dans la base Access, on met à jour le champ IdContactOutlook côté Access.

- On actualise le sous-formulaire.

Procédure événementielle CmdInitialiserLiens_Click

Private Sub CmdInitialiserLiens_Click()
' Exécute de la procédure d'initialisation des liens en cas de changement d'ordinateur
On Error GoTo err_CmdInitialiserLiens_Click

' Si l'utilisateur souhaite initialiser les liens entre Access et Outlook
If MsgBox("Souhaitez-vous initialiser les liens ?", vbYesNo + vbQuestion) = vbYes Then
If InitialiserLiens Then
' Si l'initialisation des liens a bien eu lieu
MajDossiersOutlook ' On met à jour la liste des dossiers Outlook dans la base Access
MajContactsOutlook ' On met à jour la liste des contacts Outlook dans la base Access
Me.SF_ListeContact.Requery ' On actualise le sous-formulaire
MsgBox ("L'initialisation des liens a été réalisée avec succès !") ' Affichage du message de succès
End If
End If

err_CmdInitialiserLiens_Click:
If Err.Number <> 0 Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If

End Sub

VI - Formulaire F_Contact

Il permet de modifier ou ajouter un contact. Il comprend également des boutons de commande permettant d'importer, d'exporter ou de supprimer un contact, et des listes déroulantes pour les recherches.

Formulaire F_Contact

Ce formulaire s'ouvre en mode édition en double-cliquant sur une ligne précise de la liste des contacts, et en mode ajout, en cliquant sur le bouton "Ajouter un contact" situé dans l'en-tête du formulaire F_ListeRendezVous.

VI-A - Bouton de commande CmdImportContact

Ce bouton permet l'import d'un contact Outlook pour l'ajouter à la base s'il n'est pas présent ou le remplacer dans le cas contraire.

Bouton cmdImportContact

Déroulé de la procédure événementielle

- On actualise l'enregistrement courant sur le formulaire.

- Si le contact Outlook est dans la base Access, on le remplace.

- Sinon, on ajoute le contact Outlook à la base.

- On rafraîchit la source du formulaire.

- On rafraîchit les listes des dossiers et contacts Outlook sur le formulaire.

Procédure événementielle CmdImportContact_Click

Private Sub CmdImportContact_Click()
' Exécute l'importation du contact choisi dans la liste cmbContactOutlook
On Error GoTo err_CmdImportContact_Click

If Me.cmbContactOutLook.Value <> "" Then ' Si un dossier Outlook est enregistré pour le contact

' Si sur la 2e colonne on indique que le contact Outlook n'est pas présent dans la base Access
If (Me.cmbContactOutLook.Column(2) = "") Then

' Si l'utilisateur souhaite ajouter ce contact outlook dans la base
If MsgBox("Souhaitez-vous importer le contact Outlook dans la base ?", vbYesNo + vbQuestion) = vbYes Then

Me.Refresh ' On actualise le contact actuel

If ImportContact(Nz(Me.cmbContactOutLook.Value, "")) Then ' On importe le contact Outlook
' Si l'import a bien eu lieu
MajContactsOutlook ' On met à jour la liste des contacts Outlook dans la base Access
Me.Requery ' On rafraîchit les données du formulaire
Me.Refresh ' On actualise l'enregistrement courant, ce qui provoque l'actualisation des listes déroulantes
DoCmd.GoToRecord acDataForm, Me.Name, acLast ' On se déplace sur le nouvel enregistrement
MsgBox ("L'importation du contact a été réalisée avec succès !") ' Affichage du message de succès
End If

End If

Else

If MsgBox("Contact déjà présent dans la base ! Souhaitez-vous le mettre à jour ?", vbYesNo) = vbYes Then

Me.Refresh ' On actualise le contact actuel

If ImportContact(Nz(Me.cmbContactOutLook.Value, "")) Then ' On importe le contact Outlook
' Si l'import a bien eu lieu
MajContactsOutlook ' On met à jour la liste des contacts Outlook dans la base Access
Me.Refresh ' On actualise l'enregistrement courant, ce qui provoque l'actualisation des listes déroulantes
MsgBox ("L'importation du contact a été réalisée avec succès !") ' Affichage du message de succès
End If
End If

End If
Else ' Sinon
MsgBox ("Choisir un contact Outlook !")
End If

err_CmdImportContact_Click:
If Err.Number <> 0 Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If

End Sub

VI-C - Bouton de commande CmdExportContact

Ce bouton permet l'export du contact enregistré dans la table Access pour l'ajouter dans Outlook s'il n'est pas présent ou le remplacer dans le cas contraire.

Bouton cmdExportContact

Déroulé de la procédure événementielle

- On actualise l'enregistrement courant sur le formulaire.

- Si le contact enregistré dans la table Access est présent dans la base Outlook, on le remplace.

- Sinon, on ajoute le contact dans Outlook.

- On rafraîchit la source du formulaire.

- On rafraîchit les listes des dossiers et contacts Outlook sur le formulaire.

Procédure événementielle CmdExportContact_Click

Private Sub CmdExportContact_Click()
' Exécute l'exportation du contact dans Outlook
On Error GoTo err_CmdExportContact_Click

If Me.IdDossierOutlook.Value <> "" Then ' Si un dossier Outlook a été choisi sur le formulaire
' Si l'utilisateur ne souhaite pas exporter le contact, on sort
If MsgBox("Souhaitez-vous exporter ce contact dans le dossier Outlook ?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If

' Sinon
Me.Refresh ' On actualise le contact actuel

If ExportContact() Then ' On exporte le contact dans Outlook
'Si l'export a réussi
MajContactsOutlook ' On met à jour la liste des contacts Outlook dans la base Access
Me.Refresh ' On actualise l'enregistrement courant, ce qui provoque l'actualisation des listes déroulantes
Form_Current ' On met à jour le contact et le dossier Outlook dans l'en-tête de formulaire
MsgBox ("L'exportation du contact a été réalisée avec succès !") ' Affichage du message de succès
End If

Else ' Si aucun dossier Outlook n'a été choisi sur le formulaire
MsgBox ("Choisir un dossier de contacts Outlook !")
End If

err_CmdExportContact_Click:
If Err.Number <> 0 Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If

End Sub

VI-E - Bouton de commande CmdSupprimerContact

Ce bouton permet de supprimer un contact côté Access ou côté Outlook.

Bouton cmdSupprimerContact

Déroulé de la procédure événementielle

- On actualise l'enregistrement courant sur le formulaire.

- Si le contact Outlook est dans la base Access, on le supprime des deux côtés.

- Si le contact Outlook n'est pas dans la base Access, on le supprime dans Outlook.

- Si le contact Access n'est pas dans Outlook, on le supprime dans Access.

- On rafraîchit la source du formulaire.

- On ferme le formulaire pour revenir à la liste des contacts si elle est ouverte.

Procédure événementielle CmdSupprimerContact_Click

Private Sub CmdSupprimerContact_Click()
' Exécute la suppression du contact des 2 côtés
On Error GoTo err_CmdSupprimerContact_Click

' Si l'utilisateur souhaite supprimer le contact
If MsgBox("Souhaitez-vous supprimer le contact ?", vbYesNo + vbQuestion) = vbYes Then
DoCmd.SetWarnings False ' On déactive les avertissements Access
' On supprime le contact dans Access
DoCmd.RunSQL ("delete * from T_Contact where IdContact=" & Nz(Me.IdContact, 0))
DoCmd.SetWarnings True ' On remet les avertissements Access

If SupprimerContactOutlook(Nz(Me.cmbContactOutLook, "")) Then
MsgBox ("Suppression du contact Outlook réalisée avec succès !")
End If

Me.Requery ' Actualisation de la source du formulaire

If CurrentProject.AllForms("F_ListeContact").IsLoaded Then
' Si le formulaire F_ListeContact est ouvert
DoCmd.Close acForm, Me.Name ' Fermeture du formulaire
End If
End If

err_CmdSupprimerContact_Click:
If Err.Number <> 0 Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
DoCmd.SetWarnings True ' On remet les avertissements Access
End If

End Sub

VI-F - Bouton de commande CmdActualiser

Ce bouton permet d'actualiser le formulaire.

Bouton cmdActualiser

Déroulé de la procédure événementielle

- On met à jour la liste des contacts et des dossiers Outlook enregistrés dans les tables T_ContactOutlook, T_DossierOutlook.

- On rafraîchit le formulaire et les listes déroulantes.

Procédure événementielle CmdActualiser_Click

Private Sub CmdActualiser_Click()
' Procédure d'actualisation du formulaire et de ses listes
On Error GoTo err_CmdActualiser_Click

' Si l'utilisateur ne souhaite pas actualiser le contact, on sort
If MsgBox("Souhaitez-vous actualiser le formulaire Access ?", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If

If Not IsOutLookRunning() Then ' Si Outlook n'est pas déjà ouvert
RunOutlook
MsgBox ("Ouverture d'Outlook !")
End If

MajDossiersOutlook ' On met a jour la liste des dossiers Outlook
MajContactsOutlook ' On met a jour la liste des contacts Outlook

Me.Refresh ' On actualise l'enregistrement en cours

' Partie gestion de l'erreur
err_CmdActualiser_Click:
If Err.Number <> 0 Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If

End Sub

VI-G - Liste déroulante cmbContactOutlook

Elle permet de rechercher un contact Outlook déjà importé dans la base Access.

Elle est alimentée par la requête R_ContactOutlook qui affiche l'identifiant, le nom complet et l'état du contact Outlook (État : Importé ou non).

Liste déroulante cmbContactOutlook

VI-H - Liste déroulante cmbDossierOutlook

Elle permet de saisir un dossier Outlook pour le contact enregistré dans Access.

Elle est alimentée par la table T_DossierOutlook qui permet d'enregistrer les noms des dossiers Outlook.

Liste déroulante cmbDossierOutlook

VII - Module M_Contact

On s'arrange pour regrouper dans des procédures ou fonctions génériques les portions de code répétitives, pour ainsi rendre le code plus lisible et faciliter sa maintenance. Ces routines sont ensuite appelées dans les procédures principales.

VII-A - Fonction isOutLookRunning

Cette fonction teste si Outlook est ouvert ou pas :

Fonction isOutLookRunning

Public Function IsOutLookRunning() As Boolean
On Error Resume Next
Dim objOutLook As Object

'Référence vers l'objet Application Outlook
Set objOutLook = GetObject(, "OutLook.Application")

'Si outlook n'est pas ouvert
If (Err <> 0) Then
IsOutLookRunning = False
Else
IsOutLookRunning = True
End If

Set objOutLook = Nothing

End Function

VII-B - Procédure RunOutlook

Procédure de lancement d'Outlook.

Procédure RunOutlook

Public Sub RunOutlook()
' Lancement d'Outlook
Dim oShell As Object

Set oShell = CreateObject("WScript.Shell")
oShell.Run "outlook" ' On ouvre Outlook
Set oShell = Nothing

End Sub

VII-C - Fonction Evaluer

Elle nous permet de gérer les cas où la valeur du champ ou de la propriété est nulle.

Fonction Evaluer

Public Function Evaluer(fieldvalue As Variant) As Variant
Dim s As String

s = Nz(fieldvalue, "") ' Si la valeur est nulle on passe une chaîne vide

If s <> "" Then
Evaluer = s
End If

End Function

VII-D - Procédure générique AddContactOutlook

Elle permet d'ajouter le contact Outlook dans la table Access, et prend en argument le Recordset basé sur la table Access, l'objet ContactItem du contact Outlook, et son dossier.

Procédure AddContactOutlook

Public Sub AddContactOutlook(rs As DAO.Recordset, objContact As Outlook.ContactItem, objFolder As Outlook.Folder)
' procédure d'ajout du contact Outlook dans Access
Dim dt As Date

With rs

.AddNew ' On ajoute le contact Outlook dans la base Access

!PrenomContact = Evaluer(objContact.FirstName)
!NomContact = Evaluer(objContact.LastName)

!Fonction = Evaluer(objContact.JobTitle)
!Categorie = Evaluer(objContact.Categories)

!NomSociete = Evaluer(objContact.CompanyName)
!Adresse = Evaluer(objContact.BusinessAddressStreet)
!Ville = Evaluer(objContact.BusinessAddressCity)
![CodePostal] = Evaluer(objContact.BusinessAddressPostalCode)
![TelBureau] = Evaluer(objContact.BusinessTelephoneNumber)
!TELECOPIE = Evaluer(objContact.BusinessFaxNumber)
![TelDomicile] = Evaluer(objContact.HomeTelephoneNumber)
![TelMobile] = Evaluer(objContact.MobileTelephoneNumber)
!Email = Evaluer(objContact.Email1Address)
!Notes = Evaluer(objContact.Body)

If Not IsNull(objContact.Birthday) Then
dt = objContact.Birthday
If dt < Date Then
!DateAnniversaire = dt
End If
End If

!IdDossierOutlook = objFolder.EntryID ' On copie dans le champ Access l'identifiant du dossier Outlook
!IdContactOutlook = objContact.EntryID ' On copie dans le champ Access l'identifiant du contact Outlook

.Update ' Enregistrement du contact dans la table

.MoveLast

objContact.BillingInformation = Evaluer(!IdContact)
objContact.Save

End With

End Sub

VII-E - Procédure générique UpdateContactAccess

Elle permet de mettre à jour le contact enregistré côté Access avec les données du contact Outlook. Elle prend en argument le Recordset basé sur la table Access, l'objet ContactItem du contact Outlook, et son dossier.

Procédure UpdateContactAccess

Public Sub UpdateContactAccess(rs As DAO.Recordset, objContact As Outlook.ContactItem, objFolder As Outlook.Folder)
' procédure de mise à jour du contact dans Access
Dim dt As Date

With rs

.Edit ' On met à jour ce contact Access avec les données de Outlook

!PrenomContact = Evaluer(objContact.FirstName)
!NomContact = Evaluer(objContact.LastName)

!Fonction = Evaluer(objContact.JobTitle)
!Categorie = Evaluer(objContact.Categories)

!NomSociete = Evaluer(objContact.CompanyName)
!Adresse = Evaluer(objContact.BusinessAddressStreet)
!Ville = Evaluer(objContact.BusinessAddressCity)
![CodePostal] = Evaluer(objContact.BusinessAddressPostalCode)
![TelBureau] = Evaluer(objContact.BusinessTelephoneNumber)
!TELECOPIE = Evaluer(objContact.BusinessFaxNumber)
![TelDomicile] = Evaluer(objContact.HomeTelephoneNumber)
![TelMobile] = Evaluer(objContact.MobileTelephoneNumber)
!Email = Evaluer(objContact.Email1Address)
!Notes = Evaluer(objContact.Body)

If Not IsNull(objContact.Birthday) Then
dt = objContact.Birthday
If dt < Date Then
!DateAnniversaire = dt
End If
End If

!IdDossierOutlook = objFolder.EntryID ' On copie dans le champ Access l'identifiant du dossier Outlook
!IdContactOutlook = objContact.EntryID ' On copie dans le champ Access l'identifiant du contact Outlook

.Update ' Enregistrement du contact dans la table

objContact.BillingInformation = Evaluer(!IdContact)
objContact.Save

End With

End Sub

VII-F - Procédure générique UpdateContactOutlook

Elle permet de mettre à jour le contact Outlook avec les données du contact Access. Elle prend en argument le Recordset basé sur la table Access, l'objet ContactItem du contact Outlook, et l'objet NameSpace.

Procédure UpdateContactOutlook

Public Sub UpdateContactOutlook(objContact As Outlook.ContactItem, rs As DAO.Recordset, objSpace As Outlook.NameSpace)
' Procédure de mise à jour du contact Outlook
Dim dt As Date, id As String
Dim objContact2 As Outlook.ContactItem
Dim objFolder As Outlook.Folder

With objContact  ' Mise à jour des champs Outlook avec les données Access du contact

.FirstName = Evaluer(rs!PrenomContact)
.LastName = Evaluer(rs!NomContact)

.JobTitle = Evaluer(rs!Fonction)
.Categories = Evaluer(rs!Categorie)

.CompanyName = Evaluer(rs!NomSociete)
.BusinessAddressStreet = Evaluer(rs!Adresse)
.BusinessAddressCity = Evaluer(rs!Ville)
.BusinessAddressPostalCode = Evaluer(rs![CodePostal])
.BusinessTelephoneNumber = Evaluer(rs![TelBureau])
.BusinessFaxNumber = Evaluer(rs!TELECOPIE)
.HomeTelephoneNumber = Evaluer(rs![TelDomicile])
.MobileTelephoneNumber = Evaluer(rs![TelMobile])
.Email1Address = Evaluer(rs!Email)
.Body = Evaluer(rs!Notes)
.BillingInformation = Evaluer(rs!IdContact)

If Not IsNull(rs!DateAnniversaire) Then
dt = rs!DateAnniversaire
.Birthday = dt
End If

.Save ' Sauvegarde des modifications dans le contact Outlook

Set objFolder = objSpace.GetFolderFromID(rs!IdDossierOutlook)
id = .EntryID

If objFolder.Name <> .Parent.Name Then
Set objContact2 = .Move(objFolder) ' Déplacement du contact dans le bon dossier
id = objContact2.EntryID
End If

rs.Edit
rs!IdContactOutlook = id
rs.Update

End With

'Fermeture et libérations des variables
Set objContact2 = Nothing
Set objFolder = Nothing

End Sub

VII-G - Fonction ImportContact

Déroulé de la fonction

- On teste si Outlook est ouvert et on l'ouvre si ce n'est pas le cas.

- On crée les objets Application et NameSpace d'Outlook et on ouvre le Recordset basé sur la table des contacts.

- On recherche le contact Outlook ayant comme identifiant la chaîne de caractères passée en argument.

- Si on le trouve, on met à jour le contact de la base Access avec les données du contact Outlook, sinon on l'ajoute à la base.

- On ferme et libère les variables.

On teste si Outlook est déjà ouvert :

If Not IsOutLookRunning() Then ' Si Outlook n'est pas déjà ouvert
RunOutlook ' On exécute Outlook
End If

On crée les objets Application et NameSpace d'Outlook, la référence au compte de messagerie et à la base en cours, puis on ouvre le Recordset basé sur la table T_Contact :

' Création de l'objet Application d'Outlook
Set objApp = new Outlook.Application

' Création de l'objet NameSpace d'Outlook
Set objSpace = objApp.GetNamespace("MAPI")

' Référence au dossier du compte de messagerie
Set objCptFolder = objSpace.Folders(DLookup("EMail", "T_CompteMessagerie"))

' Référence à la base de données courante
Set db = CurrentDb

' Ouverture du recordset contenant le contact courant sur le formulaire
Set rs = db.OpenRecordset("T_Contact", dbOpenDynaset)

On recherche le contact Outlook ayant comme identifiant la valeur de l'argument IdContactOutlook :

On Error Resume Next
' Référence au Contact Outlook ayant comme EntryID, l'identifiant du contact Outlook dans Access
Set objContact = objSpace.GetItemFromID(IdContactOutlook, objCptFolder.StoreID)

On Error GoTo err_ImportContact
...

On teste si le contact trouvé est présent dans la table T_Contact, si c'est le cas on le met à jour, sinon on l'ajoute :

If TypeName(objContact) <> "Nothing" Then ' Si aucun contact n'a été trouvé

' On recherche le contact Outlook dans la base Access
rs.FindFirst "[IdContactOutlook] = '" & objContact.EntryID & "'"

If rs.NoMatch Then ' Si aucun contact dans Access ne possède cet identifiant
' On ajoute le contact dans la base Access
AddContactOutlook rs, objContact, objContact.Parent
Else ' Si un contact Access possède le même identifiant
' On met à jour le contact Access
UpdateContactAccess rs, objContact, objContact.Parent
End If

ImportContact = True

End If
...

Pour finir, on minimise la fenêtre Outlook pour revenir à la fenêtre Access, puis ferme et libère les variables :

'On minimise la fenêtre Outlook pour revenir sur Access
objApp.ActiveWindow.WindowState = 1

err_ImportContact:
If (Err.Number <> 0) And Not ImportContact Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf &  "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If
On Error Resume Next
'Fermeture et libérations des variables
If Not (rs Is Nothing) Then
rs.Close
End If
Set rs = Nothing
Set db = Nothing
Set objContact = Nothing
Set objCptFolder = Nothing
Set objSpace = Nothing
Set objApp = Nothing

VII-H - Fonction ImportContacts

Déroulé de la fonction

- On teste si Outlook est ouvert et on l'ouvre si ce n'est pas le cas.

- On crée l'objet Application d'Outlook et on ouvre le Recordset basé sur la table des contacts.

- On parcourt les dossiers et sous-dossiers Outlook à la recherche du ou des dossiers de contacts.

- On liste les contacts contenus dans ces dossiers.

- Pour chaque contact, si un nom de société a été choisi, on verifie s'il appartient à la bonne société.

- Ensuite, s'il est présent dans la base, on le remplace, sinon on l'ajoute.

- On ferme et libère les variables.

On teste si Outlook est déjà ouvert :

If Not IsOutLookRunning() Then ' Si Outlook n'est pas déjà ouvert
RunOutlook ' On exécute Outlook
End If

On crée les objets Application et NameSpace d'Outlook, la référence au compte de messagerie et à la base en cours, puis on ouvre le Recordset basé sur la table T_Contact :

' Création de l'objet Application d'Outlook
Set objApp = New Outlook.Application

' Création de l'objet NameSpace d'Outlook
Set objSpace = objApp.GetNamespace("MAPI")

' Référence au dossier principal du compte de messagerie
Set objCptFolder = objSpace.Folders(DLookup("email", "T_CompteMessagerie"))

' Référence à la base de données courante
Set db = CurrentDb

' Ouverture du recordset basé sur la table T_Contact contenant les contacts dans Access
Set rs = db.OpenRecordset("T_Contact", dbOpenDynaset)

IdDossierOutlook = Forms!F_ListeContact!cmbDossierOutlook.value
NomSociete = Forms!F_ListeContact!cmbSociete

On parcourt les dossiers et sous-dossiers Outlook à la recherche du ou des dossiers de contacts, puis on liste les contacts à la recherche de celui à importer :

' Dans le dossier principal du compte de messagerie
With objCptFolder

' On parcourt les dossiers contenus dans le dossier du compte
For Each objFolder In .Folders

If (objFolder.DefaultItemType = olContactItem) Then ' Si c'est un dossier de contacts

' Si le dossier est celui choisi ou si on a choisit de tout importer
If (objFolder.EntryID = IdDossierOutlook) Or (IdDossierOutlook = "[Tous]") Then

Set objContacts = objFolder.Items ' Référence à la liste des contacts contenus dans le dossier

For Each objContact In objContacts ' Parcourt de la liste des contact Outlook

' Si ce contact n'est pas un groupe de contacts
If (TypeName(objContact) <> "DistListItem") Then
...

Pour chaque contact, si un nom de société a été choisi, on verifie s'il appartient à la bonne société. On teste ensuite s'il est présent dans la table T_Contact, si c'est le cas, on le met à jour, sinon on l'ajoute :

' Si la société est celle choisie ou si on les a toutes choisies
If (objContact.CompanyName = NomSociete) Or (NomSociete = "[Toutes]") Then
' Recherche dans la table T_Contact du contact ayant le même identifiant Outlook
rs.FindFirst "[IdContactOutlook] = '" & objContact.EntryID & "'"

If rs.NoMatch Then ' Si aucun contact dans Access ne possède cet identifiant
' On ajoute le contact dans la base Access
AddContactOutlook rs, objContact, objFolder
Else ' Si un contact Access possède le même identifiant
' On met à jour le contact Access
UpdateContactAccess rs, objContact, objFolder
End If

End If

...

Pour finir, on minimise la fenêtre Outlook pour revenir à la fenêtre Access, puis ferme et libère les variables :

'On minimise la fenêtre Outlook pour revenir sur Access
objApp.ActiveWindow.WindowState = 1
ImportContacts = True

err_ImportContacts:
If (Err.Number <> 0) And Not ImportContacts Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf &  "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If
On Error Resume Next
'Fermeture et libérations des variables
If Not (rs Is Nothing) Then
rs.Close
End If
Set rs = Nothing
Set db = Nothing
Set objContact = Nothing
Set objContacts = Nothing
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objCptFolder = Nothing
Set objSpace = Nothing
Set objApp = Nothing

VII-I - Fonction ExportContact

Déroulé de la fonction

- On teste si Outlook est ouvert et on l'ouvre si ce n'est pas le cas.

- On crée les objets Application et NameSpace d'Outlook et on ouvre le Recordset sur le contact affiché sur le formulaire.

- On recherche le contact Outlook ayant comme identifiant la valeur du champ IdContactOutlook de l'enregistrement courant.

- Si on le trouve, on le remplace par celui de la base Access, sinon on l'ajoute dans Outlook.

- On ferme et libère les variables.

On teste si Outlook est déjà ouvert :

If Not IsOutLookRunning() Then ' Si Outlook n'est pas déjà ouvert
RunOutlook ' On exécute Outlook
End If

On crée les objets Application et NameSpace d'Outlook, la référence au compte de messagerie et à la base en cours, puis on ouvre le Recordset basé sur la table T_Contact filtrée sur le contact affiché sur le formulaire :

' Création de l'objet Application d'Outlook
Set objApp = new Outlook.Application

' Création de l'objet NameSpace d'Outlook
Set objSpace = objApp.GetNamespace("MAPI")

' Référence au dossier du compte de messagerie
Set objCptFolder = objSpace.Folders(DLookup("EMail", "T_CompteMessagerie"))

' Référence à la base de données courante
Set db = CurrentDb

' Ouverture du recordset contenant le contact courant sur le formulaire
Set rs = db.OpenRecordset("select * from T_Contact where [IdContact]=" & Nz(Forms!F_Contact![IdContact], 0), dbOpenDynaset)

On recherche le contact Outlook ayant comme identifiant la valeur du champ IdContactOutlook de la table T_Contact :

If Not rs.EOF Then ' Si le contact est présent dans Access

IdContactOutlook = Nz(rs!IdContactOutlook, "") ' Identifiant du contact Outlook

On Error Resume Next
' Référence au Contact Outlook ayant comme EntryID l'id Outlook dans Access
Set objContact = objSpace.GetItemFromID(IdContactOutlook, objCptFolder.StoreID)
On Error GoTo err_ExportContact
...

On teste si le contact affiché sur le formulaire est présent dans Outlook, si c'est le cas, on le met à jour, sinon on l'ajoute :

If TypeName(objContact) = "Nothing" Then ' Si aucun contact n'a été trouvé
' On crée le contact Outlook
Set objContact = objApp.CreateItem(olContactItem)
End If

' On met à jour le contact Outlook
UpdateContactOutlook objContact, rs, objSpace

ExportContact = True
...

Pour finir, on minimise la fenêtre Outlook pour revenir à la fenêtre Access, puis ferme et libère les variables :

'On minimise la fenêtre Outlook pour revenir sur Access
objApp.ActiveWindow.WindowState = 1

err_ExportContact:
If (Err.Number <> 0) And Not ExportContact Then Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf &  "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If
On Error Resume Next
'Fermeture et libérations des variables
If Not (rs Is Nothing) Then
rs.Close
End If
Set rs = Nothing
Set db = Nothing
Set objContact = Nothing
Set objSpace = Nothing
Set objApp = Nothing

VII-J - Fonction ExportContacts

Déroulé de la fonction

- On teste si Outlook est ouvert et on l'ouvre si ce n'est pas le cas.

- On crée les objets Application et NameSpace d'Outlook et on ouvre le Recordset en sélectionnant les contacts correspondant aux choix effectués sur le formulaire.

- On parcourt le Recordset et recherche pour chaque contact dans Access celui ayant comme identifiant la valeur du champ IdContactOutlook.

- Si on le trouve, on le remplace par celui de la base Access, sinon on l'ajoute dans Outlook.

- On ferme et libère les variables.

On teste si Outlook est déjà ouvert :

If Not IsOutLookRunning() Then ' Si Outlook n'est pas déjà ouvert
RunOutlook ' On exécute Outlook
End If

On crée les objets Application et NameSpace d'Outlook, la référence au compte de messagerie et à la base en cours, puis on ouvre le Recordset en fonction des choix effectués sur le formulaire :

' Création de l'objet Application d'Outlook
Set objApp = New Outlook.Application

' Création de l'objet NameSpace d'Outlook
Set objSpace = objApp.GetNamespace("MAPI")

' Référence au dossier du compte de messagerie
Set objCptFolder = objSpace.Folders(DLookup("EMail", "T_CompteMessagerie"))

' Variable identifiant le dossier Outlook
IdDossierOutlook = Forms!F_ListeContact!cmbDossierOutlook.value

If Forms!F_ListeContact!cmbDossierOutlook.Value = "[Tous]" Then
' Copie d'une astérix dans la variable, pour indiquer qu'on les prend tous
IdDossierOutlook = "*"
Else
' Copie de l'identifiant du dossier dans la variable
IdDossierOutlook = Forms!F_ListeContact!cmbDossierOutlook.Value
End If

If Forms!F_ListeContact!cmbSociete = "[Toutes]" Then
' Copie d'une astérix dans la variable, pour indiquer qu'on les prend toutes
NomSociete = "*"
Else
' Copie du nom de la société dans la variable
NomSociete = Forms!F_ListeContact!cmbSociete
End If

' Référence à la base de données courante
Set db = CurrentDb

' Constitution de la chaîne SQL en fonction des choix effectués sur le formulaire
sSQL = "select * from T_Contact where (IdDossierOutlook like '" & IdDossierOutlook & "') and (nz(IdDossierOutlook,'')<>'') and " & _
"(nz(NomSociete,'') like '" & NomSociete & "')"

' Ouverture du recordset
Set rs = db.OpenRecordset(sSQL, dbOpenDynaset)
...

Pour chaque enregistrement, on recherche le contact Outlook ayant comme identifiant la valeur du champ IdContactOutlook :

Do Until rs.EOF ' On parcourt la liste des contacts présents dans Access

IdContactOutlook = Nz(rs!IdContactOutlook, "") ' Identifiant du contact Outlook

On Error Resume Next
' Référence au Contact Outlook ayant comme EntryID l'id Outlook dans Access
Set objContact = objSpace.GetItemFromID(IdContactOutlook, objCptFolder.StoreID)
On Error GoTo err_ExportContacts
...

Si le contact de l'enregistrement Access est présent dans le dossier Outlook, on le met à jour, sinon on l'ajoute dans la base Access :

If TypeName(objContact) = "Nothing" Then ' Si aucun contact n'a été trouvé
' On crée le contact Outlook
Set objContact = objApp.CreateItem(olContactItem)
End If

' On met à jour le contact Outlook
UpdateContactOutlook objContact, rs, objSpace
...

Pour finir, on minimise la fenêtre Outlook pour revenir à la fenêtre Access, puis ferme et libère les variables :

ExportContacts = True

'On minimise la fenêtre Outlook pour revenir sur Access
objApp.ActiveWindow.WindowState = 1

err_ExportContacts:
If (Err.Number <> 0) and And Not ExportContacts Then Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf &  "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If
On Error Resume Next
'Fermeture et libérations des variables
If Not (rs Is Nothing) Then
rs.Close
End If
Set rs = Nothing
Set db = Nothing
Set objContact = Nothing
Set objCptFolder = Nothing
Set objSpace = Nothing
Set objApp = Nothing

VII-K - Fonction SupprimerContactOutlook

Déroulé de la fonction

- On teste si Outlook est ouvert et on l'ouvre si ce n'est pas le cas.

- On crée les objets Application et NameSpace d'Outlook.

- On recherche le contact Outlook ayant comme identifiant la chaîne de caractères passée en argument.

- Si on le trouve, on supprime le contact dans Outlook.

- On ferme et libère les variables.

On teste si Outlook est déjà ouvert :

If Not IsOutLookRunning() Then ' Si Outlook n'est pas déjà ouvert
RunOutlook ' On exécute Outlook
End If

On crée les objets Application et NameSpace d'Outlook :

' Création de l'objet Application d'Outlook
Set objApp = new Outlook.Application

' Création de l'objet NameSpace d'Outlook
Set objSpace = objApp.GetNamespace("MAPI")

' Référence au dossier principal du compte de messagerie
Set objCptFolder = objSpace.Folders(DLookup("email", "T_CompteMessagerie"))

On recherche le contact Outlook ayant comme identifiant la valeur de l'argument IdContactOutlook :

On Error Resume Next
' Référence au Contact Outlook ayant comme EntryID, l'identifiant du contact Outlook dans Access
Set objContact = objSpace.GetItemFromID(IdContactOutlook, objCptFolder.StoreID)

On Error GoTo err_SupprimerContactOutlook
'...

On teste si le contact est présent dans Outlook, si c'est le cas, on le supprime :

If TypeName(objContact) <> "Nothing" Then ' Si un contact a été trouvé
' On supprime le contact Outlook
objContact.Delete
SuppContact = True
End If

Pour finir, on minimise la fenêtre Outlook pour revenir à la fenêtre Access, puis ferme et libère les variables :

'On minimise la fenêtre Outlook pour revenir sur Access
objApp.ActiveWindow.WindowState = 1

err_SupprimerContactOutlook:
If (Err.Number <> 0) and Not SupprimerContactOutlook Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf &  "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If
On Error Resume Next
'Fermeture et libérations des variables
Set objContact = Nothing
Set objSpace = Nothing
Set objApp = Nothing

VII-L - Fonction MajContactsOutlook

Déroulé de la fonction

- On crée l'objet Application d'Outlook ;

- On vide la table T_ContactOutlook et ouvre le Recordset basé sur cette table ;

- On parcourt les dossiers et sous-dossiers Outlook à la recherche des dossiers de contacts.

- On liste les contacts contenus dans ces dossiers en les ajoutant à la table.

- On ferme et libère les variables.

On crée les objets Application et NameSpace d'Outlook, puis la référence au compte de messagerie :

' Création de l'objet Application d'Outlook
Set objApp = new Outlook.Application

' Création de l'objet NameSpace d'Outlook
Set objSpace = objApp.GetNamespace("MAPI")

' Référence au dossier principal du compte de messagerie
Set objCptFolder = objSpace.Folders(DLookup("email", "T_CompteMessagerie"))

On vide la table T_ContactOutlook et ouvre le Recordset basé sur cette table :

' Référence à la base courante
Set db = CurrentDb

' Suppression des contacts Outlook dans la table T_ContactOutlook
db.Execute "delete * from T_ContactOutlook;", dbFailOnError

' Ouverture du recordset basé sur la table T_ContactOutlook
Set rs = db.OpenRecordset("T_ContactOutlook", dbOpenDynaset)

On parcourt les dossiers et sous-dossiers Outlook à la recherche de dossiers de contacts, puis on liste les contacts en les ajoutant à la table :

' Dans le dossier principal du compte de messagerie
With objCptFolder

' On parcourt les dossiers contenus dans ce dossier parent
For Each objFolder In .Folders

If objFolder.DefaultItemType = olContactItem Then ' Si c'est un dossier de contacts

Set objContacts = objFolder.Items ' Référence à la liste des contacts contenus dans le dossier

For Each objContact In objContacts ' Parcours de la liste des contacts Outlook
If (TypeName(objContact) <> "DistListItem") Then ' Si ce contact n'est pas un groupe de contacts
rs.AddNew ' On ajoute le contact Outlook dans la table Access
rs!IdContact = objContact.EntryID
rs!NomComplet = objContact.LastName & " " & objContact.FirstName
rs!IdDossier = objContact.Parent.EntryID
rs.Update
End If
Next

End If

' On parcourt les sous-dossiers Outlook
For Each objSubFolder In objFolder.Folders

If objSubFolder.DefaultItemType = olContactItem Then ' Si c'est un dossier de contacts

Set objContacts = objSubFolder.Items ' Référence à la liste des contacts contenus dans le dossier

For Each objContact In objContacts
If (TypeName(objContact) <> "DistListItem") Then ' Si ce contact n'est pas un groupe de contacts
rs.AddNew ' On ajoute le contact Outlook dans la table Access
rs!IdContact = objContact.EntryID
rs!NomComplet = objContact.LastName & " " & objContact.FirstName
rs!IdDossier = objContact.Parent.EntryID
rs.Update
End If
Next

End If

Next

Next

End with
...

Pour finir, on ferme et libère les variables :

err_MajContactsOutlook:
If (Err.Number <> 0) And Not MajContactsOutlook Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf &  "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If
On Error Resume Next
'Fermeture et libérations des variables
If Not (rs Is Nothing) Then
rs.Close
End If
Set rs = Nothing
Set db = Nothing
Set objContact = Nothing
Set objContacts = Nothing
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objCptFolder = Nothing
Set objSpace = Nothing
Set objApp = Nothing

VII-M - Fonction MajDossiersOutlook

Déroulé de la fonction

- On crée les objets Application et NameSpace d'Outlook.

- On vide la table T_DossierOutlook et ouvre le Recordset basé sur cette table.

- On parcourt les dossiers et sous-dossiers Outlook à la recherche des dossiers de contacts.

- On ajoute les noms de ces dossiers à la table.

- On ferme et libère les variables.

On crée les objets Application et NameSpace d'Outlook, puis la référence au compte de messagerie :

' Création de l'objet Application d'Outlook
Set objApp = new Outlook.Application

' Création de l'objet NameSpace d'Outlook
Set objSpace = objApp.GetNamespace("MAPI")

' Référence au dossier principal du compte de messagerie
Set objCptFolder = objSpace.Folders(DLookup("email", "T_CompteMessagerie"))

On vide la table T_ContactOutlook et ouvre le Recordset basé sur cette table :

' Référence à la base courante
Set db = CurrentDb

' Suppression des dossiers Outlook dans la table T_DossierOutlook
db.Execute "delete * from T_DossierOutlook;", dbFailOnError

' Ouverture du recordset basé sur la table T_DossierOutlook
Set rs = db.OpenRecordset("T_DossierOutlook", dbOpenDynaset)

On parcourt les dossiers et sous-dossiers Outlook à la recherche de dossiers de contacts, puis on ajoute l'identifiant, le nom du dossier Outlook et celui de son dossier parent dans la table :

' Dans le dossier principal du compte de messagerie
With objCptFolder

' On parcourt les dossiers contenus dans ces dossiers parents
For Each objFolder In objApp.ActiveExplorer.Session.Folders.Item(i).Folders

If objFolder.DefaultItemType = olContactItem Then ' Si c'est un dossier de contacts

rs.AddNew ' Ajout de l'identifiant, du nom du dossier Outlook et de son dossier parent
rs!IdDossierContacts = objFolder.EntryID
rs!DossierContacts = objFolder.Name
rs!DossierParent = objFolder.Parent.Name
rs.Update

End If

' On parcourt les sous-dossiers Outlook
For Each objSubFolder In objFolder.Folders

If objSubFolder.DefaultItemType = olContactItem Then ' Si c'est un dossier de contacts
rs.AddNew ' Ajout de l'identifiant, du nom du dossier Outlook et de son dossier parent
rs!IdDossierContacts = objSubFolder.EntryID
rs!DossierContacts = objSubFolder.Name
rs!DossierParent = objSubFolder.Parent.Name
rs.Update
End If

Next

Next

End With
...

Pour finir, on ferme et libère les variables :

err_MajDossiersOutlook:
If (Err.Number <> 0) And Not MajDossiersOutlook Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf &  "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If
On Error Resume Next
'Fermeture et libérations des variables
If Not (rs Is Nothing) Then
rs.Close
End If
Set rs = Nothing
Set db = Nothing
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objCptFolder = Nothing
Set objSpace = Nothing
Set objApp = Nothing

VII-N - Fonction InitialiserLiens

Déroulé de la fonction

- On teste si Outlook est ouvert et on l'ouvre si ce n'est pas le cas.

- On crée l'objet Application d'Outlook et on ouvre le Recordset basé sur la table des contacts.

- On parcourt les dossiers et sous-dossiers Outlook à la recherche des dossiers de contacts.

- On liste les contacts contenus dans ces dossiers.

- Pour chaque contact, s'il est présent dans la base, on le met à jour.

- On ferme et libère les variables.

On teste si Outlook est déjà ouvert :

If Not IsOutLookRunning() Then ' Si Outlook n'est pas déjà ouvert
RunOutlook
End If

On crée les objets Application et NameSpace d'Outlook, la référence au compte de messagerie et à la base en cours, puis on ouvre le Recordset basé sur la table T_Contact :

' Création de l'objet Application d'Outlook
Set objApp = new Outlook.Application

' Création de l'objet NameSpace d'Outlook
Set objSpace = objApp.GetNamespace("MAPI")

' Référence au dossier principal du compte de messagerie
Set objCptFolder = objSpace.Folders(DLookup("email", "T_CompteMessagerie"))

' Référence à la base de données courante
Set db = CurrentDb

' Ouverture du recordset basé sur la table T_Contact contenant les contacts dans Access
Set rs = db.OpenRecordset("T_Contact", dbOpenDynaset)

On parcourt les dossiers et sous-dossiers Outlook à la recherche de dossiers de contacts, puis on liste les contacts à la recherche de celui à mettre à jour :

' Dans le dossier principal du compte de messagerie
With objCptFolder

' On parcourt les dossiers contenus dans ce dossier parent
For Each objFolder In objApp.ActiveExplorer.Session.Folders.Item(i).Folders

If (objFolder.DefaultItemType = olContactItem) Then ' Si c'est un dossier de contacts

Set objContacts = objFolder.Items ' Référence à la liste des contacts contenus dans le dossier

For Each objContact In objContacts ' Parcours de la liste des contacts Outlook

' Si ce contact n'est pas un groupe de contacts
If (TypeName(objContact) <> "DistListItem") Then
'...

On teste pour chaque contact s'il est présent dans la table T_Contact, si c'est le cas, on le met à jour :

' Recherche dans la table T_Contact du contact ayant le même identifiant Outlook
rs.FindFirst "[IdContact] = " & IIf(objContact.BillingInformation = "", 0, objContact.BillingInformation)

If Not rs.NoMatch Then ' Si un contact Access possède le même identifiant

With rs

.Edit ' On met à jour ce contact avec les infos de Outlook

...

!IdDossierOutlook = objFolder.EntryID ' On copie dans le champ Access l'identifiant du dossier Outlook
!IdContactOutlook = objContact.EntryID ' On copie dans le champ Access l'identifiant du contact Outlook

.Update ' Enregistrement du contact dans la table

End With

End If
...

Pour finir, on minimise la fenêtre Outlook pour revenir à la fenêtre Access, puis ferme et libère les variables :

'On minimise la fenêtre Outlook pour revenir sur Access
objApp.ActiveWindow.WindowState = 1
InitialiserLiens = True

' Partie gestion de l'erreur
err_InitialiserLiens:
If (Err.Number <> 0) And Not InitialiserLiens Then ' Partie gestion de l'erreur
MsgBox "MS Access a généré une erreur" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf &  "Description de l'erreur: " & _
Err.Description, vbCritical, "Une erreur a eu lieu !"
End If
On Error Resume Next
'Fermeture et libérations des variables
If Not (rs Is Nothing) Then
rs.Close
End If
Set rs = Nothing
Set db = Nothing
Set objContact = Nothing
Set objContacts = Nothing
Set objSubFolder = Nothing
Set objFolder = Nothing
Set objCptFolder = Nothing
Set objSpace = Nothing
Set objApp = Nothing

VIII - Les bases de données à télécharger

Les bases jointes sont au format mdb et accdb.

Enregistrez bien au début l'adresse e-mail de votre compte de messagerie dans la table T_CompteMessagerie.

IX - Remerciements

Je tiens à remercier Tahar AIT OUARAB pour m'avoir donné l'idée de développer ce type d'outil, Pierre Fauconnier pour m'avoir conseillé et aidé pour la réalisation de cet article, ainsi que Claude Leloup pour sa relecture.