Autres Tests de diverses solution pour lister dans un dialog perso des fichiers en filtrant par expression et extension

' Paramètres de recherche
    ' Expression dans la partie du nom
    partNom = Replace(TxtbExpression, "*", "%")
    extension = Replace(TxtbExtension, "*", "%")

Public Sub go_Click()
    Dim Chemin As String, partNom As String, Recurr As String, liste As String, extension As String, tempFile, X, i As Long, tim
    Dim m
    Const MSG_CHEMIN_VIDE As String = "Veuillez d'abord choisir un dossier parent à examiner"
    Const MSG_LISTE_VIDE As String = "La liste n'a pas pu être récupérée." & vbCrLf & _
                                      "Ou il n'y a pas de fichier avec cette extension" & vbCrLf & _
                                      "Vérifiez vos paramètres." & vbCrLf & _
                                      "Et éventuellement les autorisations de votre système pour le wscript."

    tempFile = Environ("userprofile") & "\desktop\temp_output.txt"

    ListBox1.Clear

    Chemin = TxtbFolder ' Le folder dans le textbox

    With ListBox1
        If Chemin = "" Then
            .AddItem MSG_CHEMIN_VIDE:
            .BackColor = &HC7BBA0
            .Enabled = False
            Exit Sub
        End If

        If Dir(Chemin, vbDirectory) = "" Then
            .AddItem "Ce dossier racine est introuvable": valeur = False:
            .BackColor = &HC7BBA0
            .Enabled = False
            Exit Sub
        End If
    End With

    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\" ' On prévoit le séparateur si nécessaire

    ' Paramètres de recherche
    ' Expression dans la partie du nom
    partNom = Replace(TxtbExpression, "*", "%")
    extension = Replace(TxtbExtension, "*", "%")

    'switch pour la récursivité
    If Checkrecursif = False Then
       'il ne doit pas  y avoir plus d'antislashs que le chemin de depart en non recursif
        X = Application.Rept("%\", UBound(Split(Chemin, "\")) + 1)
        Recurr = "AND System.ItemPathDisplay NOT LIKE '" & X & "%' "
    End If


    'Archive Octobre 2024 ;modèle patricktoulon  requete windowsearch V 4
    On Error GoTo ErrorHandler

    Dim Debut As Currency, Fin As Currency, Freq As Currency
    QueryPerformanceCounter Debut
    Dim objConnection As Object, objRecordset As Object
    Dim j As Integer
    Dim montableau, mess As String


    ' Création des objets ADODB
    Set objConnection = CreateObject("ADODB.Connection")
    Set objRecordset = CreateObject("ADODB.Recordset")


    ' Ouverture de la connexion
    objConnection.Open "Provider=Search.CollatorDSO;Extended Properties='Application=Windows';"
    ' Requête SQL avec les paramètres
    objRecordset.Open "SELECT System.ItemPathDisplay , System.ItemName, System.DateModified FROM SYSTEMINDEX " & _
                       "WHERE System.ItemPathDisplay LIKE '" & Chemin & "%' " & _
                       "AND System.ItemName LIKE '%" & partNom & "%' " & Recurr & _
                       "AND System.ItemName LIKE '%." & extension & "%'", objConnection

    ' Extraction des données et affichage
    If Not objRecordset.EOF Then
        montableau = objRecordset.GetRows()
        m = Transpose2dim(montableau)
    Else
        ReDim m(0) ' La ListBox accueille le split de la variable Liste
    End If

    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
    dt = Format(((Fin - Debut) / Freq), "0.000") & " s"

    With ListBox1
        If UBound(m) > 0 Then
            .List = Application.Index(m, 0, 1)
            labelcount = .ListCount & " Fichiers trouvés en " & dt
            .BackColor = vbWhite
        Else
            .List = Split(MSG_LISTE_VIDE, vbCrLf): ListBox1.Enabled = False
            .BackColor = &HC7BBA0
        End If
    End With
Cleanup:
    ' Fermeture des objets
    On Error Resume Next
    objRecordset.Close
    objConnection.Close
    Set objRecordset = Nothing
    Set objConnection = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "Erreur : " & Err.Description, vbCritical
    Resume Cleanup
End Sub

Sub test()
  
    ' Lancer le chronométrage pour la Sub test
    StartExecTimeMonitoring "démarrage de la sub test", report, debut, 1
  
    x = mafonction
    
    M_timer
    ' Afficher le rapport
    MsgBox report
End Sub

Sub test()
    
    ' Lancer le chronométrage pour la Sub test
    StartExecTimeMonitoring "démarrage de la sub test", report, debut, 1
    
    x = mafonction
      
     StopExecTimeMonitoring "fin de la sub test", report, debut, 1
 ' Afficher le rapport
    MsgBox report
End Sub