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 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
|
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, rDOC As Long, rXLS As Long, rPPT As Long, sTypeFich As String
Dim TypeF() As Variant
Private Sub ListeFichiers(sDossier As String)
DoEvents
Application.ScreenUpdating = False
QueryPerformanceCounter Dep
ShFichiers.Cells.Clear
r = 0: NbDossiers = 0: NbFichiers = 0
rDOC = 4: rXLS = 4: rPPT = 4
ListeFichiersDansDossier sDossier, True
Tri
With ShFichiers
.Columns("A:D").ColumnWidth = 14.86
.Columns("A:D").Columns.AutoFit
End With
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
With Application
.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & NbFichiers & " / " & sTypeFich & " : " & r & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
.ScreenUpdating = True
End With
End Sub
' Late Binding
Private Sub ListeFichiersDansDossier(sChemin As String, bInclureSousDossiers As Boolean)
Dim FSO As Object, Dossier As Object, Fichier As String
Dim sPath As String, i As Long
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Dossier = FSO.GetFolder(sChemin)
Fichier = Dir$(sChemin & "\*.*")
Do While Len(Fichier) > 0
NbFichiers = NbFichiers + 1
sPath = sChemin & "\" & Fichier
For i = LBound(TypeF) To UBound(TypeF)
If UCase(FSO.GetExtensionName(Fichier)) Like UCase(TypeF(i)) Then
r = r + 1
Select Case TypeF(i)
Case TypeF(0)
rDOC = rDOC + 1
ShFichiers.Hyperlinks.Add Anchor:=ShFichiers.Range("A" & rDOC), _
Address:=sPath, TextToDisplay:=CStr(Fichier)
Case TypeF(1)
rXLS = rXLS + 1
ShFichiers.Hyperlinks.Add Anchor:=ShFichiers.Range("B" & rXLS), _
Address:=sPath, TextToDisplay:=CStr(Fichier)
Case TypeF(2)
rPPT = rPPT + 1
ShFichiers.Hyperlinks.Add Anchor:=ShFichiers.Range("C" & rPPT), _
Address:=sPath, TextToDisplay:=CStr(Fichier)
End Select
End If
Next i
Fichier = Dir$()
Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & NbFichiers & " / " & sTypeFich & " : " & r
Loop
If bInclureSousDossiers 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, i As Long
TypeF = Array("doc*", "xls*", "ppt*")
sTypeFich = ""
For i = LBound(TypeF) To UBound(TypeF)
sTypeFich = sTypeFich & " " & TypeF(i)
Next i
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("A5").Select
End With
End Sub
Sub Tri()
With ShFichiers
.Range("A5:A" & Rows.Count).Sort Key1:=Range("A5"), Order1:=xlAscending
.Range("B5:B" & Rows.Count).Sort Key1:=Range("B5"), Order1:=xlAscending
.Range("C5:C" & Rows.Count).Sort Key1:=Range("C5"), Order1:=xlAscending
End With
End Sub |
Partager