VBA et outlook : Un temps monstreux et saturation de mémoire !!

Question

Salut à tous !

J'ai développé une appli avec vba sous outlook qui créer des contacts et qui les place dans des listes de distribution.
Il y a plus de 3800 contacts à créer et à placer dans au moins 3 listes chacun.
Le prog prend un temps fou (plus d'une heure 30) mais le pire est que la mémoire sature très rapidement.

Ma question est donc : Quelqu'un peut-il me dire si outlook stocke les objets qu'il utilise, en mémoire et ne les supprime que lorsque la macro est terminée ?

J'ai bien fermé tout les objets et les mettre à nothing, mais ça n'a pas l'air d'être à ça...

merci à tous

Zlackzj

cs_dragon · Answer

il y a dequoi qui rempli la mémoire, il doit te manquer dequoi a fermer

assure toi d'optimiser ton code au maximum, au pire poste ton code ici et je vasi regarder

zlackzj13 · Answer

J'ai regardé mais je ferme vraiment tout les objets !!
Je vais essayé de faire des tests en regardant les objets dans la pile d'exécution de VBA.
Mon code est celui-ci : 


Sub mettreAJourListes()
'Cette procédure permet de mettre à jour les listes de diffusion.
   
    'Noms des différents dossiers utilisés sous Outlook :
    Dim leNomDossiersPersonnels As String
    Dim leNomDossierContacts As String
    Dim leNomDossierMedecins As String
    Dim leNomDossierListesSpe As String
    Dim leNomDossierListesEts As String
    Dim leNomDossierListesSocietes As String
    leNomDossiersPersonnels = "Dossiers personnels"
    leNomDossierContacts = "Contacts"
    leNomDossierMedecins = "Médecins"
    leNomDossierListesSpe = "Listes spécialités"
    leNomDossierListesEts = "Listes établissements"
    leNomDossierListesSocietes = "Listes Sociétés"
    
    'Objets utilisés sous Outlook :
    Dim lesDossiersPersonnels As Outlook.MAPIFolder
    Dim leDossierContacts As Outlook.MAPIFolder
    Dim leDossierMedecins As Outlook.MAPIFolder
    Dim leDossierListesEts As Outlook.MAPIFolder
    Dim leDossierListesSpe As Outlook.MAPIFolder
    Dim leDossierListesSocietes As Outlook.MAPIFolder
    Dim leContact As Outlook.ContactItem
    Dim laListe As Outlook.DistListItem
    Dim leDestMedecin As Outlook.Recipient
    Dim lesDestinataires As Outlook.Recipients
    Dim lObjetTemporaire As Outlook.MailItem
    
    'Objets utilisés pour l'accès aux données :
    Dim laTableMAJ As New ADODB.Recordset
    Dim laTableGDS As New ADODB.Recordset
    Dim lesEnregistrementsAux As New ADODB.Recordset
    Dim laConnexionGDS As New ADODB.Connection  'Connexion à la base médecins
    Dim laConnexionMAJ As New ADODB.Connection  'Connexion à la base de mise à jour
    Dim laCommandeGDS As New ADODB.Command  'Commande gérant la première connexion
    Dim laCommandeMAJ As New ADODB.Command  'Commande gérant la seconde
    Dim laRequete As String 'La requête envoyée à une base
    
    'Variables diverses :
    Dim leTableauDeChaines() As String
    Dim lIndiceI As Integer
    Dim lIndiceJ As Integer
    Dim existeDeja As Boolean
    Dim estTrouve As Boolean

    Set lesDossiersPersonnels = Application.Session.Folders.Item(leNomDossiersPersonnels)
    Set leDossierContacts = lesDossiersPersonnels.Folders.Item(leNomDossierContacts)
    Set leDossierMedecins = leDossierContacts.Folders.Item(leNomDossierMedecins)
    Set leDossierListesSpe = leDossierContacts.Folders.Item(leNomDossierListesSpe)
    Set leDossierListesEts = leDossierContacts.Folders.Item(leNomDossierListesEts)
    Set leDossierListesSocietes = leDossierContacts.Folders.Item(leNomDossierListesSocietes)
    
    'En créant un mail temporaire, on va pouvoir récupérer un objet Recipients :
    Set lObjetTemporaire = Application.CreateItem(olMailItem)
    Set lesDestinataires = lObjetTemporaire.Recipients

    'Initialisation des chemins des bases de données
    initialiserCheminsAccesBDs

    '**** CONNEXION ****
    laConnexionGDS.Provider = "Microsoft.Jet.OLEDB.4.0"
    laConnexionGDS.ConnectionString = saChaineConnexionGDS
    laConnexionGDS.Open
    laConnexionMAJ.Provider = "Microsoft.Jet.OLEDB.4.0"
    laConnexionMAJ.ConnectionString = saChaineConnexionMAJ
    laConnexionMAJ.Open

    '**** CREATION COMMANDE ****
    laCommandeGDS.ActiveConnection = laConnexionGDS
    laCommandeMAJ.ActiveConnection = laConnexionMAJ
    
    '**** CREATION ENREGISTREMENTS ****
    laTableMAJ.CursorLocation = adUseClient
    laTableMAJ.CursorType = adOpenDynamic
    laTableMAJ.LockType = adLockOptimistic
    laTableGDS.CursorLocation = adUseClient
    laTableGDS.CursorType = adOpenDynamic
    laTableGDS.LockType = adLockOptimistic
    lesEnregistrementsAux.CursorLocation = adUseClient
    lesEnregistrementsAux.CursorType = adOpenDynamic
    lesEnregistrementsAux.LockType = adLockOptimistic

   
    '*****************************************************
    '**** TRAITEMENT DES LIENS MEDECINS - SPECIALITES ****
    '*****************************************************
    'On récupère les différentes opérations effectuées sur les spécialité des praticiens (Ajout dans une spécialité,
    'Suppression du praticien d'une spécialité).
    
    
    '**** CAS DES AJOUTS ****
    laRequete = "SELECT R_Infos_Medecin_Specialite.[Specialites], R_Infos_Medecin_Specialite.[Nom], R_Infos_Medecin_Specialite.[Prenom], R_Infos_Medecin_Specialite.[Mail] " _
                & "FROM R_Infos_Medecin_Specialite " _
                & "WHERE R_Infos_Medecin_Specialite.[Type] = 'AJOUT_SPECIALITE'"
    laCommandeMAJ.CommandText = laRequete
    laTableMAJ.Open laCommandeMAJ
    
    If laTableMAJ.EOF = False Then
        laTableMAJ.MoveFirst
    End If
