Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Lister le contenu d'un Répertoire avec lien Hypertexte

Lister le contenu d'un Répertoire avec lien Hypertexte

7 réponses
Avatar
BlackStorm
Bonsoir,

Voila, je vous pose mon problème : je gère un Intranet.
Lorsque j'ajoute de la documentation , je crée un lien Hypetexte pour
chacun des ces documents (Word, Excek, PDF...) ce qui prend énormément
de temps. Sous Excel, j'aimerai que celui-ci 'Liste l'ensemble des
fichiers contenus dans un répertoire spécifique (en utilisant un bouton
de commande) et qu'il dresse une liste classée par ordre alpha (date
d'enregistrement du document, taille, date de sa derniere
consultation...). Je veux que l'utilisateur puisse lire le fichier
désirez en cliquant alors sur ce lien hypertexte.

J'ai trouvé des appli Excel qui font cela mais je veux limiter le
listage des dossiers à des répertoires spécifiques : ex k:\Dossier
Compta\Clients\

Je vous remercie d'avance pour votre aide et pour le temps que vous
consacrez à aider les autres
BlackStorm
Signaler un problème avec ce contenu

7 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
MichDenis
Tu adapteras ce que tu veux faire avec tes liens hypertextes !



Sub TousFichiersDunDossier()
Dim FSO As Object, Dossier As Object, NomDossier
Dim Files As Object, File As Object, i As Integer
Dim Sh As Worksheet
Dim EnTetes, ArrFSO

Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
'adapter le dossier racine si besoin
NomDossier = ChoixDossierFichier("")
If NomDossier = "" Then Exit Sub
Set Dossier = FSO.GetFolder(NomDossier)

Set Files = Dossier.Files
If Files.Count <> 0 Then
Set Sh = Sheets.Add
EnTetes = Array("Chemin", "Nom", _
"Date création", "Date dernière modification", _
"Date dernier accès", "Taille", "Type", "Attribut(s)")
'mise en forme
With ActiveSheet.Range("A1:H1")
.Value = EnTetes
.Font.Bold = True
.Interior.ColorIndex = 43
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
i = 1
For Each File In Files
i = i + 1
With File
ArrFSO = Array(.ParentFolder & "", .Name, .DateCreated, _
.DateLastModified, .DateLastAccessed, .Size, .Type)
End With
Sh.Cells(i, 1). _
Resize(1, UBound(ArrFSO) - LBound(ArrFSO) + 1).Value = ArrFSO
Sh.Cells(i, UBound(ArrFSO) + 2).Value = Attributs(File.Attributes)
Next
End If
Sh.UsedRange.EntireColumn.AutoFit
Set FSO = Nothing: Set Sh = Nothing
Set Dossier = Nothing: Set File = Nothing
End Sub

Function Attributs(Attrib)
Dim Res$
If Attrib = 0 Then Res = "Aucun attribut"
If Attrib And 1 Then Res = Res & "/Lecture seule"
If Attrib And 2 Then Res = Res & "/Caché"
If Attrib And 4 Then Res = Res & "/Système"
If Attrib And 32 Then Res = Res & "/Archive"
Attributs = Res
End Function

Function ChoixDossierFichier(Racine, Optional SelType As Byte = 0)
Dim objShell, objFolder, Chemin, SecuriteSlash, FlagChoix&, Msg$

If SelType = 0 Then
FlagChoix = &H1&: Msg = "Choisissez un dossier :"
Else
FlagChoix = &H4000&: Msg = "Choisissez un fichier :"
End If

Set objShell = CreateObject("Shell.Application")
'le troisième paramètre permet de choisir
'la sélection d'un dossier ou d'un fichier (0 ou 1)
'le dernier paramètre permet de choisir le dossier racine
Set objFolder = objShell.BrowseForFolder(&H0&, Msg, FlagChoix, Racine)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
Chemin = "C:WindowsBureau"
End If
If objFolder.Title = "" Then
Chemin = ""
End If

SecuriteSlash = InStr(objFolder.Title, ":")

