[VBA] Problème de saturation mémoire lors d'une copie de contact

Le
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")

' *********************************************************************************

nombre = 0



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



'For Each objcontactitem.ContactItem.olContactItem In oContact
With oContact
'.FullName = citem.FullName
'.HomeAddress = "AdresseSamples"
.Account = citem.Account
.Anniversary = citem.Anniversary
.AssistantName = citem.AssistantName
.AssistantTelephoneNumber = citem.AssistantTelephoneNumber
.BillingInformation = citem.BillingInformation
.Birthday = citem.Birthday
.Body = citem.Body
.BusinessTelephoneNumber = citem.BusinessTelephoneNumber
.BusinessFaxNumber = citem.BusinessFaxNumber
.Business2TelephoneNumber = citem.Business2TelephoneNumber
.BusinessAddressPostOfficeBox = citem.BusinessAddressPostOfficeBox
.BusinessAddressState = citem.BusinessAddressState
.BusinessAddressStreet = citem.BusinessAddressStreet
.BusinessHomePage = citem.BusinessHomePage
.CallbackTelephoneNumber = citem.CallbackTelephoneNumber
.CarTelephoneNumber = citem.CarTelephoneNumber
.Categories = citem.Categories
.Children = citem.Children
.Companies = citem.Companies
.CompanyName = citem.CompanyName
.ComputerNetworkName = citem.ComputerNetworkName
.CustomerID = citem.CustomerID
.Department = citem.Department
.Email1Address = citem.Email1Address
.Email1AddressType = citem.Email1AddressType
.Email2Address = citem.Email2Address
.Email2AddressType = citem.Email2AddressType
.Email3Address = citem.Email3Address
.Email3AddressType = citem.Email3AddressType
.FileAs = citem.FileAs
.FirstName = citem.FirstName
.FormDescription = citem.FormDescription
.FTPSite = citem.FTPSite
.FullName = citem.FullName
.Gender = citem.Gender
.GetInspector = citem.GetInspector
.GovernmentIDNumber = citem.GovernmentIDNumber
.Hobby = citem.Hobby
.Home2TelephoneNumber = citem.Home2TelephoneNumber
.HomeAddress = citem.HomeAddress
.HomeAddressCity = citem.HomeAddressCity
.HomeAddressCountry = citem.HomeAddressCountry
.HomeAddressPostalCode = citem.HomeAddressPostalCode
.HomeAddressPostOfficeBox = citem.HomeAddressPostOfficeBox
.HomeAddressState = citem.HomeAddressState
.HomeAddressStreet = citem.HomeAddressStreet
.HomeFaxNumber = citem.HomeFaxNumber
.HomeTelephoneNumber = citem.HomeTelephoneNumber
.Importance = citem.Importance
.Initials = citem.Initials
.InternetFreeBusyAddress = citem.InternetFreeBusyAddress
.ISDNNumber = citem.ISDNNumber
.JobTitle = citem.JobTitle
.Journal = citem.Journal
.Language = citem.Language
.LastName = citem.LastName
.MailingAddress = citem.MailingAddress
.MailingAddressCity = citem.MailingAddressCity
.MailingAddressCountry = citem.MailingAddressCountry
.MailingAddressPostalCode = citem.MailingAddressPostalCode
.MailingAddressPostOfficeBox = citem.MailingAddressPostOfficeBox
.MailingAddressState = citem.MailingAddressState
.MailingAddressStreet = citem.MailingAddressStreet
.ManagerName = citem.ManagerName
.MessageClass = citem.MessageClass
.MiddleName = citem.MiddleName
.Mileage = citem.Mileage
.MobileTelephoneNumber = citem.MobileTelephoneNumber
.NetMeetingAlias = citem.NetMeetingAlias
.NetMeetingServer = citem.NetMeetingServer
.NickName = citem.NickName
.NoAging = citem.NoAging
.OfficeLocation = citem.OfficeLocation
.OrganizationalIDNumber = citem.OrganizationalIDNumber
.OtherAddress = citem.OtherAddress
.OtherAddressCity = citem.OtherAddressCity
.OtherAddressCountry = citem.OtherAddressCountry
.OtherAddressPostalCode = citem.OtherAddressPostalCode
.OtherAddressPostOfficeBox = citem.OtherAddressPostOfficeBox
.OtherAddressState = citem.OtherAddressState
.OtherAddressStreet = citem.OtherAddressStreet
.OtherFaxNumber = citem.OtherFaxNumber
.OtherTelephoneNumber = citem.OtherTelephoneNumber
.PagerNumber = citem.PagerNumber
.PersonalHomePage = citem.PersonalHomePage
.PrimaryTelephoneNumber = citem.PrimaryTelephoneNumber
.Profession = citem.Profession
.RadioTelephoneNumber = citem.RadioTelephoneNumber
.ReferredBy = citem.ReferredBy
.SelectedMailingAddress = citem.SelectedMailingAddress
.Sensitivity = citem.Sensitivity
.Spouse = citem.Spouse
.Subject = citem.Subject
.Suffix = citem.Suffix
.TelexNumber = citem.TelexNumber
.Title = citem.Title
.TTYTDDTelephoneNumber = citem.TTYTDDTelephoneNumber
.UnRead = citem.UnRead
.User1 = citem.User1
.User2 = citem.User2
.User3 = citem.User3
.User4 = citem.User4
.UserCertificate = citem.UserCertificate
.WebPage = citem.WebPage
.YomiCompanyName = citem.YomiCompanyName
.YomiFirstName = citem.YomiFirstName
.YomiLastName = citem.YomiLastName