lIndiceI = 1
    Do While laTableMAJ.EOF = False
        Set lesDestinataires = lObjetTemporaire.Recipients
        'Récupération de la liste :        Set laListe leDossierListesSpe.Items.Find("[Subject] """ & laTableMAJ.Fields(0).Value & """")
        
        'Si elle n'existe pas, on la créé :
        If TypeName(laListe) = "Nothing" Then
            Set laListe = leDossierListesSpe.Items.Add(olDistributionListItem)
            laListe.DLName = laTableMAJ.Fields(0).Value
            laListe.Save
        End If
        
        'Ajout du médecin à la liste. Si il y est déjà présent, il n'est pas ajouté par Outlook :
        lesDestinataires.Add Replace("" & laTableMAJ.Fields(3).Value, "@gsante.net", "")
        lesDestinataires.ResolveAll
        laListe.AddMembers lesDestinataires
        laListe.DLName = laListe.DLName
        laListe.Save
        
        lesDestinataires.Remove (1)
        
Debug.Print lIndiceI & " ajoutSpe: " & laTableMAJ.Fields(0).Value
lIndiceI = lIndiceI + 1
        'Passage à l'enregistrement suivant :
        laTableMAJ.MoveNext
        laListe.Close olDiscard
        Set laListe = Nothing
        Set lesDestinataires = Nothing
    Loop
    
    'Fermeture des enregistrements :
    laTableMAJ.Close
    Set laTableMAJ = Nothing
    
    
    '**** CAS DES SUPPRESSIONS ****
    laRequete = "SELECT R_Infos_Medecin_Specialite.[Specialites], R_Infos_Medecin_Specialite.[Nom], R_Infos_Medecin_Specialite.[Prenom], R_Infos_Medecin_Specialite.[Mail] " _
                & "FROM R_Infos_Medecin_Specialite " _
                & "WHERE R_Infos_Medecin_Specialite.[Type] = 'SUPPR_SPECIALITE'"
    laCommandeMAJ.CommandText = laRequete
    laTableMAJ.Open laCommandeMAJ
    
    If laTableMAJ.EOF = False Then
        laTableMAJ.MoveFirst
    End If
    
    Do While laTableMAJ.EOF = False
        'Récupération de la liste :        Set laListe leDossierListesSpe.Items.Find("[Subject] """ & laTableMAJ.Fields(0).Value & """")
                      
        If TypeName(laListe) <> "Nothing" Then
            'Recherche et suppression du médecin de la liste :
            For lIndiceI = 1 To laListe.MemberCount
                Set leDestMedecin = laListe.GetMember(lIndiceI)
                If leDestMedecin.Address = laTableMAJ.Fields(3).Value Then
                    'Suppression de la liste :
                    lesDestinataires.Add leDestMedecin
                    lesDestinataires.ResolveAll
                    laListe.RemoveMembers lesDestinataires
                    laListe.Save
                    
                    lesDestinataires.Remove (1)
                    
                    Exit For
                End If
            Next lIndiceI
        
            'Si il n'y a plus de membres dans la liste, alors on la supprime :
            If laListe.MemberCount = 0 Then
                laListe.Delete
            End If
        End If
        
        'Passage à l'enregistrement suivant :
        laTableMAJ.MoveNext
        laListe.Close olDiscard
        Set laListe = Nothing
        Set leDestMedecin = Nothing
    Loop
    
    'Fermeture des enregistrements :
    laTableMAJ.Close
    Set laTableMAJ = Nothing

    
    '***************************************************
    '**** TRAITEMENT DES LIENS MEDECINS - CLINIQUES ****
    '***************************************************
    'On récupère les différentes opérations effectuées sur les cliniques des praticiens (Ajout dans une clinique,
    'Suppression du praticien d'une clinique).
    'On vérifiera également tout ajout ou suppression d'un médecin dans une société.
    
    
    '**** CAS DES AJOUTS ****
    laRequete = "SELECT R_Infos_Medecin_Clinique.[Cliniques], R_Infos_Medecin_Clinique.[Societe], R_Infos_Medecin_Clinique.[Nom], R_Infos_Medecin_Clinique.[Prenom], R_Infos_Medecin_Clinique.[Mail] " _
                & "FROM R_Infos_Medecin_Clinique " _
                & "WHERE R_Infos_Medecin_Clinique.[Type] = 'AJOUT_CLINIQUE'"
    laCommandeMAJ.CommandText = laRequete
    laTableMAJ.Open laCommandeMAJ
    
    If laTableMAJ.EOF = False Then
        laTableMAJ.MoveFirst
    End If
