Microsoft 365 lister des fichiers

Usine à gaz

XLDnaute Barbatruc
Bonsoir à toutes et à tous :)

Je bute (comme tjr) sur un code que je voudrais modifier.
Ce code a été donné sur notre Forum et je n'avais pas pris le lien du fil (Grrrrr à moi :mad:), du coup je remercie "le soldat inconnu" de moi :)
Il fonctionne très bien et donne la liste des fichiers avec le chemin et les liens.

J'ai deux besoins :
1 - Qu'il me donne uniquement les noms des fichiers avec leurs liens (sans le chemin),
2 - Dans mon fichier, je vais mettre des commentaires à droite des noms des fichiers
--- Serait-il possible à l'ajout de fichiers dans le dossier, qu'à la mise à jour le code ajoute les nouveaux fichiers après ceux existants ?
Cela m'éviterait de perdre mes commentaires et/ou des décalages ou mélanges.

Vu mon niveau "d'ExpertDeRien", j'ai tenté de voir mais j'ai rien vu lol :D
Pourriez-vous m'aider ?
Je joins le fichier et voici ses codes :
VB:
Option Explicit
Option Compare Text

'---------------------------------------------------------------
'Liste des fichiers de l'arborescence complète d'un répertoire
'par la "méthode FileSystemObject"
'
'- NomRépertoire: chaine du nom du répertoire concerné
'                 (avec ou sans '\' final)
'
'- NoRecycle: True (valeur par défaut) pour ne pas avoir les
'             fichiers de la poubelle dans la liste résultat
'             si NomRépertoire est une lettre de lecteur (drive)
'
'- Extension: "Pattern" / modèle de l'extension des fichiers à
'             sélectionner ("txt", "xls*" ou "" pour tous)
'
'- DateCréation: True retourne la date de création en 2ème
'                     dimension
'
'- DateModification: True retourne la date de Modification en
'                    2ème dimension
'
'- Taille: True retourne la taille en 2ème dimension
'
'- Return: Table à 1 dimension des noms complets des fichiers
'          Table à 2 dimensions si DateCréation = True,
'                            et/ou DateModification = True,
'                            et/ou Taille = True.
'          ou False si aucun fichier dans le répertoire
'---------------------------------------------------------------
Function FichiersRépertoireFSO(ByVal NomRépertoire As Variant, _
                               Optional SousRépertoires As Boolean = True, _
                               Optional NoRecycle As Boolean = True, _
                               Optional Extension As String = "", _
                               Optional DateCréation As Boolean = False, _
                               Optional DateModification As Boolean = False, _
                               Optional Taille As Boolean = False) As Variant
                            
    'Tableau résultat static pour être indépendant des appels récursifs
    Static TabFichiers() As String
    Static NbFichiers As Long
    Static Dimension2 As Integer
    Static Dimension2DateCréation As Integer
    Static Dimension2DateModification As Integer
    Static Dimension2Taille As Integer
  
    'Variable du FileSystemObject commune à toutes les instances de la fonction
    Static oFSO As Object
  
    'Variable spécifiques à une instance de la fonction
    Dim oDir As Object
    Dim oSubDir As Object
    Dim oFile As Object
    Dim InitialCall As Boolean
    Dim TakeIt As Boolean
    Dim NomObjetEnErreur As String
  
    'Appel recursif de cette fonction (par elle-même ci-dessous)
    If TypeOf NomRépertoire Is Object  Then
        InitialCall = False
      
        'Valorise l'objet Folder
        Set oDir = NomRépertoire
  
    'Appel initial
    Else
         InitialCall = True
      
        'Table résultat
        Erase TabFichiers
        NbFichiers = 0
        Dimension2 = IIf(DateCréation, 1, 0) + IIf(DateModification, 1, 0) + IIf(Taille, 1, 0)
        If Dimension2 > 0 Then
            Dimension2 = 1 + Dimension2
            Dimension2DateCréation = 1 + IIf(DateCréation, 1, 0)
            Dimension2DateModification = Dimension2DateCréation + IIf(DateModification, 1, 0)
            Dimension2Taille = Dimension2DateModification + IIf(Taille, 1, 0)
        End If
      
        'File System Object
        Set oFSO = CreateObject("Scripting.FileSystemObject")
      
        'Complémente éventuellement le nom du répertoire avec '\'
        If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"
      
        'Valorise l'objet Folder
        Set oDir = oFSO.GetFolder(NomRépertoire)
    End If
  
    'Si option NoRecycle et répertoire poubelle on ne traite pas
    If NoRecycle And Len(oDir.Name) = 12 Then
        If UCase(oDir.Name) = "$RECYCLE.BIN" Then Exit Function
    End If
  
    'Si le répertoire est "System Volume Information" on ne traite pas
    If oDir.Name = "System Volume Information" Then Exit Function
  
    'Vérifie si le répertoire contient des fichiers avec l'extension
    If Len(Extension) = 0 Then
        TakeIt = True
    Else
         'Il faut couvrir la fonction Dir() par un On Error pour intercepter ses erreurs:
        'Erreur #52:
        '> Accès refusé
        '> Un ou plusieurs caractères du nom du répertoire sont codés en Unicode
        'Erreurs #53:
        '> La longueur du chemin est > longueur maxi
        'Erreurs qui sinon vont se manifester ultérieurement dans la boucle "For Each oSubDir In oDir.subfolders".
        On Error Resume Next
        TakeIt = Len(Dir(oDir.Path & "\*." & Extension)) > 0
        If Err.Number <> 0 Then TakeIt = True
        On Error GoTo 0
    End If

    'On n'examine les fichiers du répertoire que s'il contient des fichiers avec l'extension
    If TakeIt Then
        On Error Resume Next
        For Each oFile In oDir.Files
            If Err.Number = 0 Then
                'Test si correspondance de l'extension
                If Len(Extension) = 0 Then
                    TakeIt = True
                Else
                    If oFSO.GetExtensionName(oFile.Name) Like Extension Then TakeIt = True Else TakeIt = False
                End If
              
                'Stocke le nom complet du fichier en table
                If TakeIt Then
                    NbFichiers = NbFichiers + 1
                    If Dimension2 = 0 Then
                        ReDim Preserve TabFichiers(1 To NbFichiers)
                        TabFichiers(NbFichiers) = oFile.Path
                    Else
                        ReDim Preserve TabFichiers(1 To Dimension2, 1 To NbFichiers)
                        TabFichiers(1, NbFichiers) = oFile.Path
                        'Récupère la date de création
                        If DateCréation Then TabFichiers(Dimension2DateCréation, NbFichiers) = oFile.DateCreated
                        'Récupére la date de dernière modification
                        If DateModification Then TabFichiers(Dimension2DateModification, NbFichiers) = oFile.DateLastModified
                        'Récupére la taille du fichier
                        If Taille Then TabFichiers(Dimension2Taille, NbFichiers) = Left(oFile.Size, 10)
                    End If
                End If
          
            'Fichier en erreur
            Else
                NomObjetEnErreur = "Fichier <"
                If oFile Is Nothing _
                Then NomObjetEnErreur = NomObjetEnErreur & "Nothing" & ">" _
                Else NomObjetEnErreur = NomObjetEnErreur & oFile.Name & ">"
                GoSub TraiteErreur
            End If
        Next oFile
        On Error GoTo 0
    End If
  
    If SousRépertoires Then
        'Parcours des sous-répertoires du répertoire en cours
        On Error Resume Next
        For Each oSubDir In oDir.subfolders
            If Err.Number = 0 Then
                'Appels recursifs identifiés par le type Object de l'argument OsubDir
                 Call FichiersRépertoireFSO(oSubDir, SousRépertoires, NoRecycle, Extension, DateCréation, DateModification, Taille)
          
            'Répertoire en erreur
            Else
                NomObjetEnErreur = "Répertoire <"
                If oSubDir Is Nothing _
                Then NomObjetEnErreur = NomObjetEnErreur & "Nothing" & ">" _
                Else NomObjetEnErreur = NomObjetEnErreur & oSubDir.Path & ">"
                GoSub TraiteErreur
            End If
        Next oSubDir
        On Error GoTo 0
    End If
  
    'Return value
    If InitialCall Then
        If NbFichiers > 0 Then
            If Dimension2 = 0 Then
                FichiersRépertoireFSO = TabFichiers
            Else
                FichiersRépertoireFSO = Transpose(TabFichiers)
            End If
        Else
            FichiersRépertoireFSO = False
        End If
    End If
    Exit Function
  
