Nouveau code pour "Application.FileSearch"

[marmotte18]

Bonjour,

Dans Excel 2003, j'avais une macro qui fonctionnait fort bien et qui utilisait le code suivant :

With Application.FileSearch   
    .LookIn = Dossier
    .SearchSubFolders = True
End With

Avec Excel 2010, ma macro ne fonctionne plus et se bloque sur "With Application.File Search" avec le message "Erreur d'exécution 445 - Cet objet ne gère pas cette action".

Comment faut-il maintenant écrire le code sous Excel 2010 ?

Merci par avance

 

[marmotte18]

Re : Nouveau code pour "Application.FileSearch"

Bonjour tout le monde,

Merci à tous de vous êtes penchés sur mon problème. Pour l'instant, le code qui m'intéresse le plus est celui-ci :

Sub Liste()
Dim MyPath, MyName, T As Integer
 
'Chemin d'accès
MyPath = "C:\Mes documents\Informatique\Excel\"
 
'Nom du fichier lu, même avec l'attribut caché ou en lecture seul
MyName = Dir(MyPath, vbHidden)
 
'Recherche des fichiers uniquement
Do While MyName <> ""
    If MyName <> "." And MyName <> ".." Then
        For T = 1 To Len(MyName)
            If Mid(MyName, T, 1) = "." Then Debug.Print MyName
        Next T
    End If
    MyName = Dir
Loop
End Sub

Je souhaite ne conserver que les noms de fichier et pas les noms de dossier. Le code ci-dessus ne permettra pas d'exclure les noms de dossier qui ont un "." à l'intérieur. Quelqu'un a-t-il une idée ?

Merci à tous

 

[JNP]

Re : Nouveau code pour "Application.FileSearch"

Re ,
Comme ceci peut-être

Dim Extension As String
'Recherche des fichiers uniquement
Do While MyName <> ""
    If MyName <> "." And MyName <> ".." Then
        Extension = Right(MyName, 5)
        If MyName = ".xlsm" Or MyName = ".xlsx" Or Right(MyName, 4) = ".xls" Then Debug.Print MyName
    End If
    MyName = Dir
Loop

Bonne journée

 

[marmotte18]

Re : Nouveau code pour "Application.FileSearch"

Bonjour Jnp,

Merci pour ta réponse.

Je précise que les fichiers que je recherche doivent être de toutes natures (dll, exe, jpg, LiveUpdate, xls, doc, ...) et de ce fait l'extension peut très bien dépasser les 5 caractères.

Que dire d'un dossier nommé : "C:\Program Files\Dossier.Toto.Lala" ? Il ne faut pas considérer "Lala" comme une extension, ni même le nom car il s'agit d'un dossier et non d'un fichier.

 

[tototiti2008]

Re : Nouveau code pour "Application.FileSearch"

Bonjour marmotte, Bonjour JNP,