If SecuriteSlash > 0 Then
Chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If
ChoixDossierFichier = Chemin
End Function







"BlackStorm" a écrit dans le message de news:
4524049c$0$292$
Bonsoir,

Voila, je vous pose mon problème : je gère un Intranet.
Lorsque j'ajoute de la documentation , je crée un lien Hypetexte pour
chacun des ces documents (Word, Excek, PDF...) ce qui prend énormément
de temps. Sous Excel, j'aimerai que celui-ci 'Liste l'ensemble des
fichiers contenus dans un répertoire spécifique (en utilisant un bouton
de commande) et qu'il dresse une liste classée par ordre alpha (date
d'enregistrement du document, taille, date de sa derniere
consultation...). Je veux que l'utilisateur puisse lire le fichier
désirez en cliquant alors sur ce lien hypertexte.

J'ai trouvé des appli Excel qui font cela mais je veux limiter le
listage des dossiers à des répertoires spécifiques : ex k:Dossier
ComptaClients

Je vous remercie d'avance pour votre aide et pour le temps que vous
consacrez à aider les autres
BlackStorm
Avatar
BlackStorm
Merci pour votre réponse... mais puis je abuser de votre aide ?

J'ai une double demande:
1°) Que je puisse 'bloquer' le choix du répertoire à lister pour éviter
des mauvais choix quant à la selection
2°) Que les resultats trouvés et affichés soit en fait des liens ,
hypertexte, qui fassent qu'en cliquant dessus, je puisse lire
directement un document word, excel, pdf...

merci encore pour votre aide aussi précieuse
Avatar
Michel Pierron
Bonsoir BlackStorm;
Quelque chose comme (dans un module standard):

Sub Listing()
Const Folder$ = "k:DossierComptaClients"
If Dir(Folder, vbDirectory) = "" Then Exit Sub
Dim Headers(5), x%, y&, i&, p$, n$, oFile As Object
Dim objShell As Object, oFolder As Object
Set objShell = CreateObject("Shell.Application")
Set oFolder = objShell.Namespace(CStr(Folder))
Application.ScreenUpdating = False
Workbooks.Add
For i = 0 To 5
Headers(i) = oFolder.GetDetailsOf(oFolder.Items, i)
Select Case i
Case 0 To 1, 3 To 5: x = x + 1: Cells(1, x) = Headers(i)
End Select
Next
y = 1
For Each oFile In oFolder.Items
p = oFile.Path: n = oFile.Name
Select Case Right$(n, 4)
Case ".xls", ".doc", ".pdf"
x = 0: y = y + 1
For i = 0 To 5
Select Case i
Case 0 To 1, 3 To 5
x = x + 1
Cells(y, x) = oFolder.GetDetailsOf(oFile, i)
With ActiveSheet
.Hyperlinks.Add .Range("A" & y), Hlink(p), , n, n
End With
End Select
Next
End Select
Next
Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Font.Bold = True
Cells.Columns.AutoFit
Columns("B:E").HorizontalAlignment = xlCenter
Range("A1").Select
Set oFolder = Nothing: Set objShell = Nothing
End Sub

Private Function Hlink(p As String) As String
Hlink = "file:///" & Replace(Replace(p, " ", "%20"), "", "/")
End Function

MP

"BlackStorm" a écrit dans le message de news:
4524049c$0$292$
Bonsoir,

Voila, je vous pose mon problème : je gère un Intranet.
Lorsque j'ajoute de la documentation , je crée un lien Hypetexte pour
chacun des ces documents (Word, Excek, PDF...) ce qui prend énormément de
temps. Sous Excel, j'aimerai que celui-ci 'Liste l'ensemble des fichiers
contenus dans un répertoire spécifique (en utilisant un bouton de
commande) et qu'il dresse une liste classée par ordre alpha (date
d'enregistrement du document, taille, date de sa derniere
consultation...). Je veux que l'utilisateur puisse lire le fichier désirez
en cliquant alors sur ce lien hypertexte.

