fso提取汇总文件夹及其下的文件名及内容（递归操作字典汇总）

liulang0808

jave000 发表于 2022-7-17 22:30
这段代码一直使用正常，但是上海封城期间就不能用了，显示错误wrong number of arguments or invalid pro ...

这个需要提供下报错的测试文档

jave000

liulang0808 发表于 2022-7-18 07:09
这个需要提供下报错的测试文档

Sub button9_click()
    Application.ScreenUpdating = False
    Set Fso = CreateObject("scripting.filesystemobject")
    ActiveSheet.Range.ClearContents
   
    Set f1 = Fso.getfolder("\\jsvr5.net\")
    a = 1
    For Each fd1 In f1.subfolders
        Cells(a, 1) = fd1
        a = a + 1
    Next fd1
        
    Set f2 = Fso.getfolder("\\jsvr5.net\AB\D4")
    b = a
    For Each fd2 In f2.subfolders
        Cells(b, 1) = fd2
        b = b + 1
    Next fd2
        
    Set f3 = Fso.getfolder("\\jsvr5.net\C1\")
    c = b
    For Each fd3 In f3.subfolders
        Cells(c, 1) = fd3
        c = c + 1
    Next fd3
   
    Dim o
        For o = 1 To 2000
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(o, 1), Address:=Cells(o, 1).Value
        Next

    Application.ScreenUpdating = True
End Sub




我后来用可以获取全部子文件夹的代码修改成如下代码，解决了关键词获取的问题，但是发现新的问题是代码只支持下一层子文件夹，不再支持全部子文件夹了，于是我自己又加了一层For Each fe In fd.subfolders。
这个距离使用还有两个障碍，一个是因为只支持一层子文件夹，Getfd需要输入多个地址了，请问可以怎么写？还有一个是关键词"out"不够，我有两种关键词，试了or不行。

Sub button9_click()
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.ClearContents
    Cells(1, 1) = "Project Path"
    Getfd ("C:\Users\asaman\Desktop\path\")
    Dim o
    For o = 1 To 5000
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(o, 1), Address:=Cells(o, 1).Value
    Next
    Application.ScreenUpdating = True
End Sub
Sub Getfd(ByVal pth)
    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(pth)
    Cells(Rows.Count, 1).End(3).Offset(1) = pth
    For Each fd In ff.subfolders
        For Each fe In fd.subfolders
            If LCase(fe.Name) Like "out" & "*" Then
                Getfd (fe)
            End If
        Next fe
    Next fd
End Sub

jave000

https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/wrong-number-of-arguments-error-450?f1url=%3FappId%3DDev11IDEF1%26l%3Den-US%26k%3Dk(vblr6.chm1000450)%3Bk(TargetFrameworkMoniker-Office.Version%3Dv16)%26rd%3Dtrue

依清洲

liulang0808 发表于 2014-11-15 13:55
http://club.excelhome.net/blog-238368-1693.html
fso的材料整理

楼主真是厉害了

WilsonJ

感谢老师，很好用

Hontyu

学习一下！！！！！！

8776853

这写的……遍历文件树，可以用深度优先搜索dfs或者广度优先搜索bfs：

1、深度优先的，需要递归：

Function Getfd(ByVal path As String) As String()
    On Error Resume Next

    ' result数组用来保存结果
    Dim result() As String: ReDim result(0)
    Dim rows() As String

    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fdir As Object: Set fdir = fso.GetFolder(path)

    Dim i As Long, j As Long, f
   
    ' 把当前目录下的文件都保存到结果数组里
    If fdir.Files.Count > 0 Then
        i = UBound(result) + 1
        ReDim Preserve result(UBound(result) + fdir.Files.Count)

        For Each f In fdir.Files
            result(i) = f.path
            i = i + 1
        Next
    End If

    ' 下面是子目录。递归每一个子目录。因为要保存结果，所以这里是后序遍历
    For Each f In fdir.SubFolders
        rows = Getfd(f.path) ' 递归调用, 执行深度优先遍历
        If UBound(rows) > 0 Then '把结果存到结果数组
            i = UBound(result) + 1
            ReDim Preserve result(UBound(result) + UBound(rows))

            For j = 1 To UBound(rows)
                result(i) = rows(j)
                i = i + 1
            Next
        End If
    Next

    Getfd = result
End Function

2、广度优先。广度优先不需要递归，但是需要队列这种数据结构，vb没有内置队列，可以用动态数组模拟：

Function Getfd2(ByVal path) As String()
    On Error Resume Next
   
    Dim result() As String: ReDim result(0)
   
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fdir As Object
   
    Dim dirs() As String: ReDim dirs(1) ' 用动态数组模拟队列
    dirs(1) = path '把第一个元素先入队列
   
    Dim i As Long, j As Long, size As Long, f
   
    While UBound(dirs) > 0 ' 循环读队列
        size = UBound(dirs)
        
        For i = 1 To size
            path = dirs(1) ' 队列是先入先出, 所以读1号元素
            
            ' 模拟队列的行为, 把后面的元素都向前移位，并且删掉队列尾部元素
            For j = 1 To UBound(dirs) - 1
                dirs(j) = dirs(j + 1)
            Next
            ReDim Preserve dirs(UBound(dirs) - 1)
            
            Set fdir = fso.GetFolder(path)
            If fdir.Files.Count > 0 Then
                j = UBound(result) + 1
                ReDim Preserve result(UBound(result) + fdir.Files.Count)

                For Each f In fdir.Files
                    result(j) = f.path
                    j = j + 1
                Next
            End If
            
            ' 把读出来的子目录都入队列
            If fdir.SubFolders.Count > 0 Then
                j = UBound(dirs) + 1
                ReDim Preserve dirs(UBound(dirs) + fdir.SubFolders.Count)
               
                For Each f In fdir.SubFolders
                    dirs(j) = f.path
                    j = j + 1
                Next
            End If
        Next
    Wend
   
    Getfd2 = result
End Function

8776853

这写的不够清晰专业，补充一下。其实就是利用深度优先（dfs）或者广度优先（bfs）两种方法，遍历文件树。
1、深度优先。深度优先需要利用栈这种数据结构，直接用递归：
Function Getfd(ByVal path As String) As String()
    On Error Resume Next

    ' 把结果存result数组
    Dim result() As String: ReDim result(0)
    Dim rows() As String

    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fdir As Object: Set fdir = fso.GetFolder(path)

    Dim i As Long, j As Long, f
   
    ' 先把当前目录下的文件列表存结果数组里
    If fdir.Files.Count > 0 Then
        i = UBound(result) + 1
        ReDim Preserve result(UBound(result) + fdir.Files.Count)

        For Each f In fdir.Files
            result(i) = f.path
            i = i + 1
        Next
    End If

    ' 如果有子目录，递归每一个子目录。因为要存结果，所以这里其实是后序递归
    For Each f In fdir.SubFolders
        rows = Getfd(f.path) '递归
        If UBound(rows) > 0 Then ' 把递归结果存到最终结果里
            i = UBound(result) + 1
            ReDim Preserve result(UBound(result) + UBound(rows))

            For j = 1 To UBound(rows)
                result(i) = rows(j)
                i = i + 1
            Next
        End If
    Next

    Getfd = result
End Function

tanglf188

十分感谢，收藏了

yellowhawk

真的是太好了，必须收藏，认真学习！