synchro outlook-access : prob avec les modifs de fiches

[sebinator]

Bonjour,

Avec le code ci dessous, je peux synchroniser les contacts outlook2k3 avec un bdd access 2k3 :


Code :

 
 
'Dans un module : 
 
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 MAPIFolder
Dim nM As NameSpace
Dim olApp As Outlook.Application
Dim i As Integer
Dim j As Integer
 
j = 1
 
' Affectation des objets
 
Set olApp = CreateObject("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
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
 
Set db = OpenDatabase("C:\tempAcc\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(2) = Nz(mycont.LastName, " ")
    rs.Fields(3) = Nz(mycont.FirstName, " ")
    rs.Fields(4) = mycont.Email1Address
    rs.Fields(1) = Nz(mycont.CompanyName, " ")
    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.
 
'******************************************************************************
 
On Error Resume Next
 
Dim oCont As ContactItem
Dim oCo As ContactItem
Dim oFold As MAPIFolder
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("C:\tempAcc\contacts.mdb")
Set rs = db.OpenRecordset("Select * From Contacts")
Set olApp = CreateObject("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(3)
stFilt = stFilt & """ And [LastName] = """ & rs.Fields(2) & """"
 
' 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(3)
        oCont.LastName = rs.Fields(2)
        oCont.Email1Address = rs.Fields(4)
        oCont.CompanyName = rs.Fields(1)
        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
 
 
'A placer dans outlookthissession
 
Private Sub Application_Startup()
 
Dim strFichier As String
 
    strFichier = "C:\tempAcc\contacts.mdb"
    If Dir(strFichier) <> "" And strFichier <> "" Then
        MettreAJourContact
        ParcourirContact
 
        MsgBox "Base de données Access synchronisée !"
 
    Else
 
        MsgBox "La Base de n'est pas accessible ! Vérifiez la connexion réseau ! La synchronisation ne peut se faire !", vbInformation
 
    End If
 
End Sub
 
 
Private Sub Application_Quit()
Dim strFichier As String
 
    strFichier = "C:\tempAcc\contacts.mdb"
    If Dir(strFichier) <> "" And strFichier <> "" Then
        MettreAJourContact
        ParcourirContact
        MsgBox "Base de données Access synchronisée !"
 
    Else
      
 
    End If
End Sub
 

Mon problème maintenant sont les modifications :

Par ex: si une adresse mail est modifiée sur une fiche dans outlook, celle ci n'est pas synchronisée dans la bdd. C'est embettant.

Comment peut-on détecter la modif et initié la maj de la bdd ?

Merci d'avance

Seb

[Oliv-]

SAlut,

En comparant une date de synchro (à stocker) avec la date de modif des contacts. Il faut peut être aussi stocker un identifiant unique désignant ton contact si tu changes son nom

[sebinator]

l'identifiant unique je l'ai... c'est la clef primaire dans la bdd.

mais comment faire pour récupérer la date de modif d'une fiche dans outlook ?

[Oliv-]

Salut,
c'est la propriété

LastModificationTime
ex: #16/11/2007 12:46:23#

[sebinator]

Ok,

dans ma bdd, j'ai ajouté un champ datesync que j'alimente avec la proprièté que tu m'as donné, j'ai aussi ajouté un champ modifbdd qui récupère la date de modif si la fiche est modifiée dans access.

je coince dans le code, en fait je suis largué.

A quel niveau dans le code je dois intervenir pour lui dire :

lors de la synchro, de comparer les dates de modifs des fiches outlook et les dates de modifs contenues dans champs datesync et modifbdd et de synchroniser la fiche la plus récente....

[Oliv-]

Salut,
A chaque boucle (changement de contact ou ligne) il faut faire ce controle.
A toi a définir la priorité aussi fichier prévaut sur outlook ou le contraire.
Bon courage

[sebinator]

Bien, j'avance doucement...

j'ai ajouté le code ci dessous dans la function accesADB.

A partir d'outlook, quand je modifie une adresse email sur une fiche existante et déja dans la BDD. La modif est bien détectée et la synchro se fait... Yesssss.

 
Dim LastDateModif As String
'////////////////////////////////////////////////////////////////////////////////
'alimente la variable LastDateModif avec la date de modif de la fiche
'////////////////////////////////////////////////////////////////////////////////
LastDateModif = mycont.LastModificationTime
 
'////////////////////////////////////////////////////////////////////////////////
'compare la date de modif de la fiche avec la date de modif présente dans la Bdd
'Si la fiche est plus récente, l'enregistrement est mis a jour dans la Bdd
'////////////////////////////////////////////////////////////////////////////////
If LastDateModif > rs.Fields(18) Then
    rs.Edit
    rs.Fields(2) = Nz(mycont.LastName, " ")
    rs.Fields(3) = Nz(mycont.FirstName, " ")
    rs.Fields(4) = mycont.Email1Address
    rs.Fields(1) = Nz(mycont.CompanyName, " ")
    rs.Fields(18) = mycont.LastModificationTime
    rs.Update
End If
 

Maintenant je cherche à faire le contraire, a savoir que si la fiche est plus récente dans la bdd, la synchro doit mettre a jour la fiche dans outlook. je pars donc sur le même principe mais je ne trouve pas la propriété pour mettre a jour la fiche... je vois bien items.add,delete... mais pas de modify ou edit...

[Oliv-]

Salut,
Il me semble que lorsque tu vas faire ta mise à jour de outlook, avec la ligne

oCont.Save

le champs

mycont.LastModificationTime

va être automatiquement modifié.
et donc il faut faire un update de access avec cette date.

[sebinator]

J'essaye avec save et ca ne fonctionne pas.

voila ce que j'ai mis :

'////////////////////////////////////////////////////////////////////////////////
'compare la date de modif de la fiche avec la date de modif présente dans la Bdd
'Si la fiche de la bdd est plus récente, l'enregistrement est mis a jour dans outlook
'////////////////////////////////////////////////////////////////////////////////
 
LastDateModif = oCont.LastModificationTime
 
If rs.Fields(18) > LastDateModif Then
        
        oCont.CompanyName = rs.Fields(1)
        oCont.LastName = rs.Fields(2)
        oCont.FirstName = rs.Fields(3)
        oCont.Email1Address = rs.Fields(4)
        oCont.Save
 
End If
 
 

Si je modifie une fiche en changeant une adresse mail et mettant un date de modif plus recente que celle dans outlook, rien ne passe... je ne dois pas m'y prendre correctement

[Oliv-]

Peux tu publier ton code complet je vais tester sur mon poste

[sebinator]

voici le code

Dans un module :

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
 
'**************************************************************************
' Modif
'
'
'*************************************************************************
On Error Resume Next
 
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sql As String
Dim LastDateModif 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
 
Set db = OpenDatabase("C:\tempAcc\contacts.mdb")
Set rs = db.OpenRecordset(sql)
 
 
'**********************************************************************
' 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(2) = Nz(mycont.LastName, " ")
    rs.Fields(3) = Nz(mycont.FirstName, " ")
    rs.Fields(4) = mycont.Email1Address
    rs.Fields(1) = Nz(mycont.CompanyName, " ")
    rs.Fields(18) = mycont.LastModificationTime
    rs.Update
 
End If
'////////////////////////////////////////////////////////////////////////////////
'alimente la variable LastDateModif avec la date de modif de la fiche
'////////////////////////////////////////////////////////////////////////////////
LastDateModif = mycont.LastModificationTime
 
'////////////////////////////////////////////////////////////////////////////////
'compare la date de modif de la fiche avec la date de modif présente dans la Bdd
'Si la fiche est plus récente, l'enregistrement est mis a jour dans la Bdd
'////////////////////////////////////////////////////////////////////////////////
If LastDateModif > rs.Fields(18) Then
    rs.Edit
    rs.Fields(2) = Nz(mycont.LastName, " ")
    rs.Fields(3) = Nz(mycont.FirstName, " ")
    rs.Fields(4) = mycont.Email1Address
    rs.Fields(1) = Nz(mycont.CompanyName, " ")
    rs.Fields(18) = mycont.LastModificationTime
    rs.Update
End If
 
 
'////////////////////////////////////////////////////////////////////////////////
'compare la date de modif de la fiche avec la date de modif présente dans outlook
'Si la fiche est plus récente, l'enregistrement est mis a jour dans la outlook
'////////////////////////////////////////////////////////////////////////////////
 
'**********************************************************************
' Libération des objets
'**********************************************************************
 
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
 
End Function
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
 
'*************************************************************************
' Modif
'
'
'*************************************************************************
 
Dim oCont As ContactItem
Dim oFold As MAPIFolder
Dim nM As NameSpace
Dim olApp As Outlook.Application
Dim i As Integer
Dim j As Integer
 
j = 1
 
' Affectation des objets
 
Set olApp = CreateObject("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 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.
'******************************************************************************
' Modif
'
'
'*************************************************************************
On Error Resume Next
 
Dim oCont As ContactItem
Dim oCo As ContactItem
Dim oFold As MAPIFolder
Dim nM As NameSpace
Dim olApp As Outlook.Application
Dim stFilt As String
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim LastDateModif As String
 
 
'******************************************************************************
' Affectation des objets
'******************************************************************************
 
Set db = OpenDatabase("C:\tempAcc\contacts.mdb")
Set rs = db.OpenRecordset("Select * From Contacts")
Set olApp = CreateObject("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(3)
stFilt = stFilt & """ And [LastName] = """ & rs.Fields(2) & """"
 
' 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.CompanyName = rs.Fields(1)
        oCont.LastName = rs.Fields(2)
        oCont.FirstName = rs.Fields(3)
        oCont.Email1Address = rs.Fields(4)
        oCont.Save
        
 
 
 
End If
 
 
'////////////////////////////////////////////////////////////////////////////////
'compare la date de modif de la fiche avec la date de modif présente dans la Bdd
'Si la fiche de la bdd est plus récente, l'enregistrement est mis a jour dans outlook
'////////////////////////////////////////////////////////////////////////////////
 
LastDateModif = oCont.LastModificationTime
 
If rs.Fields(18) > LastDateModif Then
        
        oCont.CompanyName = rs.Fields(1)
        oCont.LastName = rs.Fields(2)
        oCont.FirstName = rs.Fields(3)
        oCont.Email1Address = rs.Fields(4)
        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
 
 

Dans thisoutlooksession :

Private Sub Application_Startup()
 
Dim strFichier As String
 
    strFichier = "C:\tempAcc\contacts.mdb"
 
    If Dir(strFichier) <> "" And strFichier <> "" Then
 
        MettreAJourContact
 
        ParcourirContact
 
        MsgBox "Base de données Access synchronisée !"
 
    Else
 
        MsgBox "La Base de n'est pas accessible ! Vérifiez la connexion réseau ! La synchronisation ne peut se faire !", vbInformation
 
    End If
 
 
 
 
 
End Sub
 
Private Sub Application_Quit()
 
Dim strFichier As String
 
    strFichier = "C:\tempAcc\contacts.mdb"
 
    If Dir(strFichier) <> "" And strFichier <> "" Then
 
        MettreAJourContact
 
        ParcourirContact
 
        MsgBox "Base de données Access synchronisée !"
 
    Else
 
        
 
    End If
 
End Sub
 
 

en piece jointe la bdd
merci pour ton aide

[Oliv-]

Salut sebinator,
il manque ta fonction NZ

[sebinator]

a quel niveau ?

[Oliv-]

Dans AccesADB il y a plusieurs lignes :

rs.Fields(2) = Nz(mycont.LastName, " ")

cela fait donc appel à une fonction NZ() qui doit remplacer la valeur null par " " selon moi.

mais cela pose le pb de la comparaison après avec outlook !!

1. Si tu n'as pas de FIRSTNAME dans outlook tu inscrits " " dans access
2. puis dans MettreAJourContact()
   Set oCo = oFold.Items.Find(stFilt)
   où tu filtres sur le nom et le prénom tu compares "" à " "
3. donc création de doublon.
   

.

donc on pourrait écrire :

rs.AddNew
    If mycont.LastName <> "" Then rs.Fields(2) = mycont.LastName
    If mycont.FirstName <> "" Then rs.Fields(3) = mycont.FirstName
    If mycont.Email1Address <>