Filesearch dans 2007 ?

Version imprimable

Bonjour,

Ca y est on vient de me migrer en 2007 !
Je n'ai plus que 10 and de retard economie, economie !

Bref il me faut valider maintenant les macros que j'ai mise à disposition de mes utilisateurs avant qu'ils ne soient tous migrés !

J'utilise en autre la fonction Filesearch pour retoruver le dernier fichier créé et supprimer les plus anciens or catte fonction n'est plus active.
J'ai regardé le tuto the Silkyroad, mais outre le fait de n'être par sûr d'avoir tout compris, il est embêtant de devoir ajouter un module complémentaires à tous les utilisateurs potentiels.
http://silkyroad.developpez.com/vba/classefilesearch/

Existe-t-il une autre alternative pour faire ce que je veux faire ?
MErci pour vos conseils
Denis.

Voici le code que j'ai récupéré et mis à ma sauce.
Désolé je n'ai plus l'auteur des lignes d'origine.

Le code lit le répertoire et stocke temporairement les fichiers
puis suite à un tri ouvre le plus récent.
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 Set fso = CreateObject("Scripting.FileSystemObject") Set fs = Application.FileSearch With fs .LookIn = "S:\Mon_repertoire" .Filename = "*.txt" .Execute For Each f In .FoundFiles Set file = fso.GetFile(f) If Left(file.Name, 7) = "STK_PSO" Then Range("a1") = file.DateLastModified Range("b1") = f Range("c1") = file.Name Range("d1").FormulaR1C1 = "=DATEDIF(RC[-3],NOW(),""md"")" Range("a1").Insert Shift:=xlDown Range("b1").Insert Shift:=xlDown Range("c1").Insert Shift:=xlDown Range("d1").Insert Shift:=xlDown ' les fichiers de plus de huit jours sont supprimés If Range("d2") > 8 Then a_supp = Range("b2").Value Kill a_supp End If End If Next f End With Set fso = Nothing Set file = Nothing Range("A1").Delete Shift:=xlUp Range("b1").Delete Shift:=xlUp Range("C1").Delete Shift:=xlUp Range("D1").Delete Shift:=xlUp Range(Range("a1"), Range("a1").End(xlDown)).Select Selection.Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlNo, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal DATE_SAP = Range("a1").Value plus_recent = Range("b1").Value SAP_FILE = Range("C1").Value If SAP_FILE = "" Then MsgBox "Pas de fichier de stock disponible relancer plus tard" End End If

31/07/2013, 14h37
parmi

Bonjour,

Tu pourrais regarder du côté de Dir ainsi que FileDateTime

Lire les fichiers d'un répertoire les trier et supprimer les plus anciens

Grâce aux tutos et quelques tests en tatonnant, j'ai réussi à m'en sortir come cela.
Inutile d'activer le complément Microsoft Scripting pour mon application.

J'ai juste repris et adapté le code proposé par Silkyroad
http://excel.developpez.com/faq/?page=FichiersDir

Par contre, je n'ai pas réussi à calculer l'âge de mon fichier en faisant
Age= date - datecrefich, je n'ai pas réussi à rendre le format de Age compatibles pour le calcul !

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
46
47
48
49
50
51
52
53
54
55
56
57
58
59
 
Application.ScreenUpdating = False
'********************************************************
'     Recherche des fichiers disponibles suppression des plus vieux que 8 jours 
'     et chargement du plus récent.
'********************************************************
    Dim Fichier As String, Chemin As String
    Dim Tableau()
    Dim m As Integer, i As Integer
    Dim z As Byte, Valeur As Byte
    Dim Datelimite As Date
    Dim Datecrefich As Date
 
'---liste les fichiers du répertoire ---
    Chemin = "MonRépertoire"
    Fichier = Dir(Chemin & "*.*")
    'pour filtrer sur un type de fichiers (par exemple xls)
    'Fichier = Dir(Chemin & "\*.xls")
 
    'Boucle sur les fichiers
    Do
 
        m = m + 1
        ReDim Preserve Tableau(1 To 2, 1 To m)
        Tableau(1, m) = Fichier
 
       Set Fso = CreateObject("Scripting.FileSystemObject")
       Set FileItem = Fso.GetFile(Chemin & "\" & Fichier)
 
        'Récupère la date de création
        Tableau(2, m) = Left(FileItem.DateCreated, 10)
' ici je fixe ma durée d'archive que je souhaite garder (ici 8 jours).
        Datelimite = Date - 8
        Datecrefich = Left(FileItem.DateCreated, 10)
' si le fichier est plus vieux, je le supprime
        If Datelimite > Datecrefich Then
        Kill FileItem
        End If
         Fichier = Dir
    Loop Until Fichier = ""
 
 
    '---Trie les fichiers par ordre décroissant de création ---
    Do
        Valeur = 0
        For i = 1 To m - 1
            If CDate(Tableau(2, i)) < CDate(Tableau(2, i + 1)) Then
                For z = 1 To 2
                    Cible = Tableau(z, i)
                    Tableau(z, i) = Tableau(z, i + 1)
                    Tableau(z, i + 1) = Cible
                Next z
 
                Valeur = 1
            End If
        Next i
    Loop While Valeur = 1
 
 MonFichierA_Ouvrir = chemin &Tableau(1, 1)