XL 2003 Récup PJ Outlook mais ne pas retraiter celles déjà faites... sujet

Bonjour à tous,

je suis face à un problème que je ne parviens pas à résoudre...
Je vous explique rapidement ma situation:

1. J'ai un code qui va me récupérer toutes les pièces jointes des mails d'un sous-dossier nommé Retour
2. J'ai un autre code qui va, une fois les PJ enregistrées, détecter les fichiers Excel, les ouvrir et s'ils répondent à certaines conditions recopier certaines valeurs, enregistrer au format voulu et sauvegarder
3. On passe ensuite à la PJ suivante

Tout ça marche nickel mais c'est long car j'ai plus de 300 fichiers pour l'instant et je devrais monter jusqu'à 600...

Du coup me suis dit, au lieu de tout reprendre à 0 à chaque fois, je vais faire une liste des PJ "*.xls" en début de code (avant la récup des PJ), puis faire la récup des PJ (qui réécrira avec le même nom les PJ déjà présentes et ajouter les nouvelles) puis faire une nouvelle liste des PJ avec un recherchev entre les 2 pour détecter celles présentes dans la 2ème liste et non dans la 1ère pour ne rajouter que celles-ci...


Problème, le code de récup étant assez complexe, je ne parviens pas à le mixer avec les listes des fichiers...

Du coup, j'obtiens un message d'erreur (cf copie d'écran)...
Sur le code suivant :

Code vba:

---

Option Explicit
'------------------------------------------------------------------------
'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library
'------------------------------------------------------------------------

 
Dim x As Integer
Dim Dossier, Dossier2

    '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)
 'MsgBox Dossier

    SearchFolders Dossier
    x = 0
   
    MsgBox "Fichiers chargés"
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
'With fld.Folders
'.Item("Retours").Items
   If SousDossier.DefaultItemType = 0 And SousDossier.Name = "Retours" Then
        For Each OLmail In SousDossier.Items
            If Not OLmail.Attachments.Count = 0 Then
                For y = 1 To OLmail.Attachments.Count
                'MsgBox SousDossier.Name
                    Set pceJointe = OLmail.Attachments(y)
                     x = x + 1
                     
                     'l'erreur apparaît là alors que ça marche quand je ne fais que ce code!!
                    pceJointe.SaveAsFile Dossier & x & "_" & pceJointe
                   
                    Set pceJointe = Nothing
                Next y
            End If
        Next OLmail
    End If
    SearchFolders SousDossier
Next SousDossier
'MsgBox x & " fichiers enregistrés"
End Sub

---

Le code pour lister les PJ :

Code vba:

---

Dim Chem, NF2

Sub t1()
With Sheets("Accueil")
.Range("r2:r65000").ClearContents
Chem = "C:\Documents and Settings\thibault.spreux\Bureau\Compta Ana\Gestion des temps\PJ Mails"
ChDir Chem
.Range("r2").Select
NF2 = Dir("*.xls")
    Do While NF2 <> ""
        ActiveCell = NF2
        ActiveCell.Offset(1, 0).Select
        NF2 = Dir
    Loop
End With
End Sub

---

Je ne sais pas du tout comment faire, si qq1 a une idée je suis preneur...

D'avance Merci

Images attachées

• 
  
  Erreur macro savePJ.JPG‎
  (15,2 Ko)