Récupération des pièces jointes d'outlook en vba

Description

Ce petit programme permet de récuperer les picèes jointes dans des messages Outlook
Il peut travailler à partir de la boite de reception ou un de ses sous dossiers et enregistre les fichiers sur une sortie prédéfine.
Il modifie le nom des fichiers afin d'éviter les écrasements.

Il n'est pas parfait mais fonctionnel.

Ps : C'était mon premier programme !

Source / Exemple :


Dim objoutlook As Outlook.Application
Dim olns As Outlook.NameSpace
Dim mItem As Outlook.MailItem
Dim att As Outlook.Attachment
Dim fld As Outlook.MAPIFolder
Dim Compteur As Integer
Dim message, Repertoire, NomDeFichierSurDisque, NomDeFichier, Taille, Emetteur As String
Option Explicit
Public Sub TransfertPJ()
On Error GoTo errorhandler

'Création de l'objet Outlook
Set objoutlook = CreateObject("Outlook.application")
'Récupération de l'espace de nom d'outlook
Set olns = objoutlook.GetNamespace("MAPI")
'Récupération du répertoire "boite de réception" par défault
Set fld = olns.GetDefaultFolder(olFolderInbox)
' Initialisation du reperetoire de sauvegarde
' ne pas oublier l'anti-slash à la fin du repertoire
Repertoire = "C:\Documents and Settings\ymeunier.E-DMCE\Bureau\En Cours\"
'Inialisation des variables Message, NomDeFichier, NomDeFichierSurDisque, Taille, Emetteur
message = NomDeFichierSurDisque = NomDeFichier = Taille = Emetteur = ""

' Initialisation
Compteur = 0
' Sauve les pieces jointes des mails se trouvant dans la boîte de réception.
' Pour adresser un dossier dans la boite de réception on pourrait utiliser :
' fld.Folders("Nom_Du_Dossier").Items
For Each mItem In fld.Items
    For Each att In mItem.Attachments
        If att.Type = olByValue Then
            Compteur = Compteur + 1
            ' Nom du fichier modifié pour l'enregistrement. Evite les controles superflus en renommant.
            Taille = mItem.Size
            Emetteur = mItem.SenderName
            NomDeFichier = att.FileName
            NomDeFichierSurDisque = "Message de " & Emetteur & " de " & Taille & " octets - " & NomDeFichier
            att.SaveAsFile Repertoire & NomDeFichierSurDisque
            ' affiche différentes informations :
            ' att.index = position du fichier dans le message
            ' att.filename = nom du fichier
            ' mItem.SenderName = Nom de l'émetteur
            ' mItem.Subject = Sujet du message
            ' mItem.Body = Corps du message
            ' mItem.HTMLBody = affiche le le corps du message en HTML - idéal pour récuperer les signatures !
            ' mItem.Size = Donne la taille du message
            ' Message = Message & "Le fichier " & att.FileName & " à été sauvegardé." & Chr(13)
            message = message & "Message de " & Emetteur & " - " & NomDeFichier & " à été sauvegardé." & Chr(13)
            mItem.UnRead = False
            'att.Delete
        End If
    Next
Next

 
' Message du nombre de PJ enregisté
If Compteur > 0 Then
    Information.Label1 = "Il y a eu " & Compteur & " fichiers de copiés."
    Information.TextBox1.Enabled = True
    Information.TextBox1 = message
    Information.Show
End If

Exit Sub

errorhandler:
MsgBox Err.Description, , Err.Source
End Sub

Conclusion :


Il faudrait faire un mix avec une autre source (29427) afin de donner pleine puissance au deux scripts.
Je vais donc m'y atteler.
Les évolutions envisagées :
Possiblité de selection des messages.
Si aucun messages selectionnés possibilité de sélectionner un dossier outlook pour l'archivage de toutes les pièces jointes
Choix du repertoire de destination

Si par contre quelqu'un a une idée pour que cela fonctionne aussi sur les fichiers archives (pst) car je n'ai jamais rein pu trouver dessus !
@+

Codes Sources

A voir également

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.