EXCEL

Sub Listing()

Set fso = CreateObject("Scripting.FileSystemObject")

'recupérer le dossier à lister
urep = BrowseForFolder

If urep = False Then Exit Sub

'demande de confirmation utilisateur
cont = MsgBox("La création de la liste peut prendre plusieurs minutes !" & vbCrLf & vbCrLf & "                                  Confirmer ?", vbYesNo, "ATTENTION")
If cont = vbNo Then Exit Sub

'Initialisation de l'heure de début
hdeb = Time

'désactivation du rafraichissement écran
Application.ScreenUpdating = False

'Création d'un collection Office.FileSearch contenant le chemin de fichiers trouvés
Dim ScanFic As Office.FileSearch
Dim NomFic As Variant
Dim Diag As String
Dim Nbr As Long
Dim i As Long
Set ScanFic = Application.FileSearch
With ScanFic
.NewSearch
.LookIn = urep
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles
Nbr = .Execute
End With '-------------------
'compteur utilisé pour le numéro de ligne
i = 2

'Création d'une nouvelle feuille
Worksheets.Add
'création des en-têtes de colonne
ActiveSheet.Cells(i, 1).Value = "Nom"
ActiveSheet.Cells(i, 2).Value = "Type"
ActiveSheet.Cells(i, 3).Value = "Taille"
ActiveSheet.Cells(i, 4).Value = "Date de création"
ActiveSheet.Cells(i, 5).Value = "Date Modification"
ActiveSheet.Cells(i, 6).Value = "Chemin Complet"

'Boucle sur les chemin de fichiers (collection ScanFic)
For Each NomFic In ScanFic.FoundFiles

i = i + 1

Set ficd = fso.GetFile(NomFic)
'Ecriture de la liste de fichiers et leurs propriétés
ActiveSheet.Cells(i, 1).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=NomFic, _
    TextToDisplay:=ficd.Name 'lien hypertext vers le fichier
ActiveSheet.Cells(i, 2).Value = ficd.Type
If (ficd.Size / 1024) < 1500 Then
        ActiveSheet.Cells(i, 3).Value = Round((ficd.Size / 1024), 0) & " ko"
    Else: ActiveSheet.Cells(i, 3).Value = Round(((ficd.Size / 1024) / 1024), 2) & " Mo"
End If
ActiveSheet.Cells(i, 4).Value = ficd.DateCreated
ActiveSheet.Cells(i, 5).Value = ficd.datelastmodified
ActiveSheet.Cells(i, 6).Value = NomFic

Next

'***********************Formattage**************************
Cells.Select
Cells.Select
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
    End With
Cells.EntireColumn.AutoFit
Rows("3:3").Select

ActiveWindow.FreezePanes = True

Range("A2:F" & i).Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
Range("A2:E2").Select
Selection.Font.Bold = True
Selection.Interior.ColorIndex = 15
Selection.HorizontalAlignment = xlCenter
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With

Cells.Select
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
    End With
Cells.EntireColumn.AutoFit
Rows("3:3").Select
ActiveWindow.FreezePanes = True
Rows("2:2").Select
Selection.AutoFilter

'Initialisation de l'heure de fin
hfin = Time
'Calcul du temps d'éxécution
extime = DateDiff("s", hdeb, hfin)

'Ecriture de la ligne d'informations
ActiveSheet.Cells(1, 1).Value = "Dossier : " & urep & " - " & Nbr & " fichiers trouvé(s) - " & extime & " seconde(s)"

'Ré-activation du rafraichissement d'écran
Application.ScreenUpdating = True

End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant

     
    Dim ShellApp As Object
     
     'Crée une fenetre windows de sélection de dossier
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
     
     'Récupere le chemin du dossier sélectionné
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Libere l'objet shell
    Set ShellApp = Nothing
     
     'Vérification de la validité de la variable d'entrée
     'Valide si commence par *: (* = n'importe quelle letre) ou // (test sur le second caractère)
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'Renvoie False si la variable d'entrée n'est pas valide
    BrowseForFolder = False
     
End Function