TraiteErreur:
    Select Case Err.Number
        'Error #70 Authorisation refusée
        Case 70
            MsgBox "Accès refusé pour le fichier <" & NomObjetEnErreur & ">."
          
        'Error #76 Path not found - Cas des noms de répertoires ou fichiers dont le chemin complet > Maximum (247, 259)
        Case 76
            MsgBox "Nom trop long pour le fichier <" & NomObjetEnErreur & ">."
      
        'Autre erreur à identifier ?
        Case Else
            MsgBox "FichiersRépertoireFSO erreur #" & Err.Number & vbCrLf & "Sur " & NomObjetEnErreur & ""
    End Select
  
    NomObjetEnErreur = ""
    Err.Clear
    Return
End Function

'---------
'Transpose
'---------
Private Function Transpose(t As Variant) As Variant
    Dim tt() As Variant
    Dim i As Long
    Dim j As Long
  
    ReDim tt(LBound(t, 2) To UBound(t, 2), LBound(t, 1) To UBound(t, 1))
  
    For i = LBound(t, 2) To UBound(t, 2)
        For j = LBound(t, 1) To UBound(t, 1)
            tt(i, j) = t(j, i)
        Next j
    Next i
  
    Transpose = tt
End Function
Code:
Option Explicit
Sub ListerLesFichiers()
    Dim TabFichiers As Variant
    Dim Répertoire As String
    Dim i As Long
  
    Répertoire = [a1].Value
  
    TabFichiers = FichiersRépertoireFSO(Répertoire)
    'ActiveSheet.Columns(1).ClearContents
                                      
    If VarType(TabFichiers) = vbBoolean Then
        MsgBox "Aucun fichier en répertoire <" & Répertoire & ">"
    Else
        If UBound(TabFichiers) <= 65535 Then
            ActiveSheet.[A2].Resize(UBound(TabFichiers), 2).Value = Application.Transpose(TabFichiers)
        Else
            ActiveSheet.[A2].Value = "Utiliser un Transpose codé."
        End If
    End If
  
    For i = 1 To UBound(TabFichiers, 1)
        'Ajoute l'Hyperlien
        ActiveSheet.Hyperlinks.Add Anchor:=[A2].Offset(i - 1), _
                                   Address:=[A2].Offset(i - 1).Value
    Next i
  
    Columns("B:B").Delete Shift:=xlToLeft
    '[a1] = [a1].Value