J'ai trouvé des appli Excel qui font cela mais je veux limiter le listage
des dossiers à des répertoires spécifiques : ex k:Dossier ComptaClients

Je vous remercie d'avance pour votre aide et pour le temps que vous
consacrez à aider les autres
BlackStorm


Avatar
MichDenis
En dessous de cette ligne de code, inscrit le nom du
chemin où tu veux voir ouvrir l'explorateur :

'ADAPTER LE CHEMIN OÙ DOIT S'OUVRIR L'EXPLORATEUR DE DOSSIERS


'-----------------------------------------
Sub TousFichiersDunDossier()
Dim FSO As Object, Dossier As Object, NomDossier
Dim Files As Object, File As Object, i As Integer
Dim Sh As Worksheet
Dim EnTetes, ArrFSO

Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
'ADAPTER LE CHEMIN OÙ DOIT S'OUVRIR L'EXPLORATEUR DE DOSSIERS
NomDossier = ChoixDossier("d:Base de données")
If NomDossier = "" Then Exit Sub
Set Dossier = FSO.GetFolder(NomDossier)

Set Files = Dossier.Files
If Files.Count <> 0 Then
Set Sh = Sheets.Add
EnTetes = Array("Chemin", "Nom", _
"Date création", "Date dernière modification", _
"Date dernier accès", "Taille", "Type", "Attribut(s)")
'mise en forme
With ActiveSheet.Range("A1:H1")
.Value = EnTetes
.Font.Bold = True
.Interior.ColorIndex = 43
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
i = 1
For Each File In Files
i = i + 1
With File
ArrFSO = Array(.ParentFolder & "", .Name, .DateCreated, _
.DateLastModified, .DateLastAccessed, .Size, .Type)
End With
Sh.Cells(i, 1). _
Resize(1, UBound(ArrFSO) - LBound(ArrFSO) + 1).Value = ArrFSO
Sh.Cells(i, UBound(ArrFSO) + 2).Value = Attributs(File.Attributes)
Next
End If
With Sh
Set rg = .Range("B2:B" & .Range("B65536").End(xlUp).Row)
End With
For Each c In rg
Sh.Hyperlinks.Add c, c.Offset(, -1) & c, , c.Offset(, -1) & c
Next
Sh.UsedRange.EntireColumn.AutoFit
Set FSO = Nothing: Set Sh = Nothing
Set Dossier = Nothing: Set File = Nothing
End Sub
'-----------------------------------------
Function Attributs(Attrib)
Dim Res$
If Attrib = 0 Then Res = "Aucun attribut"
If Attrib And 1 Then Res = Res & "/Lecture seule"
If Attrib And 2 Then Res = Res & "/Caché"
If Attrib And 4 Then Res = Res & "/Système"
If Attrib And 32 Then Res = Res & "/Archive"
Attributs = Res
End Function
'-----------------------------------------
Function ChoixDossier(Chemin)
Dim objShell, objFolder
Msg = "Voici votre répertoire:"
Set objShell = CreateObject("Shell.Application")

'Cette ligne affiche répertoire et fichiers du répertoire.
Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H4000, Chemin)

'Cette Ligne = pour afficher seulement les répertoires
'Set objFolder = objShell.BrowseForFolder(&H0&, Msg, &H1&, Chemin)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
ChoixDossier = Chemin

End Function
'-----------------------------------------
Avatar
BlackStorm
Encore un grand merci à vous tous !!

N'étant pas un grand spécialiste d'Excel, j'ai peur d'être un peu
stupide, mais Michel Pierron, je colle ou le module (est-il indépendant
? ou se rajoute-il aux lignes de codes ?)


