'*********************************************************************
' fonction Dir fichier par l'intermediaire d'un fichier BATH
'DIR fichier en ligne de commande(récursif)
'auteur: Patricktoulon et Dudu2 sur exceldownlods
'date:06/02/2021
'mise a jour
'date:07/02/2021:ajout de la correction des fichier dont le nom porte des caracteres spéciaux
'date :07/02/2021:intégration d'une boucle de transposition pour palier a la limite de transpose vba
'
'**********************************************************************
Option Explicit
Sub testDIRcmd()
[A1].CurrentRegion.Clear
Dim Racine$, tim#, T
Racine = "G:\_boulot\_5100 +++IMAGES +++++++++\041301 PHOTO id\*.jpg"
tim = Timer
T = ListFichierBath(Racine)
If IsArray(T) Then
[A1].Resize(UBound(T), 1).Value = T
MsgBox CDec(Timer - tim) & " seconde(s) pour " & UBound(T) & " fichier ou dossiers(s)"
Else: MsgBox "Pas de fichier avec cette extension "
End If
End Sub
Function ListFichierBath(Racine$, Optional Recycles As Boolean = False)
Dim laChaine$, x&, Fichier$, bat$, Commande$, tim#, tbl, tblV, I&, arr1, arr2, a&, doss
arr1 = Array("a`", "a^", "a¨", "e`", "e^", "e¨", "i`", "i^", "i¨", "o`", "o^", "o¨", "u`", "u^", "u¨") 'array caracteres séparés
arr2 = Array("à", "â", "ä", "è", "ê", "ë", "ì", "î", "ï", "ò", "ô", "ö", "ù", "û", "ü") 'array caracteres regroupés
bat = "C:\Users\polux\Desktop\baton.cmd" 'chemin du bath
Fichier = Environ("userprofile") & "\Desktop\list.txt" ' chemin du fichier liste
Commande = "chcp 1252 > nul" & vbCrLf & "dir """ & Racine & """ /S /B /A:-D >" & Fichier ' code la commande
x = FreeFile: Open bat For Output As #x: Print #x, Commande: Close #x 'creation du bath
ShellAndwaitingEndProcess bat 'appel fonction shell améliorée pour exécuter le bath
'lecture du fichier
x = FreeFile: Open Fichier For Binary Access Read As #x: laChaine = String(LOF(x), " "): Get #x, , laChaine: Close #x
'on fait le replace dans la chaine globale si defaut de caracteres present(plus rapide que le replace dans les ligne du tableau)
For a = 0 To UBound(arr1)
If InStr(1, laChaine, arr1(a)) Then laChaine = Replace(Replace(laChaine, arr1(a), arr2(a)), UCase(arr1(I)), UCase(arr2(I)))
Next
tbl = Split(laChaine, vbCrLf) 'coupe(array 1 dim)
If Not Recycles Then
For I = 0 To UBound(tbl)
If tbl(I) Like "*$RECYCLE*" Then laChaine = Replace(laChaine, tbl(I) & vbCrLf, "")
Next
tbl = Split(laChaine, vbCrLf) 'coupe(array 1 dim)
End If
'convert array 1 dim to 2 dim(transpose)
If laChaine <> vbNullString Then
ReDim tblV(UBound(tbl), 1 To 1): For I = 0 To UBound(tbl): tblV(I, 1) = tbl(I): Next
ListFichierBath = tblV
End If
Kill bat
Kill Fichier
End Function
Function ShellAndwaitingEndProcess(ByVal CheminComplet As String) As Long
Dim ProcessHandle&, ProcessId&
ProcessId = Shell(CheminComplet, vbHide)
ProcessHandle = ExecuteExcel4Macro("CALL(""Kernel32"",""OpenProcess"",""JJJJ"",""" & 2031616 & """,""" & 0 & """,""" & ProcessId & """)")
ShellAndwaitingEndProcess = ExecuteExcel4Macro("CALL(""Kernel32"",""WaitForSingleObject"",""JJJJJ"",""" & ProcessHandle & """,""" & &HF0000 & """)")
End Function
non?