End Sub
Un grand merci pour votre aide
:)
 

Pièces jointes

  • ListerLesFichiers.xlsm
    34.1 KB · Affichages: 11
Dernière édition:
Solution
c'est le cas.
Je veux bien lol
:)
Tu vois Lionel ton problème c'est que tu télécharges n'importe quoi, même les usines à gaz :oops:

Télécharge les fichiers joints dans le même dossier (le bureau) et ouvre le fichier .xlsm.

La macro affectée au bouton :
VB:
Sub MAJ()
Dim chemin$, fichier$, lig&
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Application.ScreenUpdating = False
With ActiveSheet.Columns(1) 'feuille et colonne à adapter
    lig = .Cells(Rows.Count).End(xlUp).Row + 1
    While fichier <> ""
        If fichier <> ThisWorkbook.Name And IsError(Application.Match(fichier, .Cells, 0)) Then
            .Parent.Hyperlinks.Add .Cells(lig), chemin & fichier...

patricktoulon

XLDnaute Barbatruc
re
Bonjour Lionel
moi je sais pourquoi tu n'y arrive pas

tu développe ton App au fur et à mesure de ton envie (voir besoin)

tu n'a donc aucune anticipation dans le suivie de ton projet

ce qui fait que tes logique de conception sont faussées

un projet ça s'imagine ,ça se couche sur papier(préambule , organigramme , étape , méthode , conclusion )et avant de coder la moindre ligne

