Discussion :

[richert90]

Bonjour à tous
Voila ma question:

Comment je peux faire pour qu'à partir du nom d'un fichier et son extension (exemple "test.xlsm") le rechercher sur l'ordinateur (dans tous les répertoires) pour pouvoir récupérer à la fin son chemin complet ? (ex je récupère dans une variable le chemin du répertoire où se situe le fichier cherché: "C:\Mes doc\moi\test.xlsm")

Merci d'avance

[PMO2017]

Bonjour,

Une piste avec le code suivant à copier dans un module standard.
Adaptez, à votre usage, les 2 paramètres dans la Sub aa()

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
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Declare Function SearchTreeForFile& Lib "imagehlp" ( _
  ByVal RootPath As String, ByVal InputPathName As String, ByVal OutputPathBuffer As String)
Declare Function SHGetSpecialFolderLocation& Lib "shell32.dll" ( _
  ByVal hwnd As Long, ByVal csidl As Long, ByRef ppidl As ITEMIDLIST)
Declare Function SHGetPathFromIDList& Lib "shell32.dll" ( _
  ByRef pidl As Long, ByVal pszPath As String)
 
  '/// Types ///
Type SHITEMID
  cb As Long
  abID As Byte
End Type
Type ITEMIDLIST
  mkid As SHITEMID
End Type
 
Const CSIDL_DESKTOP As Long = &H0
 
Sub aa()
Dim Reponse As String
 
'--- Adapter les 2 paramètres (ATTENTION : on ne peut pas directement chercher dans la racine C:) ---
Reponse = ResearchFile("C:\Documents and Settings", "DataObject.xlsm")
'----------------------------------------------------------------------------------------------------
 
If Reponse <> "" Then MsgBox Reponse
End Sub
 
Function ResearchFile(Dossier As String, Fichier As String) As String
Const MAX_PATH = 260
Dim Tampon$
Dim Ret&
Dim Racine$
Dim A$
'###################################################################################
'### Il est impossible de traiter directement le répertoire racine (chez moi C:) ###
'### Si le fichier recherché n'existe pas, PLANTAGE du système.                  ###
'###################################################################################
A$ = PathSpecial(CSIDL_DESKTOP)
Racine$ = Mid(A$, 1, InStr(1, A$, "\") - 1)
If UCase(Dossier) = UCase(Racine$) Or UCase(Dossier) = UCase(Racine$) & "\" Then
  MsgBox "Impossible de traiter directement le répertoire racine " & Racine$ & vbCrLf & vbCrLf & _
         "Veuillez lui apparenter un de ses sous-dossiers."
  Exit Function
End If
'###################################################################################
'--- Recherche du chemin du fichier ---
Tampon$ = Space(MAX_PATH)
Ret& = SearchTreeForFile(Dossier, Fichier, Tampon$)
If Ret& <> 0 Then
  ResearchFile = Left$(Tampon$, InStr(1, Tampon$, Chr$(0)) - 1)
Else
  MsgBox "Fichier introuvable"
End If
End Function
 
'### Recherche de dossier spécial pour pouvoir en déterminer la racine par la suite ###
Function PathSpecial(SpecialFolder As Long) As String
Dim Retour&
Dim A$
Dim IDL As ITEMIDLIST
  Retour& = SHGetSpecialFolderLocation(0, SpecialFolder, IDL)
  If Retour& = 0 Then
    A$ = Space(512)
    Retour& = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal A$)
    PathSpecial = Left(A$, InStr(A$, vbNullChar) - 1)
  End If
End Function

[casefayere]

Bonsoir,

Sans douter de la solution proposée par PMO2017, autre solution adaptable avec Fso
Un Usf avec un bouton de commande "CommandButton1", une listbox "ListBox1", la référence "Microsoft Scripting Runtime" cochée (voir image)

Les codes :

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
Option Explicit
Dim fso As New FileSystemObject
Dim fld As Folder
 
 
Private Function FindFile(ByVal sFol As String, sFile As String, _
   nDirs As Long, nFiles As Long) As Currency
   Dim tFld As Folder, tFil As File, FileName As String
 
   On Error GoTo Catch
   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
      ListBox1.AddItem fso.BuildPath(fld.ShortPath, FileName)  ' a adapter
      'ou ListBox1.AddItem  FileName
      FileName = Dir()  ' Get next file
      DoEvents
   Wend
   Label1 = "Recherche " & vbCrLf & fld.Path & "..."
   nDirs = nDirs + 1
   If fld.SubFolders.Count > 0 Then
      For Each tFld In fld.SubFolders
         DoEvents
         FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles)
      Next
   End If
   Exit Function
Catch:  FileName = ""
       Resume Next
End Function

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub CommandButton1_Click()
 Dim nDirs As Long, nFiles As Long, lSize As Currency
   Dim sDir As String, sSrchString As String
   sDir = InputBox("Repertoire de départ", _
                   "Vous pouvez modifier", ThisWorkbook.Path)
   sSrchString = InputBox("Type de fichier", _
                   "exemple", "*.xl*")
   Label1.Caption = "Recherche " & vbCrLf & UCase(sDir) & "..."
   lSize = FindFile(sDir, sSrchString, nDirs, nFiles)
   MsgBox Str(nFiles) & " Fichiers trouvés dans" & Str(nDirs) & _
          " repertoire(s)", vbInformation
   MsgBox "Total taille = " & lSize & " bytes"
End Sub