'下面代码是从我写的 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

发表于 @ 2008年03月08日 19:29:00|评论(loading...)|编辑