Microsoft 365 Liste des fichiers dans le répertoire

[RollyLCXL]

Bonjour,

J'utilise le code sn = Split(CreateObject("wscript.shell").exec("cmd /c dir """ & F & """ /a:-d /b").StdOut.ReadAll, vbCrLf)

Et j'envoi la liste des fichiers du répertoire courant dans une feuille Excel avec le code ... .Resize(UBound(sn) + 1) = Application.Transpose(sn).

Tout se fait parfaitement sauf ceci. Des caractères sont remplacés. Par exemple un fichier nommé Nouveautés.pdf dans le répertoire est renommé Nouveaut,s.pdf.

Il semble que tous les accents sont remplacés par des autres caractères étranges.

Comment faire afin d'obtenir le nom tel que dans l'Explorateurs de Fichiers de Windows?

C'est que cette façon de faire est extrêmement plus rapide qu'avec un Loop.

Merci à l'avance.

 

[mapomme]

chez moi que je change ou pas le texte est au bon format

C'est très bien ça mais ce n'est pas le cas sur mon PC
Merci d'avoir essayé.

 

[mapomme]

@mapomme

ta méthode sur C:\Programme files
1er lancement 4.80 sec
2d lancement 1.51 sec

C'est énorme comme différence !

 

[patricktoulon]

oui c'est énorme c'est l'effet de cache on l'a remarqué dans la discussion de ma pseudo boite
et c'est pareil avec la methode run du shell pareil avec adobd requête sur le windows filesearch
et aussi avec le Dir de VBA

 

[patricktoulon]

@jurassic pork :testé chez moi ça ne fonctionne pas res est vide

 

[jurassic pork]

@jurassic pork :testé chez moi ça ne fonctionne pas res est vide

Avec le code de mon code de test ? moi je suis sous Windows 11 avec Excel 2021 et toi ?

 

[patricktoulon]

Windows 10/ office 2013 32 bits vba 7

 

[jurassic pork]

et avec un && et sans le > nul :

