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), 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
Pourriez-vous m'aider ?
Je joins le fichier et voici ses codes :
Un grand merci pour votre aide
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
), 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
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
Dernière édition:
