'下面代码是从我写的 Dll 里面的 .cls 抽出来的, 因此,下面代码,除了Command1事件是本地代码, 其它另两个Sub与Function你可以活用, 摆在你的 .cls里面
'*************** 本代码是在指定的文件夹中以 "递归" 方式搜索多媒体文件
'*.mp3;*.mid;*.wav;*.wma;*.dat;*.rm;*.rmi;*.rmvb
'添加 Command1 List1
Option Explicit
Dim j%, aa$, subpattern$(), maxpattern%, tfiles&, subsch As Boolean, s
Private Sub Command1_Click()
MsgBox "共查找到: " & CStr(GetPathFiles(List1, "e:/music", "*.mp3;*.mid;*.wav;*.wma;*.dat;*.rm;*.rmi;*.rmvb", True)) & " 个文件"
'****************** 如只想搜索本文件夹而不搜索下层子文件夹则改为如下代码
'MsgBox "共查找到: " & CStr(GetPathFiles(List1, "e:/music", "*.mp3;*.mid;*.wav;*.wma;*.dat;*.rm;*.rmi;*.rmvb", False)) & " 个文件"
End Sub
Public Function GetPathFiles(Llist As Object, pschdir$, pExtName$, Optional subyn As Boolean = False) As Long
tfiles = 0
subsch = subyn
s = Split(pExtName, ";")
For j = 0 To UBound(s)
ReDim Preserve subpattern$(j)
subpattern(j) = s(j)
Next j
maxpattern = UBound(s) + 1
Call DGsearch(Llist, pschdir)
GetPathFiles = tfiles
End Function
Private Sub DGsearch(Llist As Object, strpath$)
On Error Resume Next
Dim strFileDir$(), strFile$, dircount&, lDirCount&
If Right(strpath, 1) <> "/" Then strpath = strpath & "/"
strFile = Dir(strpath, vbDirectory Or vbHidden Or vbNormal Or vbReadOnly)
While strFile <> "" '搜索当前目录
DoEvents
If (GetAttr(strpath & strFile) And vbDirectory) = vbDirectory Then '如果找到的是目录
If strFile <> "." And strFile <> ".." Then '排除掉父目录(..)和当前目录(.)
lDirCount = lDirCount + 1 '将目录数增1
ReDim Preserve strFileDir(lDirCount) As String
strFileDir(lDirCount - 1) = strFile '用动态数组保存当前目录名
End If
Else
For j = 0 To maxpattern - 1
aa = subpattern(j)
If aa = "" Then
If UCase(Right(aa, 3)) = UCase(Right(Trim(strFile), 3)) Or subpattern(j) = "*.*" Then Llist.AddItem strpath & strFile: tfiles = tfiles + 1: Exit For
ElseIf UCase(Right(aa, 3)) = UCase(Right(Trim(strFile), 3)) Or subpattern(j) = "*.*" Then
Llist.AddItem strpath & strFile: tfiles = tfiles + 1: Exit For
End If
Next j
End If
strFile = Dir
Wend
If subsch Then
For dircount = 0 To lDirCount - 1
Call DGsearch(Llist, strpath & strFileDir(dircount)) '递归搜索子目录
Next dircount
ReDim strFileDir(0) '将动态数组清空
End If
End Sub