新年献礼：最快文件搜索程序

wzsy2_mrf

附件中有二个程序，一个是搜索目录，另一个是搜索文件的，都是采取树形加栈的结构的非递归程序，速度远超一般的递归程序，且经测试即使有数万个文件也不会卡死，现作新年礼物以献大家，祈求来年好运。

wzsy2_mrf

附件在此：

wzsy2_mrf

Sub mlSearchFDG(ByRef mlNameArr() As String, pPath As String, pSub As Boolean)  '搜索子目录
'mlNameArr装文件名动态数组，psb子目录开关,pPath搜索起始路径
    On Error Resume Next
    Dim DirFile, mf&, pPath1$
    Dim workStack$(), top&    'workstack工作栈,top栈顶变量
    pPath = Trim(pPath)
    If Right(pPath, 1) <> "\" Then pPath = pPath & "\"    ' 对搜索路径加 backslash（反斜线）
    pPath1 = pPath
    top = 1
    ReDim Preserve workStack(0 To top)
    Do While top >= 1
        DirFile = Dir(pPath1, vbDirectory)
        Do While DirFile <> ""
            If DirFile <> "." And DirFile <> ".." Then
                If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
                    mf = mf + 1
                    ReDim Preserve mlNameArr(1 To mf)
                    mlNameArr(mf) = pPath1 & DirFile
                End If
            End If
            DirFile = Dir
        Loop
        If pSub = False Then Exit Sub
        DirFile = Dir(pPath1, vbDirectory)    ' 搜索子目录
        Do While DirFile <> ""
            If DirFile <> "." And DirFile <> ".." Then
                If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
                    workStack(top) = pPath1 & DirFile & "\"    '压栈
                    top = top + 1
                    If top > UBound(workStack) Then ReDim Preserve workStack(0 To top)
                End If
            End If
            DirFile = Dir
        Loop
        If top > 0 Then pPath1 = workStack(top - 1): top = top - 1    '弹栈
    Loop
    Erase workStack
End Sub

wzsy2_mrf

1. Sub FileSearchFDG(ByRef fileNameArr() As String, pPath As String, pMask As String, pSub As Boolean)
   
2.     'fileNameArr装文件名动态数组，psb子目录开关,pPath搜索起始路径，pMask扩展名(如doc)
   
3.     On Error Resume Next
   
4.     Dim DirFile, mf&, pPath1$
   
5.     Dim workStack$(), top&    'workstack工作栈,top栈顶变量
   
6.     pPath = Trim(pPath)
   
7.     If Right(pPath, 1) <> "" Then pPath = pPath & ""    ' 对搜索路径加 backslash（反斜线）
   
8.     pPath1 = pPath
   
9.     top = 1
   
10.     ReDim Preserve workStack(0 To top)
    
11.     Do While top >= 1
    
12.         DirFile = Dir(pPath1 & "*." & pMask)
    
13.         Do While DirFile <> ""
    
14.             mf = mf + 1
    
15.             ReDim Preserve fileNameArr(1 To mf)
    
16.             fileNameArr(mf) = pPath1 & DirFile
    
17.             DirFile = Dir
    
18.         Loop
    
19.         If pSub = False Then Exit Sub
    
20.         DirFile = Dir(pPath1, vbDirectory)    ' 搜索子目录
    
21.         Do While DirFile <> ""
    
22.             If DirFile <> "." And DirFile <> ".." Then
    
23.                 If (GetAttr(pPath1 & DirFile) And vbDirectory) = vbDirectory Then
    
24.                     workStack(top) = pPath1 & DirFile & ""    '压栈
    
25.                     top = top + 1
    
26.                     If top > UBound(workStack) Then ReDim Preserve workStack(0 To top)
    
27.                 End If
    
28.             End If
    
29.             DirFile = Dir    'next file
    
30.         Loop
    
31.         If top > 0 Then pPath1 = workStack(top - 1): top = top - 1    '弹栈
    
32.     Loop
    
33.     Erase workStack
    
34. End Sub
    

复制代码

wzsy2_mrf

使用方法：

1. Sub aa()
   
2.     Dim arr() As String, mf&
   
3.     Range("A1").Resize(Range("a1").End(xlDown).Row, 1).Clear
   
4.     mlSearchFDG arr, "F:", True '搜索子目录
   
5.     Range("a1").Resize(UBound(arr), 1) = Application.Transpose(arr)
   
6.    
   
7.     FileSearchFDG arr, "F:", "*", True '搜索全部文件
   
8.     Range("d1").Resize(UBound(arr), 1) = Application.Transpose(arr)
   
9.    
   
10.     FileSearchFDG arr, "F:", "xls", True '搜索特定文件
    
11.     Range("g1").Resize(UBound(arr), 1) = Application.Transpose(arr)
    
12.     Erase arr
    
13. End Sub
    

复制代码

aman1516

谢谢分享，非常好

百度不到去谷歌

wzsy2_mrf 发表于 2016-12-24 10:41
附件在此：

大神作品 严重支持 下载的人多回帖吧 拿了人家东西起码说声谢谢
ps 经测试 速度确实爆快！

xinlan6

留个备用，谢谢！

huang1314wei

看到楼主说“栈”，我吓了跳，再一看，原来所谓的“栈”只是动态数组，不过，思路确实很好，点赞

学不完用不尽

看上去很厉害的样子！