lIndiceI = 1
    Do While laTableMAJ.EOF = False
    
        Set lesDestinataires = lObjetTemporaire.Recipients
        '**** LISTE CLINIQUE ****
        'Récupération de la liste clinique :        Set laListe leDossierListesEts.Items.Find("[Subject] """ & laTableMAJ.Fields(0).Value & """")
        
        'Si la liste n'existe pas, on la créé :
        If TypeName(laListe) = "Nothing" Then
            Set laListe = leDossierListesEts.Items.Add(olDistributionListItem)
            laListe.DLName = laTableMAJ.Fields(0).Value
            laListe.Save
        End If
        
        'Ajout du médecin à la liste. Si il y est déjà présent, Outlook ne l'ajoute pas :
        lesDestinataires.Add Replace("" & laTableMAJ.Fields(4).Value, "@gsante.net", "")
        lesDestinataires.ResolveAll
        laListe.AddMembers lesDestinataires
        laListe.DLName = laListe.DLName
        laListe.Save
               
        lesDestinataires.Remove (1)
        
        laListe.Close olDiscard
        Set laListe = Nothing
        Set lesDestinataires = Nothing
                       
        Set lesDestinataires = lObjetTemporaire.Recipients
        '**** LISTE SOCIETE ****
        'Récupération de la liste société :        Set laListe leDossierListesSocietes.Items.Find("[Subject] """ & laTableMAJ.Fields(1).Value & """")
        
        'Si la liste n'existe pas, on la créé :
        If TypeName(laListe) = "Nothing" Then
            Set laListe = leDossierListesSocietes.Items.Add(olDistributionListItem)
            laListe.DLName = laTableMAJ.Fields(1).Value
            laListe.Save
        End If
        
        'Ajout du médecin à la liste. Si il y est déjà présent, Outlook ne l'ajoute pas :
        lesDestinataires.Add Replace("" & laTableMAJ.Fields(4).Value, "@gsante.net", "")
        lesDestinataires.ResolveAll
        laListe.AddMembers lesDestinataires
        laListe.DLName = laListe.DLName
        laListe.Save
        
        lesDestinataires.Remove (1)
        