Sub Listing()
Const Folder$ = "k:DossierComptaClients"
If Dir(Folder, vbDirectory) = "" Then Exit Sub
Dim Headers(5), x%, y&, i&, p$, n$, oFile As Object
Dim objShell As Object, oFolder As Object
Set objShell = CreateObject("Shell.Application")
Set oFolder = objShell.Namespace(CStr(Folder))
Application.ScreenUpdating = False
Workbooks.Add
For i = 0 To 5
Headers(i) = oFolder.GetDetailsOf(oFolder.Items, i)
Select Case i
Case 0 To 1, 3 To 5: x = x + 1: Cells(1, x) = Headers(i)
End Select
Next
y = 1
For Each oFile In oFolder.Items
p = oFile.Path: n = oFile.Name
Select Case Right$(n, 4)
Case ".xls", ".doc", ".pdf"
x = 0: y = y + 1
For i = 0 To 5
Select Case i
Case 0 To 1, 3 To 5
x = x + 1
Cells(y, x) = oFolder.GetDetailsOf(oFile, i)
With ActiveSheet
.Hyperlinks.Add .Range("A" & y), Hlink(p), , n, n
End With
End Select
Next
End Select
Next
Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Font.Bold = True
Cells.Columns.AutoFit
Columns("B:E").HorizontalAlignment = xlCenter
Range("A1").Select
Set oFolder = Nothing: Set objShell = Nothing
End Sub

Private Function Hlink(p As String) As String
Hlink = "file:///" & Replace(Replace(p, " ", "%20"), "", "/")
End Function
Avatar
Michel Pierron
Re BlackStorm;
La procédure Listing correspond à celle qui doit être exécutée lors d'un
clique sur ton bouton de commande.
Cette procédure crée un nouveau classeur contenant la liste des fichiers
contenus dans le répertoire indiqué sous forme de liens hypertextes. Lorsque
l'utilisateur clique sur un lien hypertexte, cela entraîne l'ouverture du
fichier correspondant.

MP

"BlackStorm" a écrit dans le message de news:
4524282a$0$9495$
Encore un grand merci à vous tous !!

N'étant pas un grand spécialiste d'Excel, j'ai peur d'être un peu stupide,
mais Michel Pierron, je colle ou le module (est-il indépendant ? ou se
rajoute-il aux lignes de codes ?)


Sub Listing()
Const Folder$ = "k:DossierComptaClients"
If Dir(Folder, vbDirectory) = "" Then Exit Sub
Dim Headers(5), x%, y&, i&, p$, n$, oFile As Object
Dim objShell As Object, oFolder As Object
Set objShell = CreateObject("Shell.Application")
Set oFolder = objShell.Namespace(CStr(Folder))
Application.ScreenUpdating = False
Workbooks.Add
For i = 0 To 5
Headers(i) = oFolder.GetDetailsOf(oFolder.Items, i)
Select Case i
Case 0 To 1, 3 To 5: x = x + 1: Cells(1, x) = Headers(i)
End Select
Next
y = 1
For Each oFile In oFolder.Items
p = oFile.Path: n = oFile.Name
Select Case Right$(n, 4)
Case ".xls", ".doc", ".pdf"
x = 0: y = y + 1
For i = 0 To 5
Select Case i
Case 0 To 1, 3 To 5
x = x + 1
Cells(y, x) = oFolder.GetDetailsOf(oFile, i)
With ActiveSheet
.Hyperlinks.Add .Range("A" & y), Hlink(p), , n, n
End With
End Select
Next
End Select
Next
Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Font.Bold = True
Cells.Columns.AutoFit
Columns("B:E").HorizontalAlignment = xlCenter
Range("A1").Select
Set oFolder = Nothing: Set objShell = Nothing
End Sub

Private Function Hlink(p As String) As String
Hlink = "file:///" & Replace(Replace(p, " ", "%20"), "", "/")
End Function


Avatar
BlackStorm
Bonsoir,

Grand merci à vous tous !!! Cela fonctionne super !
Mais j'ai une question... Je veux utiliser Excel comme outils de gestion
de documentation. Je voudrais que la liste des documents trouvés dans un
répertoire NE SE FASSE que dans la feuille 2 et uniquement cette
feuille. Cela a chaque utilisation. Il faut donc qu'il "purge" la
feuille...

Merci d'avance. En tout cas je ne suis pas un pro d'excel, mais en
essyant de décortiquer les lignes de commandes, cela me permet de voir
comment cela fonctionne... et franchement, cela est passionnant !!!