L
Le rital
Guest
Bonjour le forum,
Voici un code qui fonctionne très bien.
Est-il possible d'ajouter une procédure pour créer des "lien hypertexte" qui pointent sur le fichier ?
Merci d'avance
Cordialement
Le rital
( Liste les fichiers d'un dossier et de ses sous dossiers)
(dans une feuille de calcul avec certains renseignemens)
(d'après Ole P Erlandsen) "rendre à César ce qui appartient à César"
(code original à cette adresse http://www.erlandsendata.no/)
Sub TestListFilesInFolder()
Dim RootFolder$
' dossier à scanner
RootFolder = ChoisirDossier
If RootFolder = "" Then Exit Sub
' create a new workbook for the file list
Workbooks.Add
' add headers
With Range("A1")
.Formula = " Contenu du dossier : " & RootFolder
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "Chemin : "
Range("B3").Formula = "Nom : "
Range("C3").Formula = "Date Création : "
Range("D3").Formula = "Date Dernier Accès : "
Range("E3").Formula = "Date Dernière Modif : "
With Range("A3:E3")
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
' list all files included subfolders
ListFilesInFolder RootFolder, True
Columns("A:H").AutoFit
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
' Ole P Erlandsen (modifié fs 11/8/01)
Dim fso 'As Scripting.FileSystemObject
Dim SourceFolder 'As Scripting.Folder
Dim SubFolder 'As Scripting.Folder
Dim FileItem 'As Scripting.File
Dim r As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder(SourceFolderName)
r = Range("A65536").End(xlUp).Row + 1
For Each FileItem In SourceFolder.files
' display file properties
Cells(r, 1).Formula = FileItem.ParentFolder
Cells(r, 2).Formula = FileItem.Name
Cells(r, 3).Formula = FileItem.DateCreated
Cells(r, 3).NumberFormatLocal = "jj/mm/aa"
Cells(r, 4).Formula = FileItem.DateLastAccessed
Cells(r, 5).Formula = FileItem.DateLastModified
Cells(r, 5).NumberFormatLocal = "jj/mm/aa"
' next row number
r = r + 1
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.subfolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set fso = Nothing
ActiveWorkbook.Saved = True
End Sub
Private Function ChoisirDossier()
Dim objShell, objFolder, chemin, SecuriteSlash
Set objShell = CreateObject("Shell.Application")
Set objFolder = _
objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
On Error Resume Next
chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
chemin = "C:\Windows\Bureau"
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
ChoisirDossier = chemin
End Function
Voici un code qui fonctionne très bien.
Est-il possible d'ajouter une procédure pour créer des "lien hypertexte" qui pointent sur le fichier ?
Merci d'avance
Cordialement
Le rital
( Liste les fichiers d'un dossier et de ses sous dossiers)
(dans une feuille de calcul avec certains renseignemens)
(d'après Ole P Erlandsen) "rendre à César ce qui appartient à César"
(code original à cette adresse http://www.erlandsendata.no/)
Sub TestListFilesInFolder()
Dim RootFolder$
' dossier à scanner
RootFolder = ChoisirDossier
If RootFolder = "" Then Exit Sub
' create a new workbook for the file list
Workbooks.Add
' add headers
With Range("A1")
.Formula = " Contenu du dossier : " & RootFolder
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "Chemin : "
Range("B3").Formula = "Nom : "
Range("C3").Formula = "Date Création : "
Range("D3").Formula = "Date Dernier Accès : "
Range("E3").Formula = "Date Dernière Modif : "
With Range("A3:E3")
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
' list all files included subfolders
ListFilesInFolder RootFolder, True
Columns("A:H").AutoFit
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
' Ole P Erlandsen (modifié fs 11/8/01)
Dim fso 'As Scripting.FileSystemObject
Dim SourceFolder 'As Scripting.Folder
Dim SubFolder 'As Scripting.Folder
Dim FileItem 'As Scripting.File
Dim r As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder(SourceFolderName)
r = Range("A65536").End(xlUp).Row + 1
For Each FileItem In SourceFolder.files
' display file properties
Cells(r, 1).Formula = FileItem.ParentFolder
Cells(r, 2).Formula = FileItem.Name
Cells(r, 3).Formula = FileItem.DateCreated
Cells(r, 3).NumberFormatLocal = "jj/mm/aa"
Cells(r, 4).Formula = FileItem.DateLastAccessed
Cells(r, 5).Formula = FileItem.DateLastModified
Cells(r, 5).NumberFormatLocal = "jj/mm/aa"
' next row number
r = r + 1
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.subfolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set fso = Nothing
ActiveWorkbook.Saved = True
End Sub
Private Function ChoisirDossier()
Dim objShell, objFolder, chemin, SecuriteSlash
Set objShell = CreateObject("Shell.Application")
Set objFolder = _
objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
On Error Resume Next
chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
chemin = "C:\Windows\Bureau"
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
ChoisirDossier = chemin
End Function
