Extraire les pièces jointes d’Outlook en VBA
Dans Outlook (pas Express), j’ai des e-mails avec pièces jointes. Comment extraire toutes ces pièces jointes automatiquement, en VBA, dans un dossier du disque dur ?
Mise en place
Le code qui va suivre utilise lui-même d’autres portions de VBA publiées sur ce blog, portions que vous devez aussi intégrer à votre base de données. Reportez-vous à ces articles :
D’autre part, votre projet VBA doit référencer la bibliothèque « Microsoft Outlook x.y Object Library » (x.y
étant votre version d’Outlook, par exemple 12.0
). Pour plus de détails sur les références, consultez cet article du blog.
Le code
Voici 2 procédures VBA à recopier intégralement dans un module standard de votre base de données.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
' --- ' EXTRACTION DE PIECES JOINTES OUTLOOK ' --- ' Sub SaveAttachments( _ ByVal strTargetFolder As String, _ Optional ByVal blnIncludeSubFolders As Boolean = False) ' Quelques variables... Dim olApp As Outlook.Application Dim ns As Outlook.NameSpace Dim fld As Outlook.MAPIFolder ' Vérifier si le dossier de destination existe bien If Dir(strTargetFolder, vbDirectory) = "" Then MsgBox "Le dossier destination n'existe pas !", vbExclamation Exit Sub End If strTargetFolder = AddBackslash(strTargetFolder) ' Démarrer Outlook Set olApp = New Outlook.Application ' Pointer sur la boîte de réception Set ns = olApp.GetNamespace("MAPI") Set fld = ns.GetDefaultFolder(olFolderInbox) ' Extraire tous les messages du dossier SaveFolderAttachments fld, strTargetFolder, blnIncludeSubFolders Set fld = Nothing Set ns = Nothing olApp.Quit Set olApp = Nothing End Sub ' --- ' EXTRACTION DES PIECES JOINTES D'UN DOSSIER ' --- ' Sub SaveFolderAttachments( _ fld As Outlook.MAPIFolder, _ strTargetFolder As String, _ Optional ByVal blnIncludeSubFolders As Boolean = False) Dim mi As Outlook.MailItem Dim att As Outlook.Attachment Dim strFile As String ' Debug Debug.Print "---" Debug.Print "DOSSIER : " & fld.Name Debug.Print "---" ' Parcourir tous les messages For Each mi In fld.Items If mi.Attachments.Count > 0 Then ' Pour info... Debug.Print mi.Subject For Each att In mi.Attachments strFile = FilenameInc(strTargetFolder & att.Filename) ' Sauvegarder la pièce jointe sous son nom original ' ou avec un nom incrémenté en cas de doublons att.SaveAsFile strFile Debug.Print " -> " & strFile Next End If Next ' Si nécessaire, effectuer le même traitement ' sur les sous-dossiers If blnIncludeSubFolders Then Dim subfld As Outlook.MAPIFolder For Each subfld In fld.Folders SaveFolderAttachments subfld, strTargetFolder, blnIncludeSubFolders Next End If End Sub |
Tester le code
En principe, vous appelez la 1ère des deux procédures de cette manière :
- Ouvrez la fenêtre Exécution (
CTRL
+G
). - Tapez :
SaveAttachments "C:undossierexistantquelconque"
puis[Entrée]
.
Toutes les pièces jointes de messages situés dans la boîte de réception seront alors extraites dans le dossier souhaité (s’il existe, bien sûr).
- Si deux messages (ou plus) contiennent une pièce jointe de même nom, ces pièces jointes seront toutes sauvées et numérotées différemment. Par exemple :
photo.jpg
,photo-00001.jpg
,photo-00002.jpg
, etc. C’est la fonctionFilenameInc()
traitée dans cet article qui prend en charge la numérotation. - La fenêtre Exécution affiche quelques informations utiles (sujet du message, chemin de la pièce jointe sauvegardée).
Variante
Si votre boîte de réception contient des sous-dossiers, ceux-ci ne sont pas traités par défaut. Si vous souhaitez que tous les sous-dossiers de votre boîte de réception soient parcourus, écrivez plutôt :
SaveAttachments "C:undossierexistantquelconque", True
Le second paramètre indique qu’il faut parcourir les sous-dossiers de façon récursive.
Bonjour,
pourriez-vous m’indiquer la modification de script à effectuer pour ajouter la date du jour au nom des fichiers copiés ? Par exemple : France_ventes_20160210.txt, Allemagne_ventes_20160210.txt, etc.
Ainsi les fichiers du jour ne viennent pas effacer ceux de la veille.
Merci d’avance !
A vue de nez, il faudrait remplacer la ligne :
strFile = FilenameInc(strTargetFolder & att.Filename)
par quelque chose comme :
strFile = Format(Now(), "yyyymmdd") & "_" & att.Filename
J’ai placé la date plutôt devant, pour simplifier la gestion de l’extension. En adaptant un peu, on peut placer la date avant l’extension.
Bonjour ,
Bien intéressé aussi par ce prog , je cherche (en vain ..) à faire fonctionner…
Problème :
Le prog se fige sur la fonction « Function FilenameInc(ByVal strFile As String) As String » avec FilePath de « FilePath(strFile) » selectionné !
Le message d’erreur est ‘Erreur de compilation , Sub ou Function non définie »
Qu’en pensez-vous ?
Merci. par avance.
FilePath(strFile)
La fonction
FilenameInc()
nécessite d’autres fonctions en amont (l’article correspondant donne les liens). A priori, ça doit venir de là… 😉Bonjour,
Je voudrais savoir si il y a une possibilité d’insérer une règle d’exception dans l’extraction. je souhaite extraire les pièces jointe de tous les mails sauf ceux qui finissent par « group.com »
Merci d’avance pour votre aide
A priori, ça devrait être possible : dans la procédure
SaveFolderAttachments
,mi
est un objet de typeMailItem
. Il y a donc moyen d’obtenir l’émetteur ou le(s) destinaire(s), et de rajouter unIf
pour tester si la règle est respectée ou non. A affiner, je n’ai pas eu le temps de tester. 😉Merci pour votre réponse!
est-il possible d’avoir le code à implémenter dans la macro ? je ne suis très doué sur VBA
Merci d’avance pour votre retour
Je n’ai malheureusement pas assez de temps ces jours-ci. 🙁
Mais j’ai noté l’idée pour un prochain article.
Si un autre visiteur est inspiré…
Bonjour,
Simplement pour vous informer que les liens proposés vers les autres portions de VBA nécessaires au bon fonctionnement du code proposé sont obsolètes ce qui est bien dommage. Cela est égalemeent le cas pour d’autre pages de ce site.
Bien cordialemeent
Merci pour le retour. Effectivement, suite à la migration récente du site, certains liens ont été avalés. 🙁 J’en ai traité un très grand nombre en automatique, mais certains sont passés à la trappe. Je rectifie dès que j’ai plus de temps. 😉
anthooooony > En fait, ce n’est ni un problème Access, ni un problème Excel : c’est un truc à faire dans Outlook uniquement. Il faudrait sans doute que tu appelles la macro dans l’événement
NewMail
de Outlook (cet événement se déclenche à chaque réception de message).Bonjour,
Je cherche depuis pret de deux semaines un moyen de lancer une macro en l’occurence celle présente ci dessous à la reception d’un nouvel email d’un expéditeur précis.
J’ai crée une regle pour que lorsque je recois un email(destinataire précis) avec une piece jointe elle aille dans un dossier bien précis
ensuite j’ai une macro que lorsque je la lance mets toutes les pieces jointes du dossier dans un endroit du disque dur
mais je cherche un moyen de mettre en relation la regle à la macro.
En faite, de qu’imaginons l’utilisateur anthooooony@hotmail.com envoie un email avec une piece jointe que la macro se lance et enregistrer les pieces jointes dans mon dd.
C’est dommage que nous puissions pas le faire nativement à partir d’excel au lieu de faire des regles puis des macros grr
merci en de votre aide
anthooooony
ewen > Comme il est indiqué en début d’article, il faut recopier dans un module d’autres fonctions publiées sur le blog, notamment la fonction
AddBackSlash()
. Le lien figure en début d’article.Bonjour
Ce code me pose quelque problème. Bien entendus mon projet VBA référence la bibliothèque « Microsoft Outlook 11.0 Object Library ».
Mais apres quand j’execute le code cette fonction n’est pas définie :AddBackslash???
Merci
pauline > Ça marche effectivement comme ça. On pourrait utiliser une variante à la place de
Parent
, mais le principe est là.Content que tu aies pu trouver de ton côté. Bon dev’ !
En fait c’est bon j’ai réussi, il faut rajouter après:
> Set ns = olApp.GetNamespace(« MAPI »)
Set fld = ns.GetDefaultFolder(olFolderInbox)
> Set myFolder = fld.Parent.Folders(nomdossier)
et remplacer SaveFolderAttachments fld, strTargetFolder, blnIncludeSubFolders
par : SaveFolderAttachments myFolder, strTargetFolder, blnIncludeSubFolders
et dans la déclaration de variable ne pas oublier > Dim myFolder As Outlook.MAPIFolder
et on vide la variable à la fin : Set myFolder = Nothing
J’utilise une variable nomdossier pour pouvoir réutiliser ma fonction, mais en mettant le nom de dossier entre « » ça marche aussi.
Je ne sais pas si cette façon de faire est la plus pratique mais ça marche.
Merci encore pour tout.
Bonjour,
Non se serait pour un dossier au même niveau que la boîte de réception dans la boîte aux lettres, il s’appelle ARCHIVES_LDD, j’ai essayé la méthode avec le sous-dossier, le problème c’est qu’il pointe directement vers la boîte de réception alors que moi je voudrais me mettre sur un autre dossier.
J’espère que j’ai été claire.
Merci beaucoup.
pauline > Quel dossier par exemple ?
Pour un sous-dossier de la boîte de réception, ma réponse donnée à matt peut convenir.
Bonjour,
Merci beaucoup pour ce code, je voudrais savoir quels modifications apporter si je veux pointer non pas sur la boîte de réception mais sur un autre dossier de la boite aux lettres.
Merci beaucoup
matt > Pour cibler un sous-dossier de la boîte de réception, il faut remplacer la ligne :
Par :
où
xyz
est le nom d’un sous-dossier.L’idéal serait d’aménager la procédure
SaveAttachments
pour qu’elle gère ça systématiquement.Bonjour,
quel modification à apporter si on cible directement un sous dossier de la boite de réception et non l’intégralité des mails ?
Merci
Patrick_Oise > Le principe consiste à copier la pièce jointe vers le disque, puis à la supprimer. La méthode
Delete
de la classeAttachment
devrait faire l’affaire. Il faudrait rajouter :après la ligne :
Bonjour,
Cà marche à la perfection bravo mais j’ai une question :
Quelles modifications à apporter au code si je veux « extraire » et non seulement « copier » les fichiers ??
Merci pour votre réponse