Outlook - script pour enregistrer les pièces jointes des mails contenus dans les

Question

Bonjour,

J'ai repris ce script et je l'ai modifié en fonction de mes besoins. Il permet bien d'extraire les pièces jointes des mails et de les enregistrer dans un dossier précédemment crée. En plus de cela il tient à jour un journal de logs correspondants.

Mon problème : ce script n'extrait que les pièces jointes du dossier principal de Outlook (Inbox ou boîte de réception) et ignore totalement ses sous-dossiers si on laisse le champ sous_dossier_outlook vide. 

J'aimerais savoir comment l'adapter pour qu'il effectue l'extraction des pièces jointes à partir du dossier principal ainsi que TOUS les sous-dossiers, dès lors qu'on laisse le champ sous_dossier_outlook vide, et ce quel que soit leur chemin d'accès du moment qu'ils se situent dans le dossier principal d'Outlook. Existe-t-il une variable spécifique pour cela ? Si oui comment l'utiliser correctement dans mon cas de figure?

Merci d'avance si vous pouvez m'aider.

-----------------------------------------------------------------------------------------------------------------------------------------------
cpt ="0"
debut = Timer

ost = InputBox ("Entrer le nom du fichier de dossiers personnels (ost ou pst)" & vbCrLf & _
    "Exemple : Boîte aux lettres - Chuck Norris", _
    "Sélection du dossier personnel" )

dossier_outlook = InputBox ("Entrer le nom du dossier Outlook à extraire les fichiers joints" & vbCrLf & _
    "Exemple : Inbox" & vbCrLf & "Attention, tous les fichiers seront extraits.", _
    "Sélection du dossier Outlook" )

sous_dossier_outlook = InputBox ("Entrer le nom du sous-dossier Outlook à extraire les fichiers joints" & vbCrLf & _
    "Exemple : Server monitoring" & vbCrLf &  vbCrLf & "Si vous n'avez pas de sous-dossier, cliquer sur OK ou ANNULER", _
    "Sélection du sous-dossier Outlook" )

Target_Folder = InputBox ("Entrer le chemin complet du répertoire de destination en respectant la syntaxe de l'exemple (il doit être créé préalablement)" & vbCrLf & "exemple : c:\Pièces jointes", _
    "Choix du répertoire cible" )

Set oOutLookObject = Createobject("Outlook.Application" )
Set objFolder = oOutLookObject.GetNameSpace("MAPI" ).Folders(ost)
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"  Or TypeFichier = "rar" Then
             
                expediteur = Split(objMail.SenderName,"@" )(0)
                jour = Split(Split(objMail.ReceivedTime," " )(0),"/" )(0)
                mois = Split(Split(objMail.ReceivedTime," " )(0),"/" )(1)
                annee = Split(Split(objMail.ReceivedTime," " )(0),"/" )(2)
                
                
                FichierExtrait = annee &"-"& mois &"-"& jour &"_"& 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 "L'extraction s'est correctement achevée." & vbCrLf & _
        "Merci de consulter le fichier : " & vbCrLf & _
        Target_Folder & dossier_outlook & "_" &  sous_dossier_outlook & "_log.txt" & vbCrLf &_
        "Si vous désirez obtenir des informations supplémentaires." & vbCrLf & _
        "Durée d'exécution du script : " & Duree & " secondes" _
        , vbOKOnly + vbInformation, "Fin du programme."
End If

cs_loulou69 · Answer

Bonjour, Welcome

Essaye quelque chose comme cela

For Each sous_dossier_outlook In dossier_outlook 

' debut existant dans ton code ci-dessus
For Each objMail In objFolder.Items
.....
Next 
if Cpt>0 then

end if
' fin existant dans ton code ci-dessus
Next sous_dossier_outlook 


Tu peux aussi t'inspirer du code ici, je ne t'assures pas que cela fonctionne
http://www.vbaexpress.com/forum/showthread.php?p=175546#post175546

Outlook - script pour enregistrer les pièces jointes des mails contenus dans les

1 réponse

Votre réponse

Discussions similaires