VBA Outlook transférer mail dans un autre dossier

Bonjour à tous,

aujourd'hui j'ai le code suivant qui fonctionne très bien:

Option Explicit
'------------------------------------------------------------------------
'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library
'------------------------------------------------------------------------
Sub ExportePiecesJointes()
Dim Ol As New Outlook.Application
Dim Ns As Outlook.Namespace
Dim Dossier As Outlook.MAPIFolder

Set Ns = Ol.GetNamespace("MAPI")
Set Dossier = Ns.Folders(1)

SearchFolders Dossier
End Sub

Private Sub SearchFolders(ByVal Fld As Outlook.MAPIFolder)
Dim y As Integer
Dim OLmail As Outlook.MailItem
Dim pceJointe As Outlook.Attachment
Dim SousDossier As Outlook.MAPIFolder
Dim S_Commande As Worksheet
Dim Chemin As String

Set S_Commande = ThisWorkbook.Sheets("Commande")
Chemin = S_Commande.Cells(3, 2).Value

For Each SousDossier In Fld.Folders
If SousDossier.DefaultItemType = 0 And SousDossier = "Test" Then
y = 1
For Each OLmail In SousDossier.Items

Set pceJointe = OLmail.Attachments(y)
pceJointe.SaveAsFile Chemin & y & "_" & pceJointe
y = y + 1
Set pceJointe = Nothing
Next OLmail
End If
SearchFolders SousDossier
Next SousDossier
End Sub

Il me permet de prendre toutes les pièces jointes des mails situés dans le dossier Test, et de les télécharger pour les envoyer dans un dossier de mon bureau renseigné dans la variable chemin. J'aimerais modifier ce code ou l'améliorer.

Ce que je souhaiterais faire, c'est ajouter une ligne de code, (à mon avis au dessus de "y = y + 1") qui me permettrait juste après le téléchargement de la pièce jointe, de transférer le mail contenant cette pièce jointe dans un autre dossier Outlook nommé Test2. Lorsque je dis "ajouter une ligne de code", ça peut être plus, mais je pense que c'est pas trop compliqué, bien que je ne sache pas comment m'y prendre. Une idée ?

Bonne journée les amis !

SkillzZ

Bonjour,

à tester, en espèrent que vous pourrai l'intégrer à votre code,

Sub Deplacer_Message()
Dim myOlApp As Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myFolder As Outlook.MAPIFolder
Dim myFolderArchive As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myFolderArchive = myFolder.Parent.Folders("Perso")
myFolder.Items(1).Move myFolderArchive
End Sub

Bonjour SabV merci beaucoup pour ta réponse. Malheureusement j'ai vu ce style de code sur internet et je n'ai pas réussi à l'intégrer. En fait la structure de mon code initiale est peut-être à changer. Dans le code que tu me proposes, suis-je censé remplacer "perso" par le nom du dossier où je veux envoyer mes mails ? Par ailleurs, je ne comprends pas le "items(1)" que signifie le (1) ?

Merci en tout cas pour ta réponse, je galère sur on souci depuis maintenant une semaine et je n'ai pas trouvé la solution.

Bonne journée !

SkillzZ

Bonjour,

Voulez-vous transférer le mail dans un sous-dossier de Dossier

c'est à dire un sous dossier de Ns.Folders(1) ?