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