Extraction pièces jointes Outlook via VBA

Version imprimable

Bonjour,
J'ai récupéré un code sur ce site pour extraire automatiquement les pièces jointes Outlook via VBA. ça marche bien, mais j'ai un problème parce qu'il parcourt à chaque fois tous les dossiers de ma boite mail, alors que je ne voudraise récupérer que le spieces jointes de mon dossier "Test".
1) Pourriez vous me dire SVP comment modifier leprogramme ci-dessous pour spécifier un seul dossier d'extraction.
2) Est ce qu'on pourrait aussi spécifier les adresses qu'il doit regarder. Autrement dit, forcer le programme à extraire seulement le spieces jointes des adresses qu'on lui donnera.

D'avance merci.

Code:

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
Option Explicit
'------------------------------------------------------------------------
'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library
'------------------------------------------------------------------------
 
 
Dim x As Integer
    'La boite de réception, la boite des éléments supprimés et tous leurs
    'sous dossiers sont pris en compte.
Sub ExportePiecesJointes()
    Dim Ol As New Outlook.Application
    Dim Ns As Outlook.Namespace
    Dim Dossier As Outlook.MAPIFolder
 
    Set Ns = Ol.GetNamespace("MAPI")
    Set Dossier = Ns.Folders(1)
 
    SearchFolders Dossier
    x = 0
End Sub
 
 
Private Sub SearchFolders(ByVal fld As Outlook.MAPIFolder)
Dim y As Integer
Dim OLmail 'As Outlook.MailItem
Dim pceJointe As Outlook.Attachment
Dim SousDossier As Outlook.MAPIFolder
 
For Each SousDossier In fld.Folders
'.Item("Nom_Du_Dossier").Items
    If SousDossier.DefaultItemType = 0 Then
        For Each OLmail In SousDossier.Items
            If Not OLmail.Attachments.Count = 0 Then
                For y = 1 To OLmail.Attachments.Count
                     Set pceJointe = OLmail.Attachments(y)
                     x = x + 1
                     pceJointe.SaveAsFile "C:\PJ\" & x & "_" & pceJointe
                    Set pceJointe = Nothing
                Next y
            End If
        Next OLmail
    End If
    SearchFolders SousDossier
Next SousDossier
End Sub

bonjour

dans cet exemple, le dossier "Test" est supposé etre un sous repertoire de la boite de réception:

Code:

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
Option Explicit
Option Compare Text
 
 
Sub Essai()
    Extraction "Test", "mimi@provider.fr"
End Sub
 
 
Sub Extraction(NomDossier As String, Expediteur As String)
    Dim olApp As Outlook.Application
    Dim olSpace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olInbox As Outlook.MAPIFolder
    Dim olmail As Outlook.MailItem
    Dim pceJointe As Outlook.Attachment
 
    Dim y As Integer, x As Integer
 
    Set olApp = New Outlook.Application
    Set olSpace = olApp.GetNamespace("MAPI")
    Set olInbox = olSpace.GetDefaultFolder(olFolderInbox)
    Set olFolder = olInbox.Folders(NomDossier)
 
    For Each olmail In olFolder.Items
        If olmail.SenderEmailAddress = Expediteur And _
            Not olmail.Attachments.Count = 0 Then
 
            For y = 1 To olmail.Attachments.Count
                 Set pceJointe = olmail.Attachments(y)
                 x = x + 1
                 pceJointe.SaveAsFile "C:\" & x & "_" & pceJointe
                Set pceJointe = Nothing
            Next y
        End If
    Next olmail
 
End Sub

bonaprès midi
michel

09/03/2008, 19h09
pontoise

Bonjour,
J'ai mis ton code, le programme s'execute sans erreur mais je n'ai aucun fichier de rappatrié sous C:/.
J'ai crée un dossier "PJ" sous C; puis modifié le chemin dans le programme pour y mettre les pieces jointes, mais en vain (toujours pas de fichiers).
Aurais-tu des pistes pour moi STP??

Merci
10/03/2008, 17h52
SilkyRoad

bonsoir

ça fonctionne sans problème chez moi ...

bonne soirée
michel

Extraction des pieces jointes Outlook via le VBA (Suite)

