Question

我想知道excel VBA中是否有任何或所有这些功能：

列出本地区域内的所有文件夹和子文件夹（路径名）。
生成一个链接，以便在显示时，用户可以从电子表格中打开它。
如果用户在目录中添加或删除任何文件或文件夹/子文件夹，则会自动更新电子表格。

Answer 1

我做了一个快速示例，向您展示如何列出所有文件和子文件夹：

Option Explicit

Private Sub test()
    readFileSystem ("C:\Temp\")
End Sub

Private Sub readFileSystem(ByVal pFolder As String)
    Dim oFSO As Object
    Dim oFolder As Object

    ' create FSO
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    ' get start folder
    Set oFolder = oFSO.getFolder(pFolder)

    ' list folder content
    listFolderContent oFolder

    ' destroy FSO
    Set oFolder = Nothing
    Set oFSO = Nothing
End Sub

Private Sub listFolderContent(ByVal pFolder As Object)
    Dim oFile As Object
    Dim oFolder As Object

    ' go thru all sub folders
    For Each oFolder In pFolder.SubFolders
        Debug.Print oFolder.Path
        ' do the recursion to list sub folder content
        listFolderContent oFolder
    Next

    ' list all files in that directory
    For Each oFile In pFolder.Files
        Debug.Print oFile.Path
    Next

    ' destroy all objects
    Set pFolder = Nothing
    Set oFile = Nothing
    Set oFolder = Nothing
End Sub

Answer 2

您也可以使用CMD：

Sub MM()

Dim fileResults As Variant

fileResults = GetFiles("C:\Users\Macro Man\Documents")

Range("A1").Resize(UBound(fileResults) + 1, 1).Value = _
    WorksheetFunction.Transpose(fileResults)

End Sub


'// UDF to populate array with files, assign to a Variant variable. 
Function GetFiles(parentFolder As String) As Variant

GetFiles = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & parentFolder & _
    IIf(Right(parentFolder, 1) = "\", vbNullString, "\") & "*.*"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")

End Function

如果您有大量文件，因为它不需要递归，这会更快（在中等规格的PC上需要几秒钟才能完成1000多个文件）。

Answer 3

以下是如何根据Scripting.FileSystemObject和Scripting.Dictionary ActiveX获取文件夹和文件列表的示例，没有递归调用，只有Do ... Loop：

Option Explicit

Sub Test()

    Dim strFolder As String
    Dim objFolders As Object
    Dim objFiles As Object
    Dim i As Long
    Dim objItem As Object

    ' target folder
    strFolder = "C:\Test"

    ' loop through all folders and files
    Set objFolders = CreateObject("Scripting.Dictionary")
    Set objFiles = CreateObject("Scripting.Dictionary")
    objFolders(0) = strFolder
    i = 0
    With CreateObject("Scripting.FileSystemObject")
        Do
            With .GetFolder(objFolders(i))
                For Each objItem In .Files
                    objFiles(objFiles.Count) = objItem.Path
                Next
                For Each objItem In .SubFolders
                    objFolders(objFolders.Count) = objItem.Path
                Next
            End With
            i = i + 1
        Loop Until i = objFolders.Count
    End With

    ' results output to the 1st sheet
    With Sheets(1)
        .Select
        .Cells.Delete
        .Range(.Cells(1, 1), .Cells(objFolders.Count, 1)).Value = Application.Transpose(objFolders.Items)
        .Range(.Cells(1, 2), .Cells(objFiles.Count, 2)).Value = Application.Transpose(objFiles.Items)
        .Columns.AutoFit
    End With

End Sub

Answer 4

这将列出所选文件夹中的所有文件（它将提示一个对话框，以便您可以选择该文件夹）：

强制显式声明变量

Option Explicit

创建一个函数来选择文件所在的文件夹：

        Function ChooseFolder() As String

        'function to select the folder where the files are

        Dim fldr As FileDialog
        Dim sItem As String

        Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
        With fldr
            .Title = "Select a Folder"
            .AllowMultiSelect = False
            If .Show <> -1 Then GoTo NextCode
            sItem = .SelectedItems(1)
        End With

    NextCode:
        ChooseFolder = sItem
        Set fldr = Nothing

    End Function

> Enter the routines to list all files in folder and sub-folders
Sub ListFiles2()

    Range("A:H").Select
    Selection.ClearContents


    'Declare the variables
    Dim objFSO As Scripting.FileSystemObject
    Dim objTopFolder As Scripting.Folder
    Dim strTopFolderName As String, ProjectF As String
    Dim i As Long

    'Insert the headers for Columns A through F
    Range("A1").Value = "File Name"
    Range("B1").Value = "Parent Folder"
    Range("C1").Value = "File Type"
    Range("D1").Value = "Date Created"
    Range("E1").Value = "Date Last Accessed"
    Range("F1").Value = "Date Last Modified"
    Range("G1").Value = "Author"
    Range("H1").Value = "Last Saved by"


    'strTopFolderName = "C:\Users\IGarcia\Documents\QMS\LaBella Engineering"

    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    'Get the top folder
    Set objTopFolder = objFSO.GetFolder(ChooseFolder)

    'Call the RecursiveFolder routine
    Call RecursiveFolder2(objTopFolder, True)

    'Change the width of the columns to achieve the best fit
    Columns.AutoFit



End Sub




Sub RecursiveFolder2(objFolder As Scripting.Folder, IncludeSubFolders As Boolean)

    'Declare the variables
    Dim objFile As Scripting.File
    Dim objSubFolder As Scripting.Folder
    Dim NextRow As Long

    Dim ws1 As Excel.Worksheet
    Dim ws2 As Excel.Worksheet

    Dim oFolder As Object, oFile As Object, objFile2 As Object

    Set oFolder = CreateObject("Shell.Application").Namespace(objFolder.Path)


    'Find the next available row
    NextRow = Cells(Rows.Count, "C").End(xlUp).Row + 1

    'Loop through each file in the folder
    For Each objFile In objFolder.Files
        Cells(NextRow, "A").Value = objFile.Name
        Cells(NextRow, "B").Value = objFile.ParentFolder
        Cells(NextRow, "C").Value = objFile.Type
        Cells(NextRow, "D").Value = objFile.DateCreated
        Cells(NextRow, "E").Value = objFile.DateLastAccessed
        Cells(NextRow, "F").Value = objFile.DateLastModified

        Set oFile = oFolder.ParseName(objFile.Name)
        Cells(NextRow, "G") = oFolder.GetDetailsOf(oFile, 20)

        Set objFile2 = CreateObject("DSOFile.OleDocumentProperties")
        On Error Resume Next
        objFile2.Open (objFile.Path)
        Cells(NextRow, "H").Value = objFile2.SummaryProperties.LastSavedBy

        NextRow = NextRow + 1

    Next objFile



    'Loop through files in the subfolders
    If IncludeSubFolders Then
        For Each objSubFolder In objFolder.SubFolders
            Call RecursiveFolder2(objSubFolder, True)
        Next objSubFolder
    End If



End Sub

是否可以列出自定义目录中的所有文件和文件夹 - excel vba

4 个答案: