Supprimer pièce jointe d'un fichier outlook en vbs

bonjour,

Donc voici ce que je souhaiterai faire :

recupérer les pièces jointes de mes message outlook ( Cela je l'effectue deja )
Ensuite je voudrai garder le message dans Outlook tout en supprimer le fichiers joint et en rajoutant un autre fichier qui me dit ou a été sauvegarder mon fichier joint auparavant

Voici mon code :

cpt ="0"
debut = Timer
 
pst = InputBox ("Entrer le nom du fichier de dossiers personnels (pst)" & vbCrLf & _
	"Exemple : Dossiers personnels, Archive, Outlook Connector For Mdaemon", _ 
	"Sélection du dossiers personnels  - Service MCO")
 
dossier_outlook = InputBox ("Entrer le nom du dossier Outlook à extraire les fichiers joints" & vbCrLf & _
	"Exemple : Boîte de réception" & vbCrLf & "Seul les fichiers doc, docx, xls, xlsx, pdf seront extraits ", _ 
	"Sélection du dossier Outlook - Service MCO")
 
sous_dossier_outlook = InputBox ("Entrer le nom du sous-dossier Outlook à extraire les fichiers joints" & vbCrLf & _
	"Exemple : année 2007" & vbCrLf &  vbCrLf & "Si vous n'avez pas de sous-dossier, cliquer sur OK ou ANNULER", _
	"Sélection du sous-dossier Outlook - Service MCO")
 
Target_Folder = InputBox ("Entrer le chemin complet du répertoire de destination (il doit être créé préalablement)" & vbCrLf & "exemple : c:\mailbox\extract\", _
	"Choix du répertoire cible – Service MCO")
 
 
Set oOutLookObject = Createobject("Outlook.Application")
Set objFolder = oOutLookObject.GetNameSpace("MAPI").Folders(pst)
Set objFolder = objFolder.Folders(dossier_outlook)
If Not sous_dossier_outlook = False Then
	If Not sous_dossier_outlook = "" Then
		Set objFolder = objFolder.Folders(sous_dossier_outlook)
	End If
End IF
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objLog = objFSO.CreateTextFile(Target_Folder & dossier_outlook & "_" &  sous_dossier_outlook & "_log.txt")
Set objShell = WScript.CreateObject("WScript.Shell" )
objShell.Run "Net Stop Beep"
 
objLog.WriteLine  "N°de fichier extrait |  Date de  reception | expéditeur  | Sujet du message | nom de la pièce jointe"
objLog.WriteLine  "____________________________________________________________________________________________________"
 
 
For Each objMail In objFolder.Items
    If objMail.attachments.Count >0 Then
	On Error Resume Next
        For i = 1 To objMail.attachments.Count
            	FichierJoint=""
            	Set FichierJoint = objMail.attachments.Item(i)
		TypeFichier = Split(FichierJoint.DisplayName,".")(1)
 
 
			If TypeFichier = "doc" Or TypeFichier = "pdf" Or TypeFichier = "xls" Or TypeFichier = "docx" Or TypeFichier = "xlsx" Then
				expediteur = Split(objMail.SenderName,"@")(0)
				mois = Split(Split(objMail.ReceivedTime," ")(0),"/")(1)
				annee = Split(Split(objMail.ReceivedTime," ")(0),"/")(2)
				FichierExtrait = annee & mois &"_"& expediteur &"_"& FichierJoint.DisplayName
            			FichierJoint.SaveAsFile Target_Folder & FichierExtrait
				objLog.WriteLine  cpt & " | " & objMail.ReceivedTime & " | " & objMail.SenderName & " | " & objMail.Subject & " | " & FichierJoint.DisplayName
				cpt = cpt + 1
 
				objMail.Delete()
 
			End If
	Next
 
    End If
Next
 
If cpt > 0 Then 
Fin = Timer
Duree = (Fix(Fin))-(Fix(Debut))
	MsgBox "Les fichiers joints ont été extrait" & vbCrLf & _
		"Merci de Consulter le fichier " & vbCrLf & _ 
		Target_Folder & dossier_outlook & "_" &  sous_dossier_outlook & "_log.txt" & vbCrLf &_
		"Et de supprimer les messages concernés dans votre messagerie." & vbCrLf & _
		"Durée d'exécution du script : " & Duree & " secondes" _ 
		, vbOKOnly + vbInformation, "Extraction terminée - Service MCO"
End If

Donc ici je sauvegarde la piece joint en la renomant et j'arrive a supprime le mail, mais je voudrai garder donc juste le corp du message

Merci d'avance