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 !
@+
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.