Enregistrer toutes les pièces jointes d'une BAL outlook dans un dossier spécifié

Question

Bonjour,

tout est dans le titre : je cherche un script .vbs qui permettrait de récupérer toutes les pièces jointes contenues dans la boite de réception d'Outlook et de les enregistrer dans un dossier spécifié. Ce script devrait fonctionner sans l'utilisation de règles ou de macros sous Outlook, il doit être parfaitement indépendant. 

J'ai trouvé quelques pistes sur ce forum mais aucune n'a fonctionné et je suis un peu perdu dans ce langage qui est tout récent pour moi.

Je vous remercie à l'avance pour vos réponses.

Nosunwillshine · Answer

Désolé pour le double post.
J'ai finalement trouvé un script qui fonctionne mais je souhaiterais le modifier.
D'une part j'aimerais savoir si il existe une commande permettant de faire en sorte que le dossier source de Outlook n'ait pas à être renseigné, c'est à dire que le script aille chercher dans le dossier Inbox par défaut et ce quel que soit l'utilisateur.
D'autre part, il serait pratique qu'il ne supprime pas les mails dans la boite de réception.

Le reste (le fichier de log, l'affichage de la durée de l'opération) me convient parfaitement.

Merci de me donner quelques idées à défaut de construire le script à ma place. Je préfèrerais comprendre et apprendre.

Merci

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" Or TypeFichier = "txt" 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

cs_loulou69 · Answer

pour éviter la suppression des mail
mettre en commentaire ou supprimer la ligne

  objMail.Delete()

cs_loulou69 · Answer

remplacer 
pst=InputBox
par 
pst="Boite de reception"

supprimer les lignes de
dossier_output = InputBox (...
à 
sous_dossier_output= InputBox

et remplacer  les lignes

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

par 
Set oOutLookObject = Createobject("Outlook.Application" )
Set objFolder = oOutLookObject.GetNameSpace("MAPI" ).Folders("Inbox")  ' ou laisser la variable pst

Nosunwillshine · Answer

Bonjour et merci pour vos réponses loulou69.

Cependant j'ai un nouveau souci, en modifiant le code comme vous me l'avez indiqué, la récupération des pièces jointes ne fonctionne plus, ainsi que le message à la fin indiquant l'état et la durée de l'opération.

Pire encore, en revenant à l'ancien code, cela ne fonctionne plus non plus ... je reste donc dubitatif ...
Aurais-je commis une erreur en transposant le code original ou alors cela serait-ce quelque chose de probable avec les scripts .vbs?

Concernant : 

remplacer 
pst=InputBox
par 
pst="Boite de reception"

Faut-il que j'écrive mot pour mot Boite de réception, ou alors faut-il que j'indique son chemin d'accès?

Merci pour votre aide.

cs_loulou69 · Answer

Excuses "Boîte de recéption" c'est pour la version française de Outlook , c'est "Inbox" pour la version anglaise je suppose

Nosunwillshine · Answer

Bonjour,

après modifications, le script ne fonctionne toujours pas, il y a un message d'erreur que voici :

Line: 	12
Column:	1
Error:	Impossible d'exécuter l'opération. Impossible de trouver un objet.
Code:   8004010F
Source: Microsoft Office Outlook

Et voilà le script modifié :

cpt ="0"
debut = Timer

pst = "Inbox"


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("Inbox")  ' ou laisser la variable pst

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" Or TypeFichier = "txt" 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


Selon le message d'erreur, il y aurait donc un élément manquant ayant un rapport avec cette ligne 12. Lequel? j'aimerais bien le savoir. Si quelqu'un a des idées, je le remercie à l'avance de nous les faire partager.

Nosunwillshine · Answer

Oula, petit problème de mise en page sur mon dernier message (ça serait cool qu'il soit effacé) et désolé pour le double post.

Donc d'après le message d'erreur que voici : 

Line:   12 
Column:	1 
Error:	Impossible d'exécuter l'opération. Impossible de trouver un objet. 
Code:   8004010F Source: Microsoft Office Outlook


Il y a un souci lié à la ligne 12 dans mon code.

Voilà le code après modifications :


cpt ="0"
debut = Timer

pst = "Inbox"


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("Inbox")  ' ou laisser la variable pst

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" Or TypeFichier = "txt" 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



J'aimerais savoir si quelqu'un sait ce qu'il faudrait modifier, ajouter ou retirer pour que ça fonctionne enfin correctement. Merci.

Nosunwillshine · Answer

J'étais en cours et donc j'ai pas eu le temps de continuer depuis. Mais là je vais devoir m'y remettre.
Si je réussis je publierai le script ici. En attendant, je ne refuse pas un petit peu d'aide. Merci.

Enregistrer toutes les pièces jointes d'une BAL outlook dans un dossier spécifié

8 réponses

Votre réponse

Discussions similaires