Bonjour,

En effet, j'ai récupéré le code ci-dessous pour extraire automatiquement les pièces jointes Outlook via VBA. Ce code fonctionne bien mais ne répond pas tout à fait à mon besoin parce qu'il parcourt tous les dossiers de ma boite mail, alors que je ne voudrais récupérer que les pieces jointes de mon dossier "Test" qui est un dossier de ma "boite de reception".
1) Pourriez vous m'expliquer SVP comment modifier le programme ci-dessous pour spécifier un seul dossier d'extraction et ne pas parcourir à chaque fois toute ma boite mail ?

Pour information, sur l'autre discussion, mes interlocuteurs m'avaient fourni un autre code à la place mais qui n'a pas fonctionné malheureusement chez moi.

D'avance merci.
Voici le code:

Code:

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
Option Explicit
'------------------------------------------------------------------------
'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library
'------------------------------------------------------------------------
 
Dim x As Integer
 
    'La boite de réception, la boite des éléments supprimés et tous leurs
    'sous dossiers sont pris en compte.
Sub ExportePiecesJointes()
    Dim Ol As New Outlook.Application
    Dim Ns As Outlook.Namespace
    Dim Dossier As Outlook.MAPIFolder
 
    Set Ns = Ol.GetNamespace("MAPI")
    Set Dossier = Ns.Folders(1)
 
    SearchFolders Dossier
    x = 0
End Sub
 
 
Private Sub SearchFolders(ByVal fld As Outlook.MAPIFolder)
Dim y As Integer
Dim olmail 'As Outlook.MailItem
Dim pceJointe As Outlook.Attachment
Dim SousDossier As Outlook.MAPIFolder
 
For Each SousDossier In fld.Folders
'.Item("Nom_Du_Dossier").Items
    If SousDossier.DefaultItemType = 0 Then
        For Each olmail In SousDossier.Items
            If Not olmail.Attachments.Count = 0 Then
                For y = 1 To olmail.Attachments.Count
                     Set pceJointe = olmail.Attachments(y)
                     x = x + 1
                     pceJointe.SaveAsFile "C:\PJ\" & x & "_" & pceJointe
                    Set pceJointe = Nothing
                Next y
            End If
        Next olmail
    End If
    SearchFolders SousDossier
Next SousDossier
End Sub

Bonsoir,

je n'ai pas d'outlook sous la main mais que se passe-t-il si tu rajoute la ligne msgbox :
Code:

1 2 3 4 5 For Each SousDossier In fld.Folders '.Item("Nom_Du_Dossier").Items msgbox SousDossier.name If SousDossier.DefaultItemType = 0 Then

24/11/2008, 12h17
pontoise

Effectivement, j'ai plusieurs pop-up qui défilent avec à chaque fois le nom de l'un des dossiers de ma messagerie (elements supprimés, boite de reception, elements envoyes, Test .....).
Cela prouve que mon programme parcourt bien tous les dossiers, alors ²que je voudrais regarder que le dossier "Test".
Merci d'avance.
24/11/2008, 12h23
Godzestla
Bonjour,
je n'ai pas Outlokk et ne sais donc pas tester, mais tu devrais essayer de remplacer ceci :
Code:

1 2 3 4 For Each SousDossier In fld.Folders .... Next SousDossier
par quelquechose du genre
Code:

1 2 3 4 With fld.folder("Test") .... end with
24/11/2008, 14h31
pontoise

Quand j'ai fait ce que tu m'as expliqué, mon programme bloque au niveau de ligne :

Code:

With fld.Folder("Test")

Est ce que tu aurais d'autres suggestions STP?

Ca fait un peu bidouillage, mais teste ça :

Code:

1
2
3
For Each SousDossier In fld.Folders
'.Item("Nom_Du_Dossier").Items
    If SousDossier.DefaultItemType = 0 and SousDossier.name = "Test" Then

24/11/2008, 14h46
pontoise

Yes, ça marche.
Merci beaucoup.
24/11/2008, 14h49
Godzestla
Comme je t'ai dit, je n'ai pas outlook, nulle-part et il m'est donc totallement impossible de tester, mais il faut tester par exemple via la "Immediate Windows" pour trouver la syntaxe correcte pour récupérer un élément précis de la collection Folders.