Debug.Print lIndiceI & " ajoutEtsSoc: " & laTableMAJ.Fields(0).Value
lIndiceI = lIndiceI + 1
        'Passage à l'enregistrement suivant :
        laTableMAJ.MoveNext
        laListe.Close olDiscard
        Set laListe = Nothing
        Set lesDestinataires = Nothing
    Loop
    
    'Fermeture des enregistrements :
    laTableMAJ.Close
    Set laTableMAJ = Nothing
        
    
    '**** CAS DES SUPPRESSIONS ****
    laRequete = "SELECT R_Infos_Medecin_Clinique.[Cliniques], R_Infos_Medecin_Clinique.[Societe], R_Infos_Medecin_Clinique.[Nom], R_Infos_Medecin_Clinique.[Prenom], R_Infos_Medecin_Clinique.[Mail], R_Infos_Medecin_Clinique.[GUIDPraticien] " _
                & "FROM R_Infos_Medecin_Clinique " _
                & "WHERE R_Infos_Medecin_Clinique.[Type] = 'SUPPR_CLINIQUE'"
    laCommandeMAJ.CommandText = laRequete
    laTableMAJ.Open laCommandeMAJ
    
    If laTableMAJ.EOF = False Then
        laTableMAJ.MoveFirst
    End If

    Do While laTableMAJ.EOF = False
    
        '**** LISTE CLINIQUE ****
        'Récupération de la liste clinique :        Set laListe leDossierListesEts.Items.Find("[Subject] """ & laTableMAJ.Fields(0).Value & """")
               
        'Recherche et suppression du médecin dans la liste :
        For lIndiceI = 1 To laListe.MemberCount
            Set leDestMedecin = laListe.GetMember(lIndiceI)
            If leDestMedecin.Address = laTableMAJ.Fields(4).Value Then
                'Suppression du médecin de la liste :
                lesDestinataires.Add leDestMedecin
                lesDestinataires.ResolveAll
                laListe.RemoveMembers lesDestinataires
                laListe.Save
                
                lesDestinataires.Remove (1)
                
                Exit For
            End If
        Next lIndiceI
        
        'Si il n'y a plus de membres dans la liste, on la supprime :
        If laListe.MemberCount = 0 Then
            laListe.Delete
        Else
            laListe.Close olDiscard
        End If
        
        Set leDestMedecin = Nothing
        Set laListe = Nothing
        
        '**** LISTE SOCIETE ****
        'Lors de la suppression d'un médecin d'une clinique, il ne doit être également supprimé de la société que si il
        'n'y est plus présent dans aucun autre établissement :
        
        'On vérifie si il existe des lignes dans la table Ass_Cliniques avec le GUID du médecin et le libellé de la
        'société. Si ce n'est pas le cas, on  doit le supprimer :
        laRequete = "SELECT Count(Ass_Cliniques.[NomSociete]) " _
                    & "FROM Ass_Cliniques " _
                    & "WHERE Ass_Cliniques.[GUIDPraticien] = '" & laTableMAJ.Fields(5).Value & "' " _
                    & "AND Ass_Cliniques.[NomSociete] = '" & laTableMAJ.Fields(1).Value & "'"
        laCommandeMAJ.CommandText = laRequete
        lesEnregistrementsAux.Open laCommandeMAJ
        
        If lesEnregistrementsAux.EOF = False Then
            lesEnregistrementsAux.MoveFirst
                            
            If lesEnregistrementsAux.Fields(0).Value = 0 Then
                'Récupération de la liste société :                Set laListe leDossierListesSocietes.Items.Find("[Subject] """ & laTableMAJ.Fields(1).Value & """")
                   
                'Recherche et suppression du médecin dans la liste :
                For lIndiceI = 1 To laListe.MemberCount
                    Set leDestMedecin = laListe.GetMember(lIndiceI)
                    If leDestMedecin.Address = laTableMAJ.Fields(4).Value Then
                        'Suppression du médecin de la liste :
                        lesDestinataires.Add leDestMedecin
                        lesDestinataires.ResolveAll
                        laListe.RemoveMembers lesDestinataires
                        laListe.Save
                        
                        lesDestinataires.Remove (1)
                        
                        Exit For
                    End If
                Next lIndiceI
            
                'Si il n'y a plus de membres dans la liste, on la supprime :
                If laListe.MemberCount = 0 Then
                    laListe.Delete
                Else
                    laListe.Close olDiscard
                End If
            End If
        End If
        
        'Fermeture des enregistrements :
        lesEnregistrementsAux.Close
        Set lesEnregistrementsAux = Nothing
        
        'Passage à l'enregistrement suivant :
        laTableMAJ.MoveNext
        Set laListe = Nothing
        Set leDestMedecin = Nothing
        
    Loop
    
    'Fermeture des enregistrements :
    laTableMAJ.Close
    Set laTableMAJ = Nothing
    
    
    '**** MODIFICATION DES BOOLEENS DE MISE A JOUR ****
    
    'Modification de la table des infos des spécialités :
    laRequete = "UPDATE Infos_Medecin_Specialite " _
                & "SET Infos_Medecin_Specialite.[estMAJ] = 1 " _
                & "WHERE Infos_Medecin_Specialite.[estMAJ] = 0"
    laCommandeMAJ.CommandText = laRequete
    laTableMAJ.Open laCommandeMAJ
    
    'Modification de la table des infos des cliniques :
    laRequete = "UPDATE Infos_Medecin_Clinique " _
                & "SET Infos_Medecin_Clinique.[estMAJ] = 1 " _
                & "WHERE Infos_Medecin_Clinique.[estMAJ] = 0"
    laCommandeMAJ.CommandText = laRequete
    laTableMAJ.Open laCommandeMAJ

    'Fermeture des connexions :
    laConnexionMAJ.Close
    Set laConnexionMAJ = Nothing
    laConnexionGDS.Close
    Set laConnexionGDS = Nothing
    
    'Suppression des objets en mémoire :
    Set lesDossiersPersonnels = Nothing
    Set leDossierContacts = Nothing
    Set leDossierMedecins = Nothing
    Set leDossierListesEts = Nothing
    Set leDossierListesSpe = Nothing
    Set leDossierListesSocietes = Nothing
    Set leContact = Nothing
    Set laListe = Nothing
    Set leDestMedecin = Nothing
    Set lesDestinataires = Nothing
    Set lObjetTemporaire = Nothing
    Set laTableMAJ = Nothing
    Set laTableGDS = Nothing
    Set lesEnregistrementsAux = Nothing
    Set laConnexionGDS = Nothing
    Set laConnexionMAJ = Nothing
    Set laCommandeGDS = Nothing
    Set laCommandeMAJ = Nothing

