Déplacement de Mail via VBA

Bonsoir à tous,

Dans le cadre d'une macro je fais appel à cette procédure, qui pose problème. En effet elle fonctionne très bien.... une seule fois.

Au mail suivant j'ai une erreur me disant que le "Le dossier de destination n'a pas été trouvé".

Si je ferme Outlook et que je le relance, ça fonctionne de nouveau : une fois.

Pouvez-vous m'aider à comprendre ce qu'il se passe et où je me trompe ?

Précisions : Lorsque je lance la macro (via bouton personnalisé dans le ruban) je suis déjà dans la "Boîte de réception" de la boite mail "Postuler", je dois "juste" déplacer mon email dans le sous-dossier "CV.Traites.Outil", sous dossier déjà existant de ma "Boîte de réception".

' Fonction pour trouver un dossier récursivement
Function TrouverDossier(parentFolder As Outlook.MAPIFolder, folderName As String) As Outlook.MAPIFolder
    Dim subFolder As Outlook.MAPIFolder
    For Each subFolder In parentFolder.Folders
        If UCase(subFolder.Name) = UCase(folderName) Then
            Set TrouverDossier = subFolder
            Exit Function
        End If
        Dim foundFolder As Outlook.MAPIFolder
        Set foundFolder = TrouverDossier(subFolder, folderName)
        If Not foundFolder Is Nothing Then
            Set TrouverDossier = foundFolder
            Exit Function
        End If
    Next subFolder
End Function

Sub DéplacerMailBXL()
    Dim objNS As Outlook.Namespace
    Dim objInbox As Outlook.MAPIFolder
    Dim objDestFolder As Outlook.MAPIFolder
    Dim objItem As Object

    Set objNS = Application.GetNamespace("MAPI")
    Set objInbox = objNS.Folders("Postuler").Folders("Boîte de réception")

    Dim folder As Outlook.MAPIFolder
    For Each folder In objInbox.Folders
        Debug.Print folder.Name
    Next folder

    Dim destFolderName As String
    destFolderName = "CV.Traites.Outil"

    On Error Resume Next
    Set objDestFolder = TrouverDossier(objInbox, destFolderName)
    On Error GoTo 0

    If Not objDestFolder Is Nothing Then
        Debug.Print "Dossier de destination trouvé : " & objDestFolder.Name
    Else
        Debug.Print "Dossier de destination non trouvé."
    End If

    ' Vérifiez si le dossier de destination existe
    If objDestFolder Is Nothing Then
        MsgBox "Le dossier de destination n'a pas été trouvé.", vbExclamation
        Exit Sub
    End If

    ' Obtenez l'élément actuellement sélectionné (le courriel en cours)
    Set objItem = Application.ActiveExplorer.Selection(1)

    ' Vérifiez si un élément est sélectionné
    If objItem Is Nothing Then
        MsgBox "Aucun élément sélectionné.", vbExclamation
        Exit Sub
    End If

    ' Déplacez l'élément vers le dossier de destination
    objItem.Move objDestFolder

    ' Libérez les objets
    Set objItem = Nothing
    Set objDestFolder = Nothing
    Set objInbox = Nothing
    Set objNS = Nothing

End Sub

Et le résultat de mon debug

premier lancement = ok

D. Contactés

CV.Traites.Outil

Cas à éviter

C. Archives

B. Non retenus

A. Retenus

Dossier de destination trouvé : CV.Traites.Outil

deuxième fois : nok :

Dossier de destination non trouvé.

Merci d'avance pour votre aide, car je ne parviens pas à me sortir de ce faux pas.

Bonne soirée

Lorence

j'ai cette version-ci, plus light, qui me fait la même chose

Sub DéplacerMailBXL()

    Dim OutlookApp As Outlook.Application
    Dim Namespace As Outlook.Namespace
    Dim Inbox As Outlook.MAPIFolder
    Dim Email As Object
    Dim DestFolder As Outlook.MAPIFolder

    ' Créer une instance d'Outlook
    Set OutlookApp = New Outlook.Application
    ' Accéder à l'espace de noms Outlook (profil par défaut)
    Set Namespace = OutlookApp.GetNamespace("MAPI")

    ' Accéder à la boîte "Candidat Maison-Net"
    On Error Resume Next
    Set Inbox = Namespace.Folders("Postuler").Folders("Boîte de réception")
    On Error GoTo 0

    ' Vérifier si la boîte a été trouvée
    If Inbox Is Nothing Then
        MsgBox "La boîte aux lettres 'Postuler' ou le dossier 'Boite de réception' n'a pas été trouvé.", vbExclamation
        Exit Sub
    End If

    ' Modifier le chemin du dossier de destination
    ' Si le sous-dossier "CV.Traites.Outil" n'existe pas, il sera créé

    Set DestFolder = Inbox.Folders("CV.Traites.Outil")
    ' Sélectionner l'e-mail actuellement ouvert ou sélectionné
    Set Email = OutlookApp.ActiveExplorer.Selection(1)

    ' Déplacer l'e-mail vers le dossier de destination
    Email.Move DestFolder

    ' Libérer les objets
    Set Email = Nothing
    Set DestFolder = Nothing
    Set Inbox = Nothing
    Set Namespace = Nothing
    Set OutlookApp = Nothing
