搜索选定文件夹及其子文件夹中文件的小工具

小花鹿

做了个搜索选定文件夹及其子文件夹中文件的小工具，个人觉得挺好玩的。
功能：
1、可以任意选定文件夹
2、搜索选定文件夹、子文件夹、子子文件夹中的所有文件，以便后期处理
3、用窗体实时显示搜索到的文件名及其路径，避免用户认为死机

请选择文件较多的文件夹，比如C: ，看看效果。

Option Explicit
Dim FileList(1 To 65536, 1 To 1), filen&

Sub FolderFileList()
'--------------------------------------------------------------------------------------------
Dim myfolder, mypath
    Set myfolder = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹：", 0)
    If Not myfolder Is Nothing Then
        If myfolder <> "桌面" Then mypath = myfolder.Items.Item.Path
    Else
        MsgBox "你没有选择文件夹！"
        Exit Sub
    End If
    If mypath = "" Or Left(mypath, 2) = "::" Then
        MsgBox "文件夹选择错误！"
        Exit Sub
    End If
'------------------------------------------------------------------------------------------------
Dim fso, Folder, myf
Set fso = CreateObject("scripting.filesystemobject")
Set Folder = fso.getfolder(mypath)
filen = 0
For Each myf In Folder.Files
    UserForm1.Show 0
    filen = filen + 1
    FileList(filen, 1) = myf
    UserForm1.Label1.Caption = fileedit(myf)
    DoEvents
Next myf
SubFolderFileList (mypath)
UserForm1.Label1.Caption = "文件搜索完成，共搜索到 " & filen & " 个文件！"
DoEvents
If filen > 65536 Then filen = 65536
[a1].Resize(filen) = FileList
filen = 0
End Sub

Function SubFolderFileList(pth)
Dim fso, Folder, SubFolder, myf, fd
Set fso = CreateObject("scripting.filesystemobject")
Set Folder = fso.getfolder(pth)
Set SubFolder = Folder.subfolders
On Error Resume Next
For Each fd In SubFolder
    For Each myf In fd.Files
        If myf <> "" Then
            filen = filen + 1
            FileList(filen, 1) = myf
            UserForm1.Label1.Caption = fileedit(myf)
            DoEvents
        End If
    Next myf
    SubFolderFileList (fd.Path)
Next fd
On Error GoTo 0
End Function

Function fileedit(filenam)
Dim file1, file2, filear
If filenam > 60 Then
    filear = Split(filenam, "\")
    file2 = filear(UBound(filear))
    file1 = Replace(filenam, file2, "")
    file1 = Left(file1, 30)
    fileedit = file1 & "...\" & file2
Else
    fileedit = filenam
End If
End Function

列出选中文件夹及其子文件夹中的文件.rar (1.35 MB, 下载次数: 369)

2016-1-13 13:03 上传

点击文件名下载附件

好奇心

测试过多次，如选择的是盘符的下一级文件夹，您的小工具不能达到“搜索选定文件夹、子文件夹、子子文件夹中的所有文件”的目的。

小花鹿

好奇心 发表于 2016-1-13 16:16
测试过多次，如选择的是盘符的下一级文件夹，您的小工具不能达到“搜索选定文件夹、子文件夹、子子文件夹中 ...

谢谢你的指导，请给个例子，我测试一下。

好奇心

新建文件夹.zip (132.17 KB, 下载次数: 67)

2016-1-13 19:10 上传

点击文件名下载附件

好奇心

小花鹿 发表于 2016-1-13 18:09
谢谢你的指导，请给个例子，我测试一下。

请放在任意的盘符下。谢谢。

小花鹿

好奇心 发表于 2016-1-13 19:11
请放在任意的盘符下。谢谢。

我试了一下，搜索文件没问题，只是UserForm1.Show 0放的位置不对。

小花鹿

修改两个地方，一个是UserForm1.Show 0这句放的位置不对，应该上移一行
二个是[a1].Resize(filen) = FileList这句，当没有搜索到文件时会出错，改成：If filen Then [a1].Resize(filen) = FileList
代码如下：
Option Explicit
Dim FileList(1 To 65536, 1 To 1), filen&

Sub FolderFileList()
'--------------------------------------------------------------------------------------------
Dim myfolder, mypath
    Set myfolder = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹：", 0)
    If Not myfolder Is Nothing Then
        If myfolder <> "桌面" Then mypath = myfolder.Items.Item.Path
    Else
        MsgBox "你没有选择文件夹！"
        Exit Sub
    End If
    If mypath = "" Or Left(mypath, 2) = "::" Then
        MsgBox "文件夹选择错误！"
        Exit Sub
    End If
'------------------------------------------------------------------------------------------------
Dim fso, Folder, myf
Set fso = CreateObject("scripting.filesystemobject")
Set Folder = fso.getfolder(mypath)
filen = 0
UserForm1.Show 0
For Each myf In Folder.Files
    filen = filen + 1
    FileList(filen, 1) = myf
    UserForm1.Label1.Caption = fileedit(myf)
    DoEvents
Next myf
SubFolderFileList (mypath)
UserForm1.Label1.Caption = "文件搜索完成，共搜索到 " & filen & " 个文件！"
DoEvents
If filen > 65536 Then filen = 65536
If filen Then [a1].Resize(filen) = FileList
filen = 0
End Sub

Function SubFolderFileList(pth)
Dim fso, Folder, SubFolder, myf, fd
Set fso = CreateObject("scripting.filesystemobject")
Set Folder = fso.getfolder(pth)
Set SubFolder = Folder.subfolders
On Error Resume Next
For Each fd In SubFolder
    For Each myf In fd.Files
        If myf <> "" Then
            filen = filen + 1
            FileList(filen, 1) = myf
            UserForm1.Label1.Caption = fileedit(myf)
            DoEvents
        End If
    Next myf
    SubFolderFileList (fd.Path)
Next fd
On Error GoTo 0
End Function

Function fileedit(filenam)
Dim file1, file2, filear
If filenam > 60 Then
    filear = Split(filenam, "\")
    file2 = filear(UBound(filear))
    file1 = Replace(filenam, file2, "")
    file1 = Left(file1, 30)
    fileedit = file1 & "...\" & file2
Else
    fileedit = filenam
End If
End Function

大头菜871118

小花鹿 发表于 2016-1-14 10:06
修改两个地方，一个是UserForm1.Show 0这句放的位置不对，应该上移一行
二个是[a1].Resize(filen) = FileL ...

能否建立超链接呢？

lujkhua

我的可以超链接！

JJMY

lujkhua 发表于 2016-1-14 12:59
我的可以超链接！

你的附件在哪呢，谢谢！