[VBA] Problème de saturation mémoire lors d'une copie de contact
Aucune réponse
langkif
Bonjour,
La macro que je souhaite finir de réaliser est censée copier 2 répertoire de contact depuis les dossiers publics (Exchange) vers les dossiers privés d'un utilisateur. Les répertoires étant statiques et bien définis.
Ma macro fonctionne bien pour quelques contacts, mais dès qu'on dépasse 50 (environ), j'ai une erreur sur la ligne :
.GetInspector = citem1.GetInspector
Erreur d'execution 'xxx (toujours changeant)'
Mémoire ou ressourcessystèmes insuffisantes. Fermez quelques fenetres ou programme, puis recommencez.
Mes variables sont pourtant réinitialisées à chaque fois... Je seche complètement...
Par avance merci à ceux qui prendront quelques minutes de leur temps...
Voici le code, quelqu'un a une idée ?
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Application_Startup()
Dim myOlApp As Outlook.Application
Dim myOlApp3 As Outlook.Application
Dim oNamespace
Dim oFolder2 As Outlook.MAPIFolder
Dim oFolder3 As Outlook.MAPIFolder
Dim citem2
Dim verifClient, compteur, i, verifFournisseur, compteur2, j As Integer
verifClient = 0
Set myOlApp = New Outlook.Application
Set oNamespace = myOlApp.GetNamespace("MAPI")
Set oFolder2 = oNamespace.GetDefaultFolder(olFolderContacts)
Set tmp1 = oNamespace.GetDefaultFolder(olFolderContacts).Folders.GetFirst
compteur = oFolder2.Folders.Count
For i = 1 To compteur
If tmp1 = "Clients" Then
verifClient = 1
i = compteur
End If
Set tmp1 = oNamespace.GetDefaultFolder(olFolderContacts).Folders.GetNext
Next
If verifClient = 1 Then
Set oFolder2 = oFolder2.Folders("Clients")
oFolder2.Delete
End If
Set oFolder2 = oNamespace.GetDefaultFolder(olFolderContacts)
oFolder2.Folders.Add ("Clients")
Set oFolder2 = Nothing
Set oNamespace = Nothing
Set myOlApp = Nothing
verifFournisseur = 0
Set myOlApp3 = New Outlook.Application
Set oNamespace3 = myOlApp3.GetNamespace("MAPI")
Set oFolder3 = oNamespace3.GetDefaultFolder(olFolderContacts)
Set tmp2 = oNamespace3.GetDefaultFolder(olFolderContacts).Folders.GetFirst
compteur2 = oFolder3.Folders.Count
For j = 1 To compteur2
If tmp2 = "Fournisseurs" Then
verifFournisseur = 1
j = compteur2
End If
Set tmp2 = oNamespace3.GetDefaultFolder(olFolderContacts).Folders.GetNext
Next
If verifFournisseur = 1 Then
Set oFolder3 = oFolder3.Folders("Fournisseurs")
oFolder3.Delete
End If
Set oFolder3 = oNamespace3.GetDefaultFolder(olFolderContacts)
oFolder3.Folders.Add ("Fournisseurs")
Set oFolder3 = Nothing
Set myOlApp3 = Nothing
Set oNamespace3 = Nothing
'Copie des contacts fournisseurs **************************************************
Dim oOL As Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oRestricted As Outlook.Items
Dim oFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim nombre As Integer
Dim citem
Dim oemployee As Outlook.ContactItem
Set oOL = New Outlook.Application
Set oemployeefolder = oOL.GetNamespace("MAPI").Folders("Dossiers publics")
' à modifier *********************************************************************
Set oemployeefolder = oemployeefolder.Folders("Tous les dossiers publics")
Set oemployeefolder = oemployeefolder.Folders("Contacts xxxxx")
Set oemployeefolder = oemployeefolder.Folders("Fournisseurs")
Set oOL = GetObject(, "Outlook.Application")
If oOL Is Nothing Then
Set oOL = CreateObject("Outlook.Application")
End If
Set oNS = oOL.GetNamespace("MAPI")
Set oFolder = oNS.GetDefaultFolder(olFolderContacts)
Set oContact = oOL.CreateItem(olContactItem)
For Each citem In oemployeefolder.Items
'If comparer(citem.FileAs) = False Then
' Set oOL = GetObject(, "Outlook.Application")
'If oOL Is Nothing Then
Set oOL = CreateObject("Outlook.Application")
'End If
Set oNS = oOL.GetNamespace("MAPI")
Set oContact = oOL.CreateItem(olContactItem)
Set oFolder = oNS.GetDefaultFolder(olFolderContacts).Folders("Fournisseurs")
Set oItems = oFolder.Items
Set oContact = Nothing
Set oFolder = Nothing
Set oItems = Nothing
Set oOL = Nothing
Set oNS = Nothing
nombre = nombre + 1
End With
'End If
Next
' Copie des contacts clients ***************************************************
Dim oOL1 As Outlook.Application
Dim oNS1 As Outlook.NameSpace
Dim oRestricted1 As Outlook.Items
Dim oFolder1 As Outlook.MAPIFolder
Dim oItems1 As Outlook.Items
Dim oContact1 As Outlook.ContactItem
Dim citem1
Dim oemployee1 As Outlook.ContactItem
Set oOL1 = New Outlook.Application
Set oemployeefolder1 = oOL1.GetNamespace("MAPI").Folders("Dossiers publics")
' à modifier *********************************************************************
Set oemployeefolder1 = oemployeefolder1.Folders("Tous les dossiers publics")
Set oemployeefolder1 = oemployeefolder1.Folders("Contacts xxxxx")
Set oemployeefolder1 = oemployeefolder1.Folders("Clients")
Set oOL1 = GetObject(, "Outlook.Application")
If oOL1 Is Nothing Then
Set oOL1 = CreateObject("Outlook.Application")
End If
Set oNS1 = oOL1.GetNamespace("MAPI")
Set oFolder1 = oNS1.GetDefaultFolder(olFolderContacts)
Set oContact1 = oOL1.CreateItem(olContactItem)
For Each citem1 In oemployeefolder1.Items
'If comparer(citem.FileAs) = False Then
' Set oOL = GetObject(, "Outlook.Application")
'If oOL Is Nothing Then
Set oOL1 = CreateObject("Outlook.Application")
'End If
Set oNS1 = oOL1.GetNamespace("MAPI")
Set oContact1 = oOL1.CreateItem(olContactItem)
Set oFolder1 = oNS1.GetDefaultFolder(olFolderContacts).Folders("Clients")
Set oItems1 = oFolder1.Items