End Sub


J'speres que t'arriveras à comprendre quelque chose.
Merci d'avoir répondu !

Zlackzj

zlackzj13 · Answer

Après des tests, j'ai trouvé que c'était l'ajout à la liste qui sature la mémoire. Mais pourtant je ferme bien chaque liste et je les réinitialise à "nothing" à chaque fois...

Zlackzj

zlackzj13 · Answer

Bon, mes tests confirme bien l'idée :
En fait, mon programme ajoute un contact dans la listes des destinataires (Recipients) et ajoute l'ensemble des contacts de cet objet (en l'ocurrence un seul) dans la liste de distribution. Mais j'ai l'impression que malgré le fait que je libère la mémoire pour tous les objets, Outlook stocke quelque part ces informations. Ce qui fait qu'à chaque ajout de l'objet 'Recipients' dans la liste, il stocke cet objet, encombrant la mémoire.
Je vais donc changer mon principe pour n'ajouter cet objet qu'une seule fois (regrouper l'ensemble des contacts).

Est-ce que ma théorie se révèle bonne ??

Zlackzj

zlackzj13 · Answer

Une autre question : A quoi ça sert de résoudre un destinataire ? Vérifier qu'il existe dans notre liste ??
Zlackzj

cs_dragon · Answer

bon premièrement, pour une bonne programmation, faut couper en fonction

et pourquoi tu déclare tout en trippe ??? Je sais que tu dois ajouter 3 type de personnel, mais tu peux réutiliser ce qui est déjà déclaré

zlackzj13 · Answer

J'ai développé ça dans le cadre de mon stage de fin d'étude de DUT, et je continue un mois de plus dessus.
C'était donc destiné à un utilisateur qui ne s'y connaissais pas du tout en informatique et qui devait pourtant installé la macro !! Donc, pour plus de commodité à l'installation et la première exécution de la macro, j'ai privilégié un minimum de fonctions et de procédure. Mais cela alourdi le code, je sais.
Pour en revenir à mon pb, je l'ai résolu. En fait, et à mon avis, Outlook stockait à chaque fois l'objet "Recipients" en mémoire (d'une taille exacte de 4 Ko). J'ai 3800 contacts et chaque contacts doit être au minimum présent dans trois listes... fais le compte et tu devines très vite la suite !!
Mais en regroupant tous les contacts à insérer dans une liste d'abords, on minimise la création de ces objets "Recipients". Donc, la charge mémoire se stabilise.

Mais j'ai toujours mon pb de résolution de contact. En effet, parmis mes contacts, il y a des personnes de même nom mais de mails différents. Comment je peux utiliser la méthode "resolve" pour les différencier ?? Tu saurais ?

Zlackzj

VBA et outlook : Un temps monstreux et saturation de mémoire !!

7 réponses

Discussions similaires