Alors il faut en revenir à la proposition de kjin, je pense (n'ai pas testé toutes les propositions)

FileSystemObject fait bien la différence entre dossier et fichier (SubFolders et Files, 2 collections différentes), l'aide VBA propose quelques exemples

Edit : Bonjour kjin

 

[kjin]

Re : Nouveau code pour "Application.FileSearch"

Bonjour, salut tototiti ,
@marmotte18 : zieuttes le fichier joint dans [thread=153454]CE FIL[/Thread] sur la recherche récursive de fichiers; tu pourras l'adapter en ajoutant les types d'extensions recherchées dans la liste
A+
kjin

 

[JNP]

Re : Nouveau code pour "Application.FileSearch"

Re ,
Tu peux aussi jeter un œil ICI .
Bonne après-midi

 

[marmotte18]

Re : Nouveau code pour "Application.FileSearch"

Bonjour tout le monde,

Merci à tous pour vos interventions toutes plus intéressantes les unes que les autres.

Il a bien fallu faire un choix !

JNP
J'ai regardé avec beaucoup d'attention ton lien mais il y a une chose qui me gêne dans ta réponse du 05/09/2010 à 13:15 :

Option Explicit
Dim I As Long
Sub Test()
Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
Chemin = "C:\Users\JNP\Documents\"
I = 1
Application.ScreenUpdating = False
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each Fichier In Dossier.Files
Cells(I, 1) = Dossier.Name
Cells(I, 2) = Fichier.Name
I = I + 1
Next
ListeFichier (Chemin)
Application.ScreenUpdating = True
End Sub
Function ListeFichier(Chemin As String) As String
Dim Dossier As Object, SousDossier As Object, Fichier As Object
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each SousDossier In Dossier.SubFolders
For Each Fichier In SousDossier.Files
Cells(I, 1) = SousDossier.Name
Cells(I, 2) = Fichier.Name
I = I + 1
ListeFichier (Chemin & SousDossier.Name & "\")
Next
Next
End Function

En effet, quand j'exécute ta macro chez moi, le 1er sous-répertoire n'est pas pris en compte et je ne comprends pas pourquoi.

 

[JNP]

Re : Nouveau code pour "Application.FileSearch"

Re ,
Effectivement, et j'ai eu du mal à trouver où je m'étais planté .
En réalité, je n'avais pas tenu compte qu'il pouvait y avoir des dossiers qui ne contenait pas de fichiers mais que des sous-dossiers .
Du fait

For Each SousDossier In Dossier.SubFolders
For Each Fichier In SousDossier.Files
Cells(I, 1) = SousDossier.Name
Cells(I, 2) = Fichier.Name
I = I + 1
ListeFichier (Chemin & SousDossier.Name & "\")
Next
Next

l'appel de la fonction récurente n'a pas lieu s'il n'y a pas de fichier, puisque le for Each saute directement au next ...
Donc, en appelant d'abord les sous dossiers, puis les fichiers, il semblerait que celà fonctionne normalement

Function ListeFichier(Chemin As String) As String
Dim Dossier As Object, SousDossier As Object, Fichier As Object
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each SousDossier In Dossier.SubFolders
ListeFichier (Chemin & SousDossier.Name & "\")
For Each Fichier In SousDossier.Files
Cells(I, 1) = SousDossier.Name
Cells(I, 2) = Fichier.Name
I = I + 1
Next
Next
End Function

Je vais corriger de ce pas le post de référence .
Dis moi si c'est maintenant OK .
Bonne journée

 

[marmotte18]

Re : Nouveau code pour "Application.FileSearch"

JNP,

J'ai mis ce code dans un module :

Option Explicit
Dim I As Long
Sub Test()
Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
Chemin = "C:\Mes documents\Informatique\Excel\"
I = 1
Application.ScreenUpdating = False
 
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
 
For Each SousDossier In Dossier.SubFolders
    For Each Fichier In SousDossier.Files
        Cells(I, 1) = SousDossier.Name
        Cells(I, 2) = Fichier.Name
        I = I + 1
        ListeFichier (Chemin & SousDossier.Name & "\")
    Next
Next
Application.ScreenUpdating = True
End Sub
 
Function ListeFichier(Chemin As String) As String
Dim Dossier As Object, SousDossier As Object, Fichier As Object
 
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
 
For Each SousDossier In Dossier.SubFolders
    ListeFichier (Chemin & SousDossier.Name & "\")
    For Each Fichier In SousDossier.Files
        Cells(I, 1) = SousDossier.Name
        Cells(I, 2) = Fichier.Name
        I = I + 1
    Next
Next
End Function

Désolé mais les fichiers du 1er sous-répertoire ne sont pas listés, ni même ceux du répertoire principal.

NB : mon répertoire principal est constitué de 9 sous-répertoires dont aucun n'est vide et de 129 fichiers dans le répertoire principal

 

[JNP]

Re : Nouveau code pour "Application.FileSearch"

Re ,
Evidemment, désolé, la même erreur était dans la sub principale

Sub Test()
Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
Chemin = "C:\Mes documents\Informatique\Excel\"
I = 1
Application.ScreenUpdating = False
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each SousDossier In Dossier.SubFolders
    ListeFichier (Chemin & SousDossier.Name & "\")
    For Each Fichier In SousDossier.Files
        Cells(I, 1) = SousDossier.Name
        Cells(I, 2) = Fichier.Name
        I = I + 1
    Next
Next
    For Each Fichier In Dossier.Files
Cells(I, 1) = Dossier.Name
Cells(I, 2) = Fichier.Name
I = I + 1
Next
Application.ScreenUpdating = True
End Sub

Là, ça va enfin fonctionner correctement (même nombre de ligne obtenu que les Propriétés du dossier) ...
Encore toutes mes excuses .
Bonne journée

 

[kjin]

Re : Nouveau code pour "Application.FileSearch"

Bonjour,
Une réadaptation qui fonctionne

Option Explicit

Sub Test()
Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
Dim nDirs As Long, nFiles As Long, lSize As Currency
Dim sDir As String, sExt As String
sDir = "C:\Mes documents\Informatique\Excel\"
If sDir = "" Then Exit Sub
sExt = InputBox("Quelle extension ?")
If sExt = "" Then sExt = "*.*"
lSize = FindFile(sDir, sExt, nDirs, nFiles, 1)
MsgBox Str(nFiles) & " fichiers trouvés dans " & Str(nDirs) & _
            " répertoires pour un total de " & lSize & " bytes"

End Sub
 
Private Function FindFile(ByVal sFol As String, sFile As String, _
nDirs As Long, nFiles As Long, x As Long) As Currency
Dim Fso, Fld, tFld, tFil, FileName As String, fs As Object
Dim Ext As String
On Error GoTo Suite
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fld = Fso.GetFolder(sFol)
FileName = Dir(Fso.BuildPath(Fld.Path, sFile), vbNormal Or vbHidden Or vbSystem Or vbReadOnly)
While Len(FileName) <> 0
    FindFile = FindFile + FileLen(Fso.BuildPath(Fld.Path, FileName))
    nFiles = nFiles + 1
    Set fs = Fso.GetFile(Fso.BuildPath(Fld.Path, FileName))
    Ext = Fso.GetExtensionName(Fso.BuildPath(Fld.Path, FileName))
        Cells(x, 1) = Fld.Path
        Cells(x, 2) = fs.Name
        Cells(x, 3) = fs.Type
        Cells(x, 4) = Ext
        Cells(x, 5) = fs.Size
        x = x + 1
    FileName = Dir()
    DoEvents
Wend
nDirs = nDirs + 1
If Fld.SubFolders.Count > 0 Then
   For Each tFld In Fld.SubFolders
      DoEvents
      FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles, x)
   Next
End If
Exit Function

Suite:
FileName = ""
Resume Next

End Function

A+
kjin

 

[JNP]

Re : Nouveau code pour "Application.FileSearch"

Re ,
Finalement, non, c'était toi qui t'était planté, tu as modifié la Sub alors qu'il ne fallait modifier que la fonction ...
Enfin, c'est pas grave .
Bonne journée

 

[marmotte18]

Re : Nouveau code pour "Application.FileSearch"

JNP,

Je veux bien volontiers reconnaître que je me suis trompé. Dans ce cas, peux-tu me communiquer l'intégralité du code qui est bon, car je m'y perds un peu entre toutes les versions.

Je t'en remercie par avance

 

[YANN-56]

Re : Nouveau code pour "Application.FileSearch"

Bonjour à tous,

Je suis en train de fouiller partout, et suis particulièrement ce fil.

Mon premier exemple proposé marche pour 2003 et 2007.
(2003 c'est chez moi, 2007 c'est chez kiki)
Quant pour 2010; c'est le plantage ainsi que me dis pierrejean. (Voir posts ci-dessus)

J'ai revu ma méthode, mais avant d'aller plus loin. (Nouveau classeur joint)
J'aimerais savoir s'il y a encore souci avec versions postérieures à 2003.

Par ailleurs, je suis un peu noyé parmi tout ce que je viens de lire,
et j'ai du mal à trouver la façon de faire qui me permettra:

1) D'entrer éventuellement dans les sous dossiers (Voire suite à un bouton d'option)
2) D'extirper les dates de création, de modifications, poids...Et c.
(Dans l'exemple joint, la gestion des photos n'est qu'accessoire)

En résumé, n'étant pas de taille à deviner par moi-même la solution la
mieux appropriée (Sauf à y passer moult heures d'écriture et de tests),
je fais appel à vous pour m'aiguiller vers le meilleur choix.

Bravo, au passage, pour l'aide que vous apportez à Marmotte.

Amicalement.

Yann

 

[JNP]

Re : Nouveau code pour "Application.FileSearch"

Re ,

Option Explicit
Dim I As Long
Sub Test()
Dim Chemin As String, Dossier As Object, SousDossier As Object, Fichier As Object
Chemin = "C:\Users\JNP\Documents\"
I = 1
Application.ScreenUpdating = False
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each Fichier In Dossier.Files
Cells(I, 1) = Dossier.Name
Cells(I, 2) = Fichier.Name
I = I + 1
Next
ListeFichier (Chemin)
Application.ScreenUpdating = True
End Sub
Function ListeFichier(Chemin As String) As String
Dim Dossier As Object, SousDossier As Object, Fichier As Object
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each SousDossier In Dossier.SubFolders
ListeFichier (Chemin & SousDossier.Name & "\")
For Each Fichier In SousDossier.Files
Cells(I, 1) = SousDossier.Name
Cells(I, 2) = Fichier.Name
I = I + 1
Next
Next
End Function

Voilà .
A +