200分~~求 文件搜索 的例子.在线等

Question

200分~~求  文件搜索  的例子,能解决再开贴给分.
要求可以实现,扩展名查找. 请高手指教

Answer 1

这是一个查找速度很快的程序,如果你看不懂或有什么问题可以留下你的EMAIL.'''''这是控件
'dir1:dirlistbox控件
'drive1:drivelistbox控件
'list1:listbox控件,用来存放查找出的文件.
'text1:存放路径.
'text2:查找的文件及扩展名
'command1:开始查找
'command2:停止查找''''''窗体代码''''''
Option Explicit      '声明函数
Dim lhwnd As String
Dim dirs, Dir$, files As Integer
Dim isrun As Boolean
Dim WFD As WIN32_FIND_DATA, hItem&, hFile&
Private Sub Form_Load()
  lhwnd = List1.hwnd
  SendMessage lhwnd, LB_INITSTORAGE, 30000&, ByVal 30000& * 200
End Sub
Private Sub Form_Activate()    '设定默认路径
  Dir1.Path = App.Path
  Drive1.Drive = Left(Dir1.Path, 3)
End Sub
Private Sub Dir1_Change()    '选择文件夹
  Text1.Text = Dir1.Path & "\"
End Sub
Private Sub Drive1_Change()   '选择驱动器
  Dir1.Path = Drive1.Drive
End Sub
Private Sub SearchDirs(filepath$)
  Dim dircount, i As Integer
  Dim dirarray()
  DoEvents
  If Not isrun Then Exit Sub
  hItem& = FindFirstFile(filepath$ & "*.*", WFD)     '查找文件
  If hItem& <> INVALID_HANDLE_VALUE Then
     Do
     If (WFD.dwFileAttributes And vbDirectory) Then
         If Asc(WFD.cFileName) <> 46 Then
            dirs = dirs + 1
            If (dircount Mod 10) = 0 Then ReDim Preserve dirarray(dircount + 10)
               dircount = dircount + 1
               dirarray(dircount) = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
            End If
          Else
            files = files + 1
         End If
     Loop While FindNextFile(hItem&, WFD)
     Call FindClose(hItem&)      '关闭FindFirstFile
     End If
       SendMessage lhwnd, WM_SETREDRAW, 0, 0
       hFile& = FindFirstFile(filepath$ & Dir$, WFD)
       If hFile& <> INVALID_HANDLE_VALUE Then
          Do
            DoEvents
            If Not isrun Then Exit Sub
            SendMessage lhwnd, LB_ADDSTRING, 0, _
            ByVal filepath$ & Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
            Label3.Caption = "文件个数： " & List1.ListCount & " 个"
          Loop While FindNextFile(hFile&, WFD)
          Call FindClose(hFile&)
       End If
        SendMessage lhwnd, WM_VSCROLL, SB_BOTTOM, 0
        SendMessage lhwnd, WM_SETREDRAW, 1, 0
  For i = 1 To dircount: SearchDirs filepath$ & dirarray(i) & "\": Next i
End Sub
Private Sub Text1_Change()   '
  If Len(Text1.Text) = 4 Then Text1.Text = Left(Text1.Text, 3)   '去掉路径中的End Sub
Private Sub Command1_Click()   '查找文件
  On Error Resume Next
  If isrun Then: isrun = False: Exit Sub
  Dir$ = Text2.Text
  MousePointer = 11
  isrun = True
  List1.Clear      '清空列表
  If isrun Then Call SearchDirs(Text1.Text)  '调用函数查找文件
  Label3.Caption = "文件个数： " & List1.ListCount & " 个"
  isrun = False
  MousePointer = 0
End Sub
Private Sub Command2_Click()    '停止查找
  isrun = False
  MousePointer = 0
End Sub''''''模块代码''''''
Option ExplicitDeclare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As LongPublic 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 = 7Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End TypeType WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * MaxLFNPath
        cShortFileName As String * 14
End Type

Answer 2

引用FSO.
一个COMMAND1.TEXTBOX,LISTBOXPrivate Sub Command1_Click()
    Dim fs As New FileSystemObject  ' 建立 FileSystemObject
    Dim fd As Folder    ' 定义 Folder 对象
    Dim sfd As Folder    Set fd = fs.GetFolder("c:\")
    Command1.Enabled = False
    Screen.MousePointer = vbHourglass
    FindFile fd, Text1.Text
    Command1.Enabled = True
    Screen.MousePointer = vbDefault
End SubSub FindFile(fd As Folder, FileName As String)
    Dim sfd As Folder, f As File    ' Part I查找该文件夹的所有文件
    For Each f In fd.Files
        If UCase(f.Name) Like UCase(FileName) Then
            Debug.Print f.Path
            List1.AddItem f.Path
        End If
        DoEvents
    Next    ' Part II循环查找所有子文件夹
    For Each sfd In fd.SubFolders
        FindFile sfd, FileName  ' 循环查找
    Next
End Sub

Answer 3

Private Sub Text1_Change()   '
  If Len(Text1.Text) = 4 Then Text1.Text = Left(Text1.Text, 3)   '去掉路径中的End Sub上面的这句为什么没有end if 而没有报错呢?

Answer 4

因为是个单语句,可以省略 END IF 但如果是一组语句,就一定需要END IF了

Answer 5

谢谢已经解决了.
非常感谢:julysixth(嘿呀)
也要感谢:MSTOP(陈建华(东莞立晨企业资讯服务有限公司)) 马上就结贴.