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 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
| Option Explicit
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
Dim NbFichiers As Long, NbDossiers As Long
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim r As Long
Const TypeFichier As String = "pdf"
Private Sub ListeFichiers(sDossier As String)
DoEvents
Application.ScreenUpdating = False
QueryPerformanceCounter Dep
ShFichiers.Cells.Clear
r = 0: NbDossiers = 0: NbFichiers = 0
ListeFichiersDansDossier sDossier, True
Tri
QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
With Application
.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & NbFichiers & " / " & TypeFichier & " : " & r & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
.ScreenUpdating = True
End With
End Sub
Private Sub Tri()
With ShFichiers
.Columns("A").Sort Key1:=.Range("A1"), Order1:=xlAscending
End With
End Sub
' Late Binding
Private Sub ListeFichiersDansDossier(sChemin As String, InclureSousDossiers As Boolean)
Dim FSO As Object, Dossier As Object, Fichier As String
Dim sPath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Dossier = FSO.GetFolder(sChemin)
Fichier = Dir$(sChemin & "\*.*")
Do While Len(Fichier) > 0
NbFichiers = NbFichiers + 1
sPath = sChemin & "\" & Fichier
If UCase(TypeFichier) = UCase(FSO.GetExtensionName(Fichier)) Then
r = r + 1
ShFichiers.Hyperlinks.Add Anchor:=ShFichiers.Range("A" & r), _
Address:=sPath, TextToDisplay:=CStr(Fichier)
End If
Fichier = Dir$()
If NbFichiers Mod 100 = 0 Then Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & NbFichiers & " / " & TypeFichier & " : " & r
Loop
If InclureSousDossiers Then
For Each Dossier In Dossier.SubFolders
NbDossiers = NbDossiers + 1
ListeFichiersDansDossier Dossier.Path, True
Next Dossier
End If
Set Dossier = Nothing
Set FSO = Nothing
End Sub
Sub SelDossier()
Dim sChemin As String
sChemin = ThisWorkbook.Path
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = sChemin & "\"
.Title = "Dossier à traiter"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewDetails
.ButtonName = "Sélection Dossier"
.Show
If .SelectedItems.Count > 0 Then ListeFichiers .SelectedItems(1)
ShFichiers.Range("D1").Select
End With
End Sub |
Partager