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