res = CreateObject("wscript.shell").exec("cmd /c chcp 1252   && cmd /c dir """ & F & """ /a:-d /b").StdOut.ReadAll

 

[mapomme]

Re @patricktoulon, @jurassic pork ,

Je viens de refaire les tests avec le code de @jurassic pork et celui de ma pomme (un peu plus verbeux, il faut bien que je l'avoue ).

A chaque fois, j'ai redémarré ma bécane pour être certain d'avoir vidé le cache. J'ai rajouté un "/S" à la commande de @jurassic pork pour aussi lister les sous-répertoires (comme pour mapomme) :

res = CreateObject("wscript.shell").exec("cmd /c chcp 1252 > nul  & cmd /c dir /s """ & F & """ /a:-d /b ").StdOut.ReadAll

Voici les résultats :

nota 1 : à la première exécution il ne semble pas y avoir d'effet de cache pour ma pomme (n'y aurait-il rien à cacher? ).

note 2 : après la première exécution, la durée des exécutions suivantes sont du même ordre de grandeur pour les deux méthodes.

Pour information, le code utilisé basée sur la version nippone de @jurassic pork :

Sub TestDir()
Dim F, sn, res As String, deb
   deb = Timer
   F = "C:\Program Files"
   res = CreateObject("wscript.shell").exec("cmd /c chcp 1252 > nul  & cmd /c dir /s """ & F & """ /a:-d /b ").StdOut.ReadAll
   sn = Application.Transpose(Split(res, vbCrLf))
   [a1].EntireColumn.ClearContents
   [a1].Resize(UBound(sn) + 1) = sn
   MsgBox Format(Timer - deb, "#,##0.##\ sec.")
End Sub

 

[patricktoulon]

j'essaie d'adapter à le recherche selective mais ça passe pas

Sub TestDir()
    Dim f$, sn, res As String, deb
    Dim tempFile$, TempString$, Expression$, Extension$, recurr$, Tim

    f = "k:\vba excel\" ' chemin à explorer

    Expression = "*cdo*" 'expression recherchée (on peut utiliser les jokers)

    Extension = "*.*" 'extension recherchée (on peut utiliser les jokers)

    'tempFile = ThisWorkbook.Path & "\output.txt" 'chemin du fichier temporaire


    recurr = " /S" ' récursivité

    TempString = " cmd /C dir """ & f & Expression & Extension & Chr(34) & recurr & " /a:-d /b "

    Debug.Print TempString
    deb = Timer

    f = "k:\vba excel"

    res = CreateObject("wscript.shell").exec("cmd /c chcp 1252 > nul " & TempString).StdOut.ReadAll

    sn = Application.Transpose(Split(res, vbCrLf))

    [a1].EntireColumn.ClearContents

    [a1].Resize(UBound(sn) + 1) = sn

    MsgBox Format(Timer - deb, "#,##0.##\ sec.")

End Sub

par contre avec mon fichier temps oui

Sub testbyfiletemp()
    Dim Chemin$, tempFile$, TempString$, Expression$, Extension$, recurr$, Tim
    
    Chemin = "k:\vba excel\" ' chemin à explorer
    
    Expression = "*é*è*" 'expression recherchée (on peut utiliser les jokers)
    
    Extension = "*.*" 'extension recherchée (on peut utiliser les jokers)
    
    tempFile = ThisWorkbook.Path & "\output.txt" 'chemin du fichier temporaire
    
    recurr = " /S" ' récursivité
    
    'string de la commande
    TempString = "cmd /C Dir """ & CStr(Chemin) & Expression & Extension & Chr(34) & recurr & " /b /a-d > """ & tempFile & Chr(34)

Debug.Print TempString
      
       Tim = Timer
    ' La variable Liste récupère le texte du stdout
    With CreateObject("Wscript.Shell")
        .Run "cmd /C chcp 1252", 0 ', True ' change le format du Dos
        .Run TempString, 0, True ' 0 = cacher la fenêtre, True = attendre que la commande se termine
    End With
    
    Do While Dir(tempFile) = "": DoEvents: Loop

    x = FreeFile: Open tempFile For Input As #x: liste = Input$(LOF(1), x): Close #x
    
    Tim = Format(Timer - Tim, """ en ""#0.000 ""Sec""")
    
    MsgBox Tim & vbCrLf & liste

End Sub

 

[mapomme]

Re @patricktoulon ,

Sur ma bécane :

• Procédure TestDir ne fonctionne pas
• Procédure testbyfiletemp fonctionne mais les accents sont incorrects

 

[jurassic pork]

Re @patricktoulon ,

Sur ma bécane :

• Procédure TestDir ne fonctionne pas

dans sa procédure TestDir patricktoulon a oublié le & dans la TempString :

TempString = " & cmd /C dir """ & f & Expression & Extension & Chr(34) & recurr & " /a:-d /b "

 

[jurassic pork]

Re @patricktoulon ,

Sur ma bécane :

• Procédure testbyfiletemp fonctionne mais les accents sont incorrects

Avec cette modif dans testbyfiletemp les accents sont corrects :

'string de la commande
    TempString = " & cmd /C Dir """ & CStr(Chemin) & Expression & Extension & Chr(34) & recurr & " /b /a-d > """ & tempFile & Chr(34)


Debug.Print TempString
    
       Tim = Timer
    ' La variable Liste récupère le texte du stdout
    With CreateObject("Wscript.Shell")
        .Run "cmd /C chcp 1252" & TempString, 0, True ' 0 = cacher la fenêtre, True = attendre que la commande se termine
    End With

Mais l'astuce nipponne ne semble pas fonctionner chez patrick
Les 2 run consécutifs dans le with ne fonctionnent pas chez moi non plus ( mauvais accents)

 

[patricktoulon]

re
si c'est bon ça fonctionne il faut faire attention au espaces en trop c'est tout
pour le coup la voila en petite fonction
j'ai essayé le utf-8 aussi c'est bon comme ça si il y a besoin

Sub Test_Cmd_DIR()
    Dim Liste, tim

    [a1].EntireColumn.ClearContents

    tim = Timer
    Liste = CmdDirList("k:\vba excel\", "*cdo*", "*.xl*", True) '(1252 ou omis = normal / 65001 utf-8)
    tim = Format(Timer - tim, "#,##0.##\ sec.")

    [a1].Resize(UBound(Liste)) = Application.Transpose(Liste)

    MsgBox tim

End Sub

Function CmdDirList(lFolder$, _
                    Optional Expression As String = "*", _
                    Optional Extension As String = "*.*", _
                    Optional Recursif As Boolean = False, _
                    Optional TextFormat As Long = 1252)
    
    'CmdDirList V 2.7(StdOut.ReadAll)
    '@patricktoulon
    '@jurassic pork
    '@mapomme
    Dim sn, res$, CHCP&, TempString$, recurr$

    If Right(lFolder, 1) <> "\" Then lFolder = lFolder & "\"

    If Recursif Then recurr = " /S" ' récursivité

    TempString = "& cmd /C dir """ & lFolder & Expression & Extension & Chr(34) & recurr & " /a:-d /b "

    Debug.Print TempString

    res = CreateObject("wscript.shell").exec("cmd /c chcp " & TextFormat & " > nul " & TempString).StdOut.ReadAll

    If res <> "" Then

        CmdDirList = Split(res, vbCrLf)

        Else: res = Array("")

    End If
End Function

 

[patricktoulon]

re
@jurassic pork , @mapomme
bon ben voila
la preuve en 5 minutes Chrono que le fait que l'on croit qu'avec le stDout.ReadAll , c'est plus rapide est faux et archi faux
recherche de tout fichier dans K:vba excel\

je ne raconte pas d'histoire la video parle d'elle même

 

[RollyLCXL]

Bonjour,

Un ... énorme merci. Le code ci-dessous fonctionne parfaitement aussi chez moi et cela répond parfaitement au besoin.

Je suis vieux aussi ... Je ne croyais pas y arriver car j'avais fais beaucoup de recherche. Je suis impressionné. Vraiment encore merci à vous.

Private Declare PtrSafe Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Sub TestDir()
Dim F, sn, res As String
F = "d:\dev\office\excel"
res = CreateObject("wscript.shell").exec("cmd /c dir """ & F & """ /a:-d /b").StdOut.ReadAll
OemToChar res, res
sn = Split(res, vbCrLf)
End Sub