Essaie ausi :
Code:

1 2 With fld.folders("Test")
il me semble que la solution qui t'a été donnée par SylkyRoad est correcte, via cette ligne
Code:

1 2 Set olFolder = olInbox.Folders(NomDossier)
Sinon, essaie de modifie la ligne suivante
Code:

1 2 If SousDossier.DefaultItemType = 0 Then
en
Code:

1 2 If SousDossier.DefaultItemType = 0 and SousDossier.name = "Test" Then
mais ce ne sont que des idées en draft.

Merci aux programmes qui fonctionnent...

Bonjour,
9 ans après... vive les forums...

je suis tout nouveau mais c'est pour vous remercier que je me suis inscrit et par la même occasion donner quelques informations supplémentaires
je n'ai jamais fais de VBA, donc j'ai essayé de comprendre en fonction de ce que j'avais "un historique de prog de microcontrôleur", j'ai bien galéré parce que les énoncés ne sont pas vraiment claires au départ...
je pense qu'il faut déjà connaitre pour voir les subtilités
mais bon, je viens d'extraire 4900 pièces jointes dans un répertoire et je vous remercie pour cela
voila en gros ce que j'ai compris sur le programme "qui fonctionne" de SilkyRoad
en fait :
Code:

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 Option Explicit Option Compare Text Sub Essai() Extraction "Mettre le nom du sous dossier à analyser ici", "mettre le nom de l'adresse mail que vous voulez tester (voila pourquoi cela ne fonctionnait pas pour pontoise car visualise mimi@provider.fr uniquement : je ne sais pas faire voir toutes les adresses mails mais dans mon cas pas grave" End Sub Sub Extraction(NomDossier As String, Expediteur As String) Dim olApp As Outlook.Application Dim olSpace As Outlook.NameSpace Dim olFolder As Outlook.MAPIFolder Dim olInbox As Outlook.MAPIFolder Dim olmail As Outlook.MailItem Dim pceJointe As Outlook.Attachment Dim y As Integer, x As Integer Set olApp = New Outlook.Application Set olSpace = olApp.GetNamespace("MAPI je ne sais pas pourquoi c'était écrit en rouge, je n'ai rien changé") Set olInbox = olSpace.GetDefaultFolder(olFolderInbox) Set olFolder = olInbox.Folders(NomDossier) For Each olmail In olFolder.Items If olmail.SenderEmailAddress = Expediteur And _ (ici cela compare l'adresse mail du départ avec celle dans le dossier (en l’occurrence mimi@...) Not olmail.Attachments.Count = 0 Then For y = 1 To olmail.Attachments.Count Set pceJointe = olmail.Attachments(y) x = x + 1 'pas d'affichage de x avant le nom de la PJ ça c'est mon commentaire pense bète pendant les essais... pceJointe.SaveAsFile "E:\disque ............faire le chemin..........photo\" & pceJointe (ne pas oublié le dernier\ sinon pas ok) j'ai viré l'affichage des X car je récupère les pièces jointes mais pas par ordre chronologique : ceci écrit 1 et nom pièce jointe puis 2 etnomPJ puis 3... donc X+1 le problème c'est qu'il va chercher le fichier dans un ordre pas clair... le nom de mes PJ était déjà datées (photos) Set pceJointe = Nothing Next y End If Next olmail End Sub
Donc en résumé ce programme VBA va voir un sous dossier de boite de réception (celui que vous définissez), regarder les mails reçus avec l'adresse définie au début, extrait la pièce jointe de chaque mail (dans mon cas JPG mais pas défini) puis va la placer dans un répertoire qui peut être sur n'importe quel disque dur (dans mon cas E) ne pas oublier le dernier \ et crée un fichier qui porte le nom de votre PJ (si elles ont le même nom vaut mieux utiliser le X+1 effectivement).
et tout ceci fonctionne puisque je viens de retirer 4915 photos d'une caméra qui m'envoie des photos par mail me permettant de faire un jolie montage vidéo...
Voici ma petite contribution
j'ai vraiment galéré pour trouver une solution
merci aux développeurs !!!