Bonjour

Je souhaite supprimer tous les contacts d'une boîte aux lettres par automation depuis ACCESS.

J'ai fait le code suivant mais à chaque fois il ne me supprime que la moitié des contacts...je bloque! A l'aide Merci

__________________________________________

Sub DeleteOutlookContact()
On Error GoTo Err_DeleteOutlookContact

   Dim myOlApp As New Outlook.Application
   Dim myNameSpace As NameSpace
   Dim myFolder, mySubFolder, myContactFolder As MAPIFolder
   Dim myContact As Outlook.ContactItem
   Dim myContactSelected As Outlook.ContactItem
   Dim myContactItems As Outlook.Items
    Dim nb As Integer

   Set myOlApp = CreateObject("Outlook.Application")
   Set myNameSpace = myOlApp.GetNamespace("MAPI")
   Set myFolder = myNameSpace.Folders("Dossiers publics")
   Set mySubFolder = myFolder.Folders("Tous les dossiers publics")
   Set myContactFolder = mySubFolder.Folders("COOPANNU")
   Set myContactItems = myContactFolder.Items
      
   nb = myContactFolder.Items.Count
    If nb > 0 Then
        For Each myContact In myContactItems
            myContact.Delete
        Next myContact
        MsgBox "Il y a " & nb & " Contacts supprimés"
    Else
        MsgBox "Aucun Contact à supprimer"
    End If
   
    Set myOlApp = Nothing
   Set myNameSpace = Nothing
   Set myFolder = Nothing
   Set mySubFolder = Nothing
   Set myContactFolder = Nothing
   Set myContactItems = Nothing
    Set myContact = Nothing

Exit_DeleteOutlookContact:
Exit Sub

Err_DeleteOutlookContact:
    MsgBox Err.Description
    Resume Exit_DeleteOutlookContact

End Sub