oContact.Move oFolder

oContact.Save

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



'For Each objcontactitem.ContactItem.olContactItem In oContact
With oContact1
' .FullName = citem.FullName
'.HomeAddress = "AdresseSamples"
.Account = citem1.Account
.Anniversary = citem1.Anniversary
.AssistantName = citem1.AssistantName
.AssistantTelephoneNumber = citem1.AssistantTelephoneNumber
.BillingInformation = citem1.BillingInformation
.Birthday = citem1.Birthday
.Body = citem1.Body
.BusinessTelephoneNumber = citem1.BusinessTelephoneNumber
.BusinessFaxNumber = citem1.BusinessFaxNumber
.Business2TelephoneNumber = citem1.Business2TelephoneNumber
.BusinessAddressPostOfficeBox = citem1.BusinessAddressPostOfficeBox
.BusinessAddressState = citem1.BusinessAddressState
.BusinessAddressStreet = citem1.BusinessAddressStreet
.BusinessHomePage = citem1.BusinessHomePage
.CallbackTelephoneNumber = citem1.CallbackTelephoneNumber
.CarTelephoneNumber = citem1.CarTelephoneNumber
.Categories = citem1.Categories
.Children = citem1.Children
.Companies = citem1.Companies
.CompanyName = citem1.CompanyName
.ComputerNetworkName = citem1.ComputerNetworkName
.CustomerID = citem1.CustomerID
.Department = citem1.Department
.Email1Address = citem1.Email1Address
.Email1AddressType = citem1.Email1AddressType
.Email2Address = citem1.Email2Address
.Email2AddressType = citem1.Email2AddressType
.Email3Address = citem1.Email3Address
.Email3AddressType = citem1.Email3AddressType
.FileAs = citem1.FileAs
.FirstName = citem1.FirstName
.FormDescription = citem1.FormDescription
.FTPSite = citem1.FTPSite
.FullName = citem1.FullName
.Gender = citem1.Gender
.GetInspector = citem1.GetInspector
.GovernmentIDNumber = citem1.GovernmentIDNumber
.Hobby = citem1.Hobby
.Home2TelephoneNumber = citem1.Home2TelephoneNumber
.HomeAddress = citem1.HomeAddress
.HomeAddressCity = citem1.HomeAddressCity
.HomeAddressCountry = citem1.HomeAddressCountry
.HomeAddressPostalCode = citem1.HomeAddressPostalCode
.HomeAddressPostOfficeBox = citem1.HomeAddressPostOfficeBox
.HomeAddressState = citem1.HomeAddressState
.HomeAddressStreet = citem1.HomeAddressStreet
.HomeFaxNumber = citem1.HomeFaxNumber
.HomeTelephoneNumber = citem1.HomeTelephoneNumber
.Importance = citem1.Importance
.Initials = citem1.Initials
.InternetFreeBusyAddress = citem1.InternetFreeBusyAddress
.ISDNNumber = citem1.ISDNNumber
.JobTitle = citem1.JobTitle
.Journal = citem1.Journal
.Language = citem1.Language
.LastName = citem1.LastName
.MailingAddress = citem1.MailingAddress
.MailingAddressCity = citem1.MailingAddressCity
.MailingAddressCountry = citem1.MailingAddressCountry
.MailingAddressPostalCode = citem1.MailingAddressPostalCode
.MailingAddressPostOfficeBox = citem1.MailingAddressPostOfficeBox
.MailingAddressState = citem1.MailingAddressState
.MailingAddressStreet = citem1.MailingAddressStreet
.ManagerName = citem1.ManagerName
.MessageClass = citem1.MessageClass
.MiddleName = citem1.MiddleName
.Mileage = citem1.Mileage
.MobileTelephoneNumber = citem1.MobileTelephoneNumber
.NetMeetingAlias = citem1.NetMeetingAlias
.NetMeetingServer = citem1.NetMeetingServer
.NickName = citem1.NickName
.NoAging = citem1.NoAging
.OfficeLocation = citem1.OfficeLocation
.OrganizationalIDNumber = citem1.OrganizationalIDNumber
.OtherAddress = citem1.OtherAddress
.OtherAddressCity = citem1.OtherAddressCity
.OtherAddressCountry = citem1.OtherAddressCountry
.OtherAddressPostalCode = citem1.OtherAddressPostalCode
.OtherAddressPostOfficeBox = citem1.OtherAddressPostOfficeBox
.OtherAddressState = citem1.OtherAddressState
.OtherAddressStreet = citem1.OtherAddressStreet
.OtherFaxNumber = citem1.OtherFaxNumber
.OtherTelephoneNumber = citem1.OtherTelephoneNumber
.PagerNumber = citem1.PagerNumber
.PersonalHomePage = citem1.PersonalHomePage
.PrimaryTelephoneNumber = citem1.PrimaryTelephoneNumber
.Profession = citem1.Profession
.RadioTelephoneNumber = citem1.RadioTelephoneNumber
.ReferredBy = citem1.ReferredBy
.SelectedMailingAddress = citem1.SelectedMailingAddress
.Sensitivity = citem1.Sensitivity
.Spouse = citem1.Spouse
.Subject = citem1.Subject
.Suffix = citem1.Suffix
.TelexNumber = citem1.TelexNumber
.Title = citem1.Title
.TTYTDDTelephoneNumber = citem1.TTYTDDTelephoneNumber
.UnRead = citem1.UnRead
.User1 = citem1.User1
.User2 = citem1.User2
.User3 = citem1.User3
.User4 = citem1.User4
.UserCertificate = citem1.UserCertificate
.WebPage = citem1.WebPage
.YomiCompanyName = citem1.YomiCompanyName
.YomiFirstName = citem1.YomiFirstName
.YomiLastName = citem1.YomiLastName

oContact1.Move oFolder1



oContact1.Save



Set oContact1 = Nothing
Set oFolder1 = Nothing
Set oItems1 = Nothing
Set oOL1 = Nothing
Set oNS1 = Nothing

nombre = nombre + 1


End With



'End If

Next

afic = MsgBox("Ajout de " & nombre & " contacts", vbCritical, "Contacts manager")

End Sub
Questions / Réponses high-tech
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Publicité
Poster une réponse
Anonyme