VB搜索系统文件的问题
各路高手帮帮忙以下代码我想改为全盘搜索，可以同时搜索多个文件，比如说同时搜索*.exe搜索*.rar
小弟拜托了
Option Explicit
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Const MaxLFNPath = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type 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
Const INVALID_HANDLE_VALUE = -1
Dim WFD As WIN32_FIND_DATA
Dim bgndir$, curpath$, schpattern$, aa$, fname$, progdisk$
Dim hItem&, hFile&, rtn&, i%, j%, k%, tfiles&, tfsize#, stopyn As Boolean 'Boolean 数据类型 _
(Visual Basic)存放只可能为 True 或 False 的值
Dim x1&, buff$ 'Dim x1& 是Dim x1 As Long“长整型”
'& 是 As Long的缩写,! 是 as single 的缩写
'例如:dim x0!,x1!,t!(或：dim x0 as single,x1 as single,t as single)
Private Sub Form_Load()
progdisk = Environ("ProgramFiles") & "\" '确定本机上的盘符,Environ函数是控制环境变量函数
Call init '窗体加载时,首先调用init配置过程
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub Command1_Click()
Dim s
On Error Resume Next
List1.Clear '清空list1里面的内容
tfiles = 0: tfsize = 0 '初始化统计文件数为0,文件大小为0,其中冒号是将两个语句分隔开
stopyn = False 'stopyn估计是按钮的停止属性跟cancel差不多吧
Command1.Enabled = Not Command1.Enabled
Command2.Enabled = Not Command2.Enabled
Combo1.Text = Trim(Combo1.Text) 'Trim表示去掉前后的空格前导空格(LTrim)、后续空格(RTrim)
If InStr(Text1.Text, ".") = 0 Then Text1.Text = Trim(Text1.Text) & "*.*"
'在text1中查找"."如果"."是第一个则....
Do
j = InStr(Combo1.Text, Space(2))
If j > 0 Then
Combo1.Text = Replace(Combo1.Text, Space(2), Space(1))
Else
Exit Do
End If
Loop
s = Split(Combo1.Text, " ")
For i = 0 To UBound(s)
s(i) = Trim(s(i))
If stopyn Then Exit For
bgndir = s(i) '开始搜的文件夹
If InStr(bgndir, ":") = 0 And Len(bgndir) = 1 Then bgndir = bgndir & ":"
If Right(bgndir, 1) <> "\" Then bgndir = bgndir & "\"
schpattern = Trim(Text1.Text) '模糊搜索条件,例如 *.* 或 *.mp3 或 sc*.*
Call SearchDirs(bgndir)
Next i
If tfiles > 0 Then
MsgBox "搜索完成,共查找到" & Str(tfiles) & " 个文件" & vbCrLf & Chr(10) & "总占空间: " & Format(Str(tfsize), "#,###") & " Bytes"
'Call dellist
Else
MsgBox "搜索完成,未找到符合的文件"
End If
Command1.Enabled = Not Command1.Enabled
Command2.Enabled = Not Command2.Enabled
Me.Caption = "CBM666 的快速搜索文件"
End Sub
Private Sub Command2_Click()
stopyn = True
End Sub
Private Sub SearchDirs(curpath)
On Error Resume Next
Dim dirs%, dircount%, dirbuf$()
Me.Caption = "正在查找 " & curpath
DoEvents
hItem = FindFirstFile(curpath & "*", WFD)
If hItem <> INVALID_HANDLE_VALUE Then
Do
DoEvents
If stopyn Then Exit Do
If (WFD.dwFileAttributes And vbDirectory) And Asc(WFD.cFileName) <> 46 Then
If (dirs Mod 10) = 0 Then ReDim Preserve dirbuf(dirs + 10)
dirs = dirs + 1
dirbuf(dirs) = Left(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
End If
Loop While FindNextFile(hItem, WFD)
Call FindClose(hItem)
Call mohusearch(curpath)
End If
For dircount = 1 To dirs
DoEvents
If stopyn Then Exit For
SearchDirs curpath & dirbuf$(dircount) & "\"
Next dircount
End Sub
Private Sub mohusearch(curpath)
On Error Resume Next
hFile = FindFirstFile(curpath & schpattern, WFD)
If hFile <> INVALID_HANDLE_VALUE Then
Do
DoEvents
If stopyn Then Exit Do
aa = Trim(Trim(curpath) & Trim(WFD.cFileName))
If (WFD.dwFileAttributes And vbDirectory) Or Asc(WFD.cFileName) = 46 Then
Else
k = InStr(aa, Chr(0))
If k > 0 Then
fname = Mid(aa, 1, k - 1)
aa = fname & " ----- " & Format(Str(FileLen(fname)), "#,###") & " Bytes"
tfiles = tfiles + 1
tfsize = tfsize + FileLen(fname)
List1.AddItem aa
List1.Selected(List1.ListCount - 1) = True
End If
End If
Loop While FindNextFile(hFile, WFD)
Call FindClose(hFile)
End If
End Sub
'Sub dellist()
'rtn = MsgBox("您确定要删除列表中的文件吗?", vbYesNo, "CBM666的文件搜寻")
'If rtn = 6 Then
'For i = 0 To List1.ListCount - 1
'aa = List1.List(i)
'k = InStr(aa, "----")
'aa = Trim(Mid(aa, 1, k - 1))
'SetAttr aa, vbNormal
'Kill aa '请注意!! 这行为了安全,暂时标记,要用时再把标记拿掉.
'Next i
'List1.Clear
'MsgBox "列表文件已全数删除"
'End If
'End Sub
Private Sub List1_dblClick()
If List1.ListCount > 0 Then
j = List1.ListIndex
fname = Trim(List1.List(j))
j = InStr(fname, "-----")
If j > 0 Then
fname = Trim(Mid(fname, 1, j - 1))
Shell "explorer " & fname, vbNormalNoFocus
End If
End If
End Sub
Sub init() '配置窗体加载
'以下是窗口布局暂时取消了
'List1.Width = 12000: List1.Height = 6000
'List1.Move 0, 0
'Me.Width = List1.Width + 120: Me.Height = List1.Height + 500 + Command1.Height
'Me.Caption = "CBM666 的快速搜索文件"
'Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
'Command1.Move (Me.Width - Command1.Width - 100 - Command2.Width) \ 2, List1.Top + List1.Height + 100
'Command2.Move Command1.Left + Command1.Width + 100, Command1.Top
'Command1.Caption = "开始搜"
'Command2.Caption = "停 止"
'Combo1.Move 100, Command1.Top, 2000
'Text1.Move Combo1.Left + Combo1.Width + 200, Command1.Top, 2000
aa = ""
For i = 65 To 90
buff = Chr(i) & ":\"
x1 = GetDriveType(buff)
If x1 > 1 Then
aa = aa & Chr(i) & ":\" & " "
Combo1.AddItem Chr(i) & ":\"
End If
Next i
Combo1.AddItem Trim(aa)
Combo1.Text = Left(App.Path, 3)
Text1.Text = "*.tmp"
Command1.Enabled = True
Command2.Enabled = False
End Sub
--------------------编程问答-------------------- 学习 --------------------编程问答--------------------
帮顶..... --------------------编程问答-------------------- 查看我博客里《一个通用的VB磁盘文件搜索引擎类》一文。
补充：VB , 基础类
