不过这个速度有点慢啊!下面这个快点
'in modle
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Public Const INVALID_HANDLE_VALUE = -1
Public Const MaxLFNPath = 260 '定义文件路径最大长度
Public Const LB_INITSTORAGE = &H1A8 '为指定项数和相关字符串分配内存
Public Const LB_ADDSTRING = &H180 '追加一个列表项
Public Const WM_SETREDRAW = &HB '设置窗口是否能重画
Public Const WM_VSCROLL = &H115 '当一个窗口标准垂直滚动条产生一个滚动事件时发送此消息给那个窗口
Public Const SB_BOTTOM = 7 '向下滚动
'windows提供了一种特殊的机制，可以记录文件的访问及创建时间。
'在win32环境中，这些信息以64位值的形式保存，量度的是自1601年1月1日以来经历的100ns时间单位数量
'文件时间在系统中通常用“协同世界时间”（UTC）的格式保存，但同时提供了在UTC及本地时间之间转换的函数。
'FILETIME结构里可包含UTC或本地时间——由我们自行决定在结构中包含什么时间
Private Type FILETIME
dwLowDateTime As Long '文件时间的低32 位
dwHighDateTime As Long '文件时间的高32 位
End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long '文件属性
ftCreationTime As FILETIME '文件创建时间
ftLastAccessTime As FILETIME '文件最后一次访问时间
ftLastWriteTime As FILETIME '文件最后一次修改时间
nFileSizeHigh As Long '文件长度高32位
nFileSizeLow As Long '文件长度低32位
dwReserved0 As Long '系统保留
dwReserved1 As Long '系统保留
cFileName As String * MaxLFNPath '长文件名
cShortFileName As String * 14 '8.3格式文件名
End Type
' in form
Dim mlstHwnd$ 'listbox句柄
Dim mStopSearch As Boolean '停止搜索
Private Declare Function GetTickCount Lib "kernel32" () As Long ' 用于获取自windows启动以来经历的时间长度（毫秒）
Private Sub Form_Load()
mlstHwnd$ = List1.hwnd
'LB_INITSTORAGE 为指定项数和相关字符串分配内存
'本操作只适用于Windows95版本，当你将要向列表框中加入很多表项或有很大的表项时，本操作将预先分配一块内存，以免在今后的操作中一次一次地分配内存，从而加快程序运行速度。
'wparam 表项数 30000->&H7530&
'Param 内存字节数 30000& * 200->
SendMessage mlstHwnd$, LB_INITSTORAGE, &H7530, ByVal &H5B8D80 '加速操作但消耗6M内存
End Sub
Private Sub Dir1_Change() '选择文件夹
Text1.Text = Dir1.Path & "\"
End Sub
Private Sub Drive1_Change() '选择驱动器
Dir1.Path = Drive1.Drive
End Sub
Private Sub Text1_Change()
If Len(Text1.Text) = 4 Then Text1.Text = Left$(Text1.Text, 3) '去掉路径中的\
End Sub
Private Sub Command1_Click() '查找文件
Dim a&, b&
On Error Resume Next
If mStopSearch Then
mStopSearch = False
Exit Sub
End If
If Len(Text1.Text) Then
MousePointer = vbHourglass
mStopSearch = True
List1.Clear '清空列表
b = GetTickCount
SearchDirs Text1.Text, Combo1.Text, List1
Label1.Caption = "文件个数： " & List1.ListCount & " 个"
mStopSearch = False
MousePointer = vbDefault
a = GetTickCount - b
MsgBox "执行速度" + Str$(a) + "毫秒"
End If
End Sub
Private Sub cmdStop_Click() '停止查找
mStopSearch = False
MousePointer = vbDefault
End Sub
Private Sub cmdExit_Click()
mStopSearch = False
Unload Me
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Set form1 = Nothing
End
End Sub
'查找文件的过程函数
Private Function SearchDirs(ByVal sDirName As String, ByVal FileFilter As String, lstFilesFound As ListBox) As Boolean
On Error GoTo RF_ERROR
Dim sName$, sFile$
Dim sDirlist() As String, iDirNum&, i As Integer
'首先找出该目录下的所有文件
sFile = Dir(sDirName & FileFilter, vbDirectory Or vbHidden Or vbSystem Or vbArchive Or vbNormal Or vbReadOnly Or vbVolume)
Do While Len(sFile) > 0
If Not mStopSearch Then Exit Function
If Asc(sFile) <> 46 Then
SendMessage mlstHwnd$, LB_ADDSTRING, 0, ByVal sDirName & sFile
Label1.Caption = "文件个数： " & List1.ListCount & " 个"
End If
sFile = Dir
Loop
SendMessage mlstHwnd$, WM_VSCROLL, SB_BOTTOM, 0
'准备遍历全部子目录
sName = Dir(sDirName & "*.*", vbDirectory Or vbHidden Or vbSystem Or vbArchive Or vbNormal Or vbReadOnly Or vbVolume)
Do While Len(sName) > 0
DoEvents
If sName <> "." And sName <> ".." Then
iDirNum = iDirNum + 1
ReDim Preserve sDirlist(1 To iDirNum)
sDirlist(iDirNum) = sDirName & sName & "\"
End If
sName = Dir
Loop
For i = 1 To iDirNum
SearchDirs sDirlist(i), FileFilter, lstFilesFound '递归搜索
SearchDirs = True
Next
RF_EXIT:
Exit Function
RF_ERROR:
Resume RF_EXIT
End Function