End Sub

qui fonctionne impec la première fois, puis me renvoie une erreur sur le mail suivant à la ligne

Set DestFolder = Inbox.Folders("CV.Traites.Outil") - Impossible de trouver un objet

Donc à la première utilisation tout est ok, et ensuite ça ne fonctionne plus. Pourtant je libère la mémoire, je ne comprend pas ...

Bonjour,

Je n'ai pas testé votre code, mais vous avez instancié la variable Inbox pour votre répertoire source, pourquoi n'est-elle pas utilisée pour instancier votre variable Email ?

Comment faites-vous, s'il n'y a qu'un mail dans la boite ?

Bonjour,

J'ai pu trouver ma solution. Si une personne attérit un jour sur ce fil :

Si votre boite mail est une boite partagée et que vous souhaitez y déplacer un email automatiquement, créez le dossier qui doit recevoir vos mails au même "niveau" que votre boite de réception et reprenez cette procédure y compris les 2 fonctions qui lui sont nécessaires :

Sub DéplacerMail()

     Dim OutlookApp As Outlook.Application
    Dim Namespace As Outlook.Namespace
    Dim Mailbox As Outlook.MAPIFolder
    Dim Email As Object
    Dim DestFolder As Outlook.MAPIFolder

    ' Créer une instance d'Outlook
    Set OutlookApp = New Outlook.Application
    ' Accéder à l'espace de noms Outlook (profil par défaut)
    Set Namespace = OutlookApp.GetNamespace("MAPI")

    ' Accéder à la boîte mail
    'On Error Resume Next
    Set Mailbox = Namespace.Folders("votre boite aux lettres")  'indiquez ici le nom de votre compte mail
    'On Error GoTo 0

    ' Vérifier si la boîte a été trouvée
    If Mailbox Is Nothing Then
        MsgBox "La boîte aux lettres 'votre boite aux lettres' n'a pas été trouvée.", vbExclamation 'indiquez ici le nom de votre compte mail
         Exit Sub
    End If

    ' Modifier le chemin du dossier de destination
    ' Si le dossier n'existe pas, il sera créé
    Set DestFolder = GetFolder(Mailbox, "mon dossier") 'Indiquez ici le nom de votre dossier de destination
    End If

    ' Vérifier si le dossier de destination a été trouvé
    If DestFolder Is Nothing Then
        ' Créer le dossier s'il n'existe pas
        Set DestFolder = Mailbox.Folders.Add("mon dossier") 'Indiquez ici le nom de votre dossier de destination
    End If

    ' Sélectionner l'e-mail actuellement ouvert ou sélectionné
    Set Email = OutlookApp.ActiveExplorer.Selection(1)

    ' Déplacer l'e-mail vers le dossier de destination
    Email.Move DestFolder

    ' Libérer les objets
    Set Email = Nothing
    Set DestFolder = Nothing
    Set Mailbox = Nothing
    Set Namespace = Nothing
    Set OutlookApp = Nothing

End Sub

Function GetInboxFolder(parentFolder As Outlook.MAPIFolder, folderName As String) As Outlook.MAPIFolder
    Dim folder As Outlook.MAPIFolder

    For Each folder In parentFolder.Folders
        If folder.Name = folderName Then
            Set GetInboxFolder = folder
            Exit Function
        ElseIf folder.Folders.Count > 0 Then
            ' Recherche récursive dans les sous-dossiers
            Set GetInboxFolder = GetInboxFolder(folder, folderName)
            If Not GetInboxFolder Is Nothing Then Exit Function
        End If
    Next folder
End Function

Function GetFolder(parentFolder As Outlook.MAPIFolder, folderName As String) As Outlook.MAPIFolder
    Dim folder As Outlook.MAPIFolder

    On Error Resume Next
    Set folder = parentFolder.Folders(folderName)
    On Error GoTo 0

    Set GetFolder = folder
End Function

Bonne journée