XL 2019 Changement type fenêtre pour sélection chemin dossier VBA

[guiboubou233]

Bonjour à tous,

Dans le cadre de mon travail je dois répertorier les chemins, noms, dates de modifications etc de nos fichiers lors des sauvegardes. J'ai trouvé une macro déjà faite correspondant assez bien à mes besoins.

Spoiler: Le code que j'ai déjà modifié

Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil
 
Sub MainExtractData()
    
    Dim NewSht As Worksheet
    Dim MainFolderName As String
    Dim TimeLimit As Long, StartTime As Double
      
    ReDim X(1 To 1048576, 1 To 11)
    
    Set objShell = CreateObject("Shell.Application")
    TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" & vbNewLine & vbNewLine & _
    "Leave this at zero for unlimited runtime", "Time Check box", 0)
    StartTime = Timer
    
    Application.ScreenUpdating = False
    MainFolderName = BrowseForFolder()
    Set NewSht = ThisWorkbook.Sheets.Add
    
    X(1, 1) = "Path"
    X(1, 2) = "File Name"
    X(1, 3) = "Last Accessed"
    X(1, 4) = "Last Modified"
    X(1, 5) = "Created"
    X(1, 6) = "Type"
    X(1, 7) = "Size"
    X(1, 8) = "Owner"
    X(1, 9) = "Author"
    X(1, 10) = "Title"
    X(1, 11) = "Comments"
    
    i = 1
    
    Set FSO = CreateObject("scripting.FileSystemObject")
    Set oFolder = FSO.GetFolder(MainFolderName)
     'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
    On Error Resume Next
    For Each Fil In oFolder.Files
        Set objFolder = objShell.Namespace(oFolder.Path)
        Set objFolderItem = objFolder.ParseName(Fil.Name)
        i = i + 1
        If i Mod 20 = 0 And TimeLimit <> 0 And Timer > (TimeLimit * 60 + StartTime) Then
            GoTo FastExit
        End If
        If i Mod 50 = 0 Then
            Application.StatusBar = "Processing File " & i
            DoEvents
        End If
        X(i, 1) = oFolder.Path
        X(i, 2) = Fil.Name
        X(i, 3) = Fil.DateLastAccessed
        X(i, 4) = Fil.DateLastModified
        X(i, 5) = Fil.DateCreated
        X(i, 6) = Fil.Type
        X(i, 7) = Fil.Size
        X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
        X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
        X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
        X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
    Next
    
     'Get subdirectories
    If TimeLimit = 0 Then
        Call RecursiveFolder(oFolder, 0)
    Else
        If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
    End If
    
FastExit:
    Range("A:K") = X
    If i < 1 Then Range(Cells(i + 1, "A"), Cells(1, "A")).EntireRow.Delete
    Range("A:K").WrapText = False
    Range("A:K").EntireColumn.AutoFit
    Range("1:1").Font.Bold = True
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Range("a1").Activate
    
    Set FSO = Nothing
    Set objShell = Nothing
    Set oFolder = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
    Set Fil = Nothing
    Application.StatusBar = ""
    Application.ScreenUpdating = True
End Sub
 
Sub RecursiveFolder(xFolder, TimeTest As Long)
    Dim SubFld
    For Each SubFld In xFolder.SubFolders
        Set oFolder = FSO.GetFolder(SubFld)
        Set objFolder = objShell.Namespace(SubFld.Path)
        For Each Fil In SubFld.Files
            Set objFolder = objShell.Namespace(oFolder.Path)
             'Problem with objFolder at times
            If Not objFolder Is Nothing Then
                Set objFolderItem = objFolder.ParseName(Fil.Name)
                i = i + 1
                If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
                    Exit Sub
                End If
                If i Mod 50 = 0 Then
                    Application.StatusBar = "Processing File " & i
                    DoEvents
                End If
                X(i, 1) = SubFld.Path
                X(i, 2) = Fil.Name
                X(i, 3) = Fil.DateLastAccessed
                X(i, 4) = Fil.DateLastModified
                X(i, 5) = Fil.DateCreated
                X(i, 6) = Fil.Type
                X(i, 7) = Fil.Size
                X(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
                X(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
                X(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
                X(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
            Else
                Debug.Print Fil.Path & " " & Fil.Name
            End If
        Next
        Call RecursiveFolder(SubFld, TimeTest)
    Next
End Sub
 
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
    
    Dim ShellApp As Object
    
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
    
     'Destroy the Shell Application
    Set ShellApp = Nothing
    
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    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:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
    
End Function

J'ai cependant du arranger deux trois choses :
- faire sauter la limite de 65 000 lignes en changeant l'extension et deux trois trucs dans le code => oui on a beaucoup de fichiers
- enlever tout les NA que le fichier générait jusqu'à la dernière ligne quand il ne trouvait plus de fichier.

Une dernière chose reste à faire (c'est là que j'ai besoin de vous ) : changer le type de fenêtre qui est utilisé lors du lancement de la macro qui n'est pas du tout pratique pour la sélection du dossier à cause de son format arborescence.... surtout pour des fichiers situés sur des servers.



J'aimerai plutôt avoir ce genre de fenêtre



(Petit bonus : je trouve la macro assez lente et j'ai l'impression qu'elle ne finit pas réellement lorsqu'elle a trouvé le dernier fichier mais qu'elle génère des "cases vides". Si cette impression est réelle, il y a t-il moyen de la booster un peu en optimisant le code VBA?
J'ai déjà réussi à virer les NA générés, ça fait du poids en moins dans les fichiers.... surtout sur 1M de lignes.)

Merci par avance pour vos suggestions
Paul