Discussion :

[pontoise]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[SilkyRoad]

bonjour

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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

[SilkyRoad]

bonsoir

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

bonne soirée
michel

[pontoise]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[JackOuYA]

Bonsoir,

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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.

[Godzestla]

Bonjour,
je n'ai pas Outlokk et ne sais donc pas tester, mais tu devrais essayer de remplacer ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
For Each SousDossier In fld.Folders
....
Next SousDossier

par quelquechose du genre

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
With fld.folder("Test")
....
end with

[pontoise]

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

With fld.Folder("Test")

Est ce que tu aurais d'autres suggestions STP?

[oOVaveOo]

Ca fait un peu bidouillage, mais teste ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[pontoise]

Yes, ça marche.
Merci beaucoup.

[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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Set olFolder = olInbox.Folders(NomDossier)

Sinon, essaie de modifie la ligne suivante

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
    If SousDossier.DefaultItemType = 0 Then

en

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
    If SousDossier.DefaultItemType = 0 and SousDossier.name = "Test" Then

mais ce ne sont que des idées en draft.

[bebert38]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 !!!