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