Excel VBA: создать список вложенных папок и файлов в исходной папке

Question

Я использую следующий код, чтобы перечислить все файлы в папке хоста и ее подпапках. Код работает отлично, но знаете ли вы, как я могу обновить код, чтобы также указать некоторые атрибуты файла.

Sub file_list() 

Call ListFilesInFolder("W:\ISO 9001\INTEGRATED_PLANNING\", True) 

End Sub 

Sub ListFilesInFolder(ByVal SourceFolderName As String, ByVal IncludeSubfolders As Boolean) 

Dim FSO As Object 
Dim SourceFolder As Object 
Dim SubFolder As Object 
Dim FileItem As Object 
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 

    Cells(r, 1).Formula = FileItem.Name 
    r = r + 1 
    X = SourceFolder.Path 
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 

End Sub 

Function GetFileOwner(ByVal FilePath As String, ByVal FileName As String) 

Dim objFolder As Object 
Dim objFolderItem As Object 
Dim objShell As Object 
FileName = StrConv(FileName, vbUnicode) 
FilePath = StrConv(FilePath, vbUnicode) 
Set objShell = CreateObject("Shell.Application") 
Set objFolder = objShell.Namespace(StrConv(FilePath, vbFromUnicode)) 
If Not objFolder Is Nothing Then 
    Set objFolderItem = objFolder.ParseName(StrConv(FileName, vbFromUnicode)) 
End If 
If Not objFolderItem Is Nothing Then 
    GetFileOwner = objFolder.GetDetailsOf(objFolderItem, 8) 
Else 
    GetFileOwner = "" 
End If 
Set objShell = Nothing 
Set objFolder = Nothing 
Set objFolderItem = Nothing 

End Function 

Что я действительно хотел бы видеть, это;

Колонка Папка = Host/вложенная

Столбец B = Имя файла

Колонка C = гиперссылка на файл

Возможно ли это?

У меня есть код, который создал гиперссылки, но я не знаю, как добавить к существующему коду.

Sub startIt() 

    Dim FileSystem As Object 
    Dim HostFolder As String 

    HostFolder = "W:\ISO 9001\INTEGRATED_PLANNING\" 

    Set FileSystem = CreateObject("Scripting.FileSystemObject") 
    DoFolder FileSystem.GetFolder(HostFolder) 

End Sub 

Sub DoFolder(Folder) 

    Dim SubFolder 
    For Each SubFolder In Folder.Subfolders 
    DoFolder SubFolder 
    Next 

    i = Cells(Rows.Count, 1).End(xlUp).Row + 1 
    Dim File 
    For Each File In Folder.Files 
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:= _ 
     File.Path, TextToDisplay:=File.Name 
    i = i + 1 

    Next 

End Sub 

Answer 1

Вы можете увидеть список свойств, которые File объект поддерживает здесь: https://msdn.microsoft.com/en-us/library/1ft05taf(v=vs.84).aspx

Таким образом, вы можете повысить свой код, где он принимает .Name имущество и положить, что в формуле ячейки, чтобы сделать что-то похожее на другие свойства, такие как .Type файла.

For Each FileItem In SourceFolder.Files 
    Cells(r, 1).Formula = FileItem.Name 
    Cells(r, 2).Value = FileItem.Type 
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 3), Address:= _ 
    FileItem.Path, TextToDisplay:=FileItem.Name 
    r = r + 1 
    X = SourceFolder.Path 
Next FileItem 

n.b. Я использовал Value вместо формулы, но в этом случае результат будет таким же.

Подобным же образом, вы можете добавить еще одну строку Cells(r, 3).Value =, чтобы установить значение ячейки в текущей строке r и столбца 3 к любой вашей гиперссылкой.

Answer 2

Я написал небольшой скрипт для этой цели к моему коллеге за время назад ...

Смотрите мой код ниже:

Sub FolderNames() 
'Written by Daniel Elmnas Last update 2016-02-17 
Application.ScreenUpdating = False 
Dim xPath As String 
Dim xWs As Worksheet 
Dim fso As Object, j As Long, folder1 As Object 
With Application.FileDialog(msoFileDialogFolderPicker) 
    .Title = "Choose the folder" 
    .Show 
End With 
On Error Resume Next 
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\" 
Application.Workbooks.Add 
Set xWs = Application.ActiveSheet 
xWs.Cells(1, 1).Value = xPath 
xWs.Cells(2, 1).Resize(1, 5).Value = Array("Subfolder", "Hostfolder", "Filename", "Date Created", "Date Last Modified") 
Set fso = CreateObject("Scripting.FileSystemObject") 
Set folder1 = fso.getFolder(xPath) 
getSubFolder folder1 
xWs.Cells(2, 1).Resize(1, 5).Interior.Color = 65535 
xWs.Cells(2, 1).Resize(1, 5).EntireColumn.AutoFit 
Application.ScreenUpdating = True 
End Sub 
Sub getSubFolder(ByRef prntfld As Object) 
Dim SubFolder As Object 
Dim subfld As Object 
Dim xRow As Long 
For Each SubFolder In prntfld.SubFolders 
    xRow = Range("A1").End(xlDown).Row + 1 
    Cells(xRow, 1).Resize(1, 5).Value = Array(SubFolder.Path, Left(SubFolder.Path, InStrRev(SubFolder.Path, "\")), SubFolder.Name, SubFolder.DateCreated, SubFolder.DateLastModified) 
Next SubFolder 
For Each subfld In prntfld.SubFolders 
    getSubFolder subfld 
Next subfld 
End Sub 

Вот результат:

You может немного изменить его.

Если вы пример не хотите использовать окно-диалог, и вместо этого использовать "W: \ ISO 9001 \ INTEGRATED_PLANNING \"

Ура!