alors oui ta façon ne peut pas t'apporter la logique nécessaire à une bonne conception

tes résultats
forcement des méthodes alambiquées qui sont sans cesse modifiées ou patchées pour correspondre a l'intention ( tu nous l'a montré plusieurs fois)
au bout d'un moment , tu te retrouve dans une inextricable situation ou tu ne peux ni avancer ou reculer


je ne te dis pas cela pour te saquer
c'est en toute amitié que je te le dis

bon on l'aime comme comme ça notre petite usine ;)
on se marre bien des fois
 

Usine à gaz

XLDnaute Barbatruc
re
Bonjour Lionel
moi je sais pourquoi tu n'y arrive pas

tu développe ton App au fur et à mesure de ton envie (voir besoin)

tu n'a donc aucune anticipation dans le suivie de ton projet

ce qui fait que tes logique de conception sont faussées

un projet ça s'imagine ,ça se couche sur papier(préambule , organigramme , étape , méthode , conclusion )et avant de coder la moindre ligne

alors oui ta façon ne peut pas t'apporter la logique nécessaire à une bonne conception

tes résultats
forcement des méthodes alambiquées qui sont sans cesse modifiées ou patchées pour correspondre a l'intention ( tu nous l'a montré plusieurs fois)
au bout d'un moment , tu te retrouve dans une inextricable situation ou tu ne peux ni avancer ou reculer


je ne te dis pas cela pour te saquer
c'est en toute amitié que je te le dis

bon on l'aime comme comme ça notre petite usine ;)
on se marre bien des fois
Bjr Patrick :)
Evidemment, je prends ton message comme une chaleureuse et amicale remarque constructive.
Depuis le temps que nous échangeons, de disputes en gentillesses, nous commençons à connaître nos caractères et les cœurs amicaux derrière les mots et je t'en remercie :)

Mais je crois que mon souci n'est pas uniquement là.
J'ai toujours pour habitude de faire "un plan" avant de me lancer sur un nouveau fichier.
Toutefois, il est vrai qu'au fil du temps, d'autres besoins apparaissent.
Je n'ai aucune formation en vba et je ne parle même pas un seul mot d'anglais.
J'aimerais bien apprendre et j'ai déjà énormément appris avec toi et nos autres chers ténors.
Avec l'âge, il est de plus en plus difficile d'apprendre lol 🙃
Je suis souvent en mesure de "bidouiller" des codes pour les adapter à mes besoins.

Dans le cas présent, @Dudu2 n'avait pas fait ce code pour moi et bien que je l'ai lu et relu, je n'y comprends rien "queue d'ail - qeutchi".
:)
 

patricktoulon

XLDnaute Barbatruc
re
pour comprendre le code de @Dudu2
il te faut bucher la/les librairie(s) utilisée en l’occurrence ici FSO
quelle sont ses fonctions et propertie utilisable et comment
après tu verra que le code de @Dudu2 est simple comme tout

nous avons travaillé ensemble sur ce raisonnement avec @dudu2(longue discussion)
le projet était liste récursive FSO au moins aussi rapide que dir

sur la fin nous avons divergé lui utilise une variable takeit pour jumper tout ce qui n'est pas nécessaire moi je jump directement

c'est ce jump justement qui nous permet d’accélérer
le test dir permet de savoir si la boucle ofile va être effectuée ou pas

nous avons aussi divergé sur l'utilisation de l'argument extension moi c'est part name
qui me donne la possibilité non seulement de sélectionner les extensions mais aussi une partie de nom

ensuite il a ajouter pour un autre membre me semble t il le getdetail des fichiers
comme je suis un éternel fainéant je n'aurais pas inclue çà moi, je l'aurais fait séparément
histoire d'avoir deux fonctions réutilisables

