批处理新手入门导读[视频教程]批处理基础视频教程[视频教程]VBS基础视频教程
[批处理文件精品]批处理版照片整理器[批处理文件精品]纯批处理备份&还原驱动在线第三方下载
返回列表 发帖

[原创] VBS全盘查找文件(2011年3月17日更新)

本次更新了程序对大、小写字母的兼容性-batman 2009年4月7日
-----------------------------
  1. '全盘查找文件
  2. dim path,allfiles,newpath,nowpath,inputfile,jiegou,choice
  3. on error resume next
  4. do
  5. allfiles="查找出来的文件如下:"
  6. filename=inputbox("请输入你要查找的文件:")
  7. if filename=false then
  8.    wcript.quit
  9.    else
  10.    set wshshell=createobject("wscript.shell")
  11.    set objfso=createobject("scripting.filesystemobject")
  12.    set objdrives=objfso.drives
  13.         for each objdrive in objdrives
  14.              wshshell.popup "正在查找盘符"&objdrive,1
  15.              search objdrive
  16.         next
  17.    if allfiles<>"查找出来的文件如下:" then
  18.       jiegou=allfiles&vbcrlf
  19.       else
  20.       jiegou="没有找到要查找的文件,"&vbcrlr&"请确信其存在。"
  21.    end if
  22.    wsh.echo "查找结束,"&jiegou
  23.    set objdrives=nothing
  24.    set objfiles=nothing
  25.    set objfolders=nothing
  26.    set objfso=nothing
  27.    set wshshell=nothing
  28. end if
  29. choice=msgbox ("是否需要再次查找?",vbyesno)
  30. loop while choice=vbyes
  31. function search(path)
  32.      set objfolders=objfso.getfolder(path).subfolders
  33.      for each objfolder in objfolders
  34.           nowpath=path&"\"&objfolder.name
  35.           set objfiles=objfso.getfolder(nowpath).files
  36.           for each objfile in objfiles
  37.                if lcase(objfile.name)=lcase(filename) then allfiles=allfiles&vbcrlf&objfile
  38.           next
  39.           newpath=path&"\"&objfolder.name
  40.           search newpath
  41.       next   
  42. end function
复制代码
-----------------------------
本次更新修正了以前的所有错误,并加入了硬盘判断以及搜索时的盘符选择,并大幅度简化了代码--batman 2011年3月17日
  1. Do While input = ""
  2.    input = InputBox ("请输入要查找的文件:")
  3. Loop
  4. Set fso = CreateObject ("scripting.filesystemobject")
  5. Set ws = CreateObject ("wscript.shell")
  6. Dim vbstr, choice
  7. For Each drive In fso.Drives
  8.     If drive.DriveType = 2 Then
  9.        choice = "0"
  10.        choice = MsgBox ("是否查找" & Left (drive, 1) & "盘", vbYesNo)
  11.        If choice = "6" Then
  12.           ws.Popup "正在查找" & Left (drive, 1) & "盘,请稍候。。。", 2
  13.           search drive & "\"
  14.        End If
  15.     End if   
  16. Next
  17. If vbstr = "" Then vbstr = "没有找到要查找的文件“" & input & "”,请确信它的确存在"
  18. MsgBox vbstr, 0, "查找结果"
  19. Set fso = Nothing
  20. Set ws = Nothing
  21. Function search (path)
  22.    On Error Resume Next
  23.    For Each file In fso.GetFolder (path).Files
  24.        If LCase (file.name) = LCase (input) Then vbstr = vbstr & file & vbCrLf
  25.    Next
  26.    For Each folder In fso.GetFolder (path).subfolders
  27.        search folder
  28.    Next
  29. End Function
