Lister repertoire films

Option Explicit

Sub listFolder()

Dim myFileDialog As FileDialog, myFolderPath As String, myFso As FileSystemObject, myFolder As Folder
ThisWorkbook.Sheets("Feuil1").Cells.Clear

Set myFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
myFileDialog.AllowMultiSelect = False
myFileDialog.Show
myFolderPath = myFileDialog.SelectedItems.Item(1)
Set myFileDialog = Nothing

Set myFso = New FileSystemObject
Set myFolder = myFso.GetFolder(myFolderPath)

analyseFolder myFolder

End Sub



Public Sub analyseFolder(folderAnalysed As Folder)
Dim curCell As Range, curFolder As Folder, curFile As File
With ThisWorkbook.Sheets("Feuil1")
    Set curCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
For Each curFolder In folderAnalysed.SubFolders
    analyseFolder curFolder
Next curFolder
For Each curFile In folderAnalysed.Files
    If curFile.Type = "Clip vidéo" Then
        curCell.Value = Left(curFile.Name, Len(curFile.Name) - 4)
        Set curCell = curCell.Offset(1, 0)
    End If
Next curFile
End Sub

                    With ThisWorkbook.Sheets("Test")
 
                        .Cells(L, 1).Value = Mid(Fichier.Name, 1, InStr(1, Fichier.Name, ".") - 1)

                        '.Cells(L, 1).Value = Chemin
 
                    End With

Sub ScanClasseurs()
Dim Dossier As Object, Fichier As Object
Dim Chemin As String, CeFichier As String, ExtFichier As String[COLOR="Red"][B], ExtLongeur As Integer[/B][/COLOR]
Dim TabDossiers As Variant
Dim L As Long, D As Long
    Chemin = CheminUser
    If Chemin = "" Then Exit Sub
    Application.ScreenUpdating = False
    ThisWorkbook.Sheets("Test").Range("A2:B65536").Delete Shift:=xlUp
    CeFichier = ThisWorkbook.Name
    ExtFichier = UCase(Trim(ThisWorkbook.Sheets("Test").Range("Extension").Text))
    [COLOR="Red"][B]ExtLongeur = Len(ExtFichier)[/B][/COLOR]
    L = 1
    'Création du tableau des sous-dossiers existants
    TabDossiers = lstDossiers(Chemin, True)
    For D = 1 To UBound(TabDossiers)
        'Chemin du dossier (ou sous-dossier) à analyser
        Chemin = TabDossiers(D)
        If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
        'Analyse du dossier (ou sous-dossier)
        Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
        For Each Fichier In Dossier.Files
            If Fichier.Name <> CeFichier Then
                If ExtFichier = "" Or UCase(Right(Fichier.Name, 3)) = ExtFichier Then
                    'Liste les fichiers
                    L = L + 1
                    'MAJ feuille résultats
                    With ThisWorkbook.Sheets("Test")
                        .Cells(L, 1).Value = Chemin
                        .Hyperlinks.Add Anchor:=.Cells(L, 2), Address:=Chemin & Fichier.Name, _
                                TextToDisplay:=[COLOR="Red"][B]Left(Fichier.Name, Len(Fichier.Name) - (ExtLongeur + 1))[/B][/COLOR]
                        .Cells(L, 3).Value = Fichier.Type
                        .Cells(L, 4).Value = Fichier.Size
                        .Cells(L, 5).Value = Fichier.DateCreated
                    End With
                End If
            End If
        Next
    Next D
    Set Dossier = Nothing
    'Rétablit l'alerte de lien éventuelle dans les options Excel
    Application.ScreenUpdating = True
    MsgBox L - 1 & " fichiers trouvés !"
End Sub