il faudrait que l'on retrouve cette discussion et que tu la lise de bout en bout pour que tu en comprenne le fonctionnement

oui tres trs longue discussion qui n’était pas la notre au départ d'ailleurs
 

Usine à gaz

XLDnaute Barbatruc
re
pour comprendre le code de @Dudu2
il te faut bucher la/les librairie(s) utilisée en l’occurrence ici FSO
quelle sont ses fonctions et propertie utilisable et comment
après tu verra que le code de @Dudu2 est simple comme tout

nous avons travaillé ensemble sur ce raisonnement avec @dudu2(longue discussion)
le projet était liste récursive FSO au moins aussi rapide que dir

sur la fin nous avons divergé lui utilise une variable takeit pour jumper tout ce qui n'est pas nécessaire moi je jump directement

c'est ce jump justement qui nous permet d’accélérer
le test dir permet de savoir si la boucle ofile va être effectuée ou pas

nous avons aussi divergé sur l'utilisation de l'argument extension moi c'est part name
qui me donne la possibilité non seulement de sélectionner les extensions mais aussi une partie de nom

ensuite il a ajouter pour un autre membre me semble t il le getdetail des fichiers
comme je suis un éternel fainéant je n'aurais pas inclue çà moi, je l'aurais fait séparément
histoire d'avoir deux fonctions réutilisables

il faudrait que l'on retrouve cette discussion et que tu la lise de bout en bout pour que tu en comprenne le fonctionnement

oui tres trs longue discussion qui n’était pas la notre au départ d'ailleurs
Merci Patrick pour ce retour :)
Je verrai ce soir et je tenterai de comprendre :)
 

patricktoulon

XLDnaute Barbatruc
re
Bonjour @job75
oui avec DIR et ma fonction de correction des caractères bizarres ou qui ressortent bizarre de certains fichiers( je sais plus ou je l'ai mis cette fonction )
exemple tout les fichiers
VB:
dim mondossier,f$
mondossier="c:\.....")
f=dir(mondossier &"\*.*)
do while f <>""
debug.print mondossier & "\" & f
f=dir
loop
 

job75

XLDnaute Barbatruc
c'est le cas.
Je veux bien lol
:)
Tu vois Lionel ton problème c'est que tu télécharges n'importe quoi, même les usines à gaz :oops:

Télécharge les fichiers joints dans le même dossier (le bureau) et ouvre le fichier .xlsm.

La macro affectée au bouton :
VB:
Sub MAJ()
Dim chemin$, fichier$, lig&
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xls*") '1er fichier du dossier
Application.ScreenUpdating = False
With ActiveSheet.Columns(1) 'feuille et colonne à adapter
    lig = .Cells(Rows.Count).End(xlUp).Row + 1
    While fichier <> ""
        If fichier <> ThisWorkbook.Name And IsError(Application.Match(fichier, .Cells, 0)) Then
            .Parent.Hyperlinks.Add .Cells(lig), chemin & fichier, TextToDisplay:=fichier 'crée le lien
            lig = lig + 1
        End If
        fichier = Dir 'fichier suivant
    Wend
    .Resize(, 2).AutoFit 'ajustement largeurs
End With
End Sub
 

Pièces jointes

  • Liste fichiers.xlsm
    18.2 KB · Affichages: 22
  • Bonjour.xlsx
    8.6 KB · Affichages: 9
  • Forum.xlsx
    8.6 KB · Affichages: 8

Usine à gaz

XLDnaute Barbatruc
Bonsoir Gérard :)
Encore merci et j'espère que tous pourront te dire MERCI encore TRES longtemps.
"Tu vois Lionel ton problème c'est que tu télécharges n'importe quoi, même les usines à gaz"
ça c'est ben vrai comme disait "une copine" :D

Au top, comme toujours c'est nickel.
Merci Gérard,
:)
 

Discussions similaires

Réponses
1
Affichages
113

Statistiques des forums

Discussions
313 309
Messages
2 097 036
Membres
106 816
dernier inscrit
Garry972