复制代码
--------------------------------------------------------------------------------------------------------------------------
本次更新至模糊查找--batman 2011年3月17日
  1. Do While input = ""
  2.    input = InputBox ("请输入要查找的文件,如文件输入不全则执行模糊查找:")
  3. Loop
  4. Set fso = CreateObject ("scripting.filesystemobject")
  5. Set ws = CreateObject ("wscript.shell")
  6. Dim vbstr, choice
  7. For Each drive In fso.Drives
  8.     If drive.DriveType = 2 Then
  9.        choice = "0"
  10.        choice = MsgBox ("是否查找" & Left (drive, 1) & "盘", vbYesNo)
  11.        If choice = "6" Then
  12.           ws.Popup "正在查找" & Left (drive, 1) & "盘,请稍候。。。", 2
  13.           search drive & "\"
  14.        End If
  15.     End if   
  16. Next
  17. If vbstr = "" Then vbstr = "没有找到要查找的文件“" & input & "”,请确信它的确存在"
  18. fso.CreateTextFile ("temp.txt", 1, 0).Write vbstr
  19. ws.Run "temp.txt", 1, 0
  20. Set fso = Nothing
  21. Set ws = Nothing
  22. Function search (path)
  23.    On Error Resume Next
  24.    For Each file In fso.GetFolder (path).Files
  25.        If Replace (LCase (file.name), LCase (input), "") <> LCase (file.name) Then vbstr = vbstr & file & vbCrLf
  26.    Next
  27.    For Each folder In fso.GetFolder (path).subfolders
  28.        search folder
  29.    Next
  30. End Function
复制代码
[ 本帖最后由 batman 于 2011-3-17 18:49 编辑 ]
***共同提高***

再接一个按时间查找的

  1. '全盘查找N天内创建的文件
  2. dim path,newpath,nowpath,todays,jiegou
  3. on error resume next
  4. todays=inputbox("请输入回溯的天数:")
  5. if todays=false then
  6.    wcript.quit
  7.    else
  8.    set wshshell=createobject("wscript.shell")
  9.    set objfso=createobject("scripting.filesystemobject")
  10.    set objtext=objfso.opentextfile(wshshell.currentdirectory&"\temp.txt",2,true)
  11.    objtext.writeline "下面为系统在"&todays&"天内创建的文件:"
  12.    set objdrives=objfso.drives
  13.    for each objdrive in objdrives
  14.         search objdrive
  15.    next
  16.    objtext.close
  17.    wshshell.popup "查找结束",2
  18.    wshshell.run(wshshell.currentdirectory&"\temp.txt")
  19.    wsh.sleep 1000
  20.    objfso.deletefile(wshshell.currentdirectory&"\temp.txt")
  21.    set objdrives=nothing
  22.    set objfiles=nothing
  23.    set objfolders=nothing
  24.    set objfso=nothing
  25.    set wshshell=nothing
  26. end if
  27. function search(path)
  28.      set objfolders=objfso.getfolder(path).subfolders
  29.      for each objfolder in objfolders
  30.           nowpath=path&"\"&objfolder.name
  31.           set objfiles=objfso.getfolder(nowpath).files
  32.           for each objfile in objfiles
  33.                if objfile.datecreated>=dateadd("d",-todays,date) then objtext.writeline objfile
  34.           next
  35.           newpath=path&"\"&objfolder.name
  36.           search newpath
  37.       next   
  38. end function
复制代码

[ 本帖最后由 batman 于 2009-4-6 21:31 编辑 ]
***共同提高***

TOP

全盘找不能。子目录下或多级目录好像不支持呀

TOP

全盘找不能。子目录下或多级目录好像不支持呀
NetWorker

TOP

不行了。还得改进啊。 我怎么找不到我要的QQ。EXE啊?哎~~!
々超炫街舞々

TOP

全盘查找并运行!!!
  1. dim ws
  2. Set ws=CreateObject("wscript.shell")
  3. for each x in getobject("winmgmts:").execquery("select * from CIM_DataFile where FileName = '要找的文件名,例如:Ang' and Extension = '要找文件的扩展名,例如:exe'")
  4. str = x.name
  5. 'ws.run """"& str & """"
  6. ws.run chr(34) & str & chr(34)
  7. next
复制代码

TOP

回复 5楼 的帖子

  1. dim ws
  2. Set ws=CreateObject("wscript.shell")
  3. for each x in getobject("winmgmts:").execquery("select * from CIM_DataFile where FileName = 'qq' and Extension = 'exe'")
  4. str = x.name
  5. 'ws.run """"& str & """"
  6. ws.run chr(34) & str & chr(34)
  7. next
复制代码

TOP

返回列表