中国DOS联盟

安装：安装于“网上邻居”右键菜单， 要求：如果使用非IE浏览器，则不要退于系统托盘区，虽不用窗口置顶，至少保持于任务栏。 CC_DeadLink→VBS版 [ Last edited by baomaboy on 2007-5-10 at 03:15 AM ]



'Check Clear DeadLink.VBS by baomaboy Dim WshSHell,FSO On Error Resume Next Set WshSHell = WScript.CreateObject("WScript.Shell") Set FSO = CreateObject("Scripting.FileSystemObject") Set Args = WScript.Arguments CloseTime = 5 FileName = WScript.ScriptName FileFullName = WScript.ScriptFullName FilePath = FSO.GetParentFolderName(FileFullName) InsPath = FSO.GetSpecialFolder(1) InsFullName = FSO.BuildPath(InsPath ,FileName) LnkPathAll = WshSHell.SpecialFolders("Favorites") TemFileName = "CC_DeadLink.txt" TemFilePath = FSO.GetSpecialFolder(1) Copyright="baomaboy" QQ="QQ:25926183" Email="Email:fty1995@163.com" InsTitle="检测收藏夹链接有效性" InsAnswer="检测收藏夹链接有效性" RegPath1="HKEY_CLASSES_ROOT\CLSID\{208D2C60-3AEA-1069-A2D7-08002B30309D}\shell\CC-DeadLink\" RegValue1="检测收藏夹(&A)" RegForm1="REG_SZ" RegPath2="HKEY_CLASSES_ROOT\CLSID\{208D2C60-3AEA-1069-A2D7-08002B30309D}\shell\CC-DeadLink\command\" RegValue2="wscript.exe "&InsFullName RegForm2="REG_SZ" IF FileFullName <> InsFullName then intAnswer = MsgBox("【是】将“"+ InsAnswer +"”加入到网上邻居右键菜单，"&Chr(10)&Chr(10)&"【否】将“"+ InsAnswer +"”从右键网上邻居菜单删除。 ", vbQuestion + vbYesNoCancel, "安装 - "+ InsTitle +" - "+ Copyright) If intAnswer = vbYes Then WshSHell.RegWrite RegPath1,RegValue1,RegForm1 WshSHell.RegWrite RegPath2,RegValue2,RegForm2 FSO.GetFile(FileFullName).Copy(InsFullName) WshSHell.popup _ "添加脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _ "添加注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+ _ chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _ chr(10) & "Copyright(C) " + Copyright +" " & QQ &" " + Email _ , CloseTime, "安装成功 - "+ InsTitle +" - "+ Copyright, 0 + 64 end if If intAnswer = vbNo Then WshSHell.RegDelete RegPath2 WshSHell.RegDelete RegPath1 FSO.DeleteFile InsFullName WshSHell.popup _ "删除脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _ "删除注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+ _ chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _ chr(10) & "Copyright(C) " + Copyright +" " & QQ &" " + Email _ , CloseTime, "卸载成功 - "+ InsTitle +" - "+ Copyright, 0 + 64 End If If intAnswer = vbCancel Then end if ELSE set outFile = FSO.OpenTextFile(FSO.BuildPath(TemFilePath,TemFileName),2) TimeSpend = Timer scan LnkPathAll TimeSpend = round(Timer - TimeSpend,2) outFile.close if FileTotal="" then FileTotal=0 if DirTotal="" then DirTotal=0 txtResult = "共搜索目录：" & DirTotal & "个。" & vbCrLf & "失效链接数：" & FileTotal & "个。"& vbCrLf &"共用去时间：" & round(TimeSpend,0) & "秒。" intAnswer = MsgBox(txtResult&Chr(10)&Chr(10)&"【是】将删除失效的链接文件并删除链接列表文件，"&Chr(10)&Chr(10)&"【否】将放弃删除失效的链接并查看失效链接列表。", vbQuestion + vbYesNo, InsTitle +" - CC DeadLink By "+ Copyright) If intAnswer = vbYes Then Set FR=FSO.OpenTextFile(FSO.BuildPath(TemFilePath,TemFileName),1,false,-1) Do Until FR.AtEndOfStream FSO.DeleteFile FR.ReadLine Loop FR.Close FSO.DeleteFile FSO.BuildPath(TemFilePath,TemFileName) end if If intAnswer = vbNo Then WshSHell.Run ("Notepad.exe "&FSO.BuildPath(TemFilePath ,TemFileName)) end if End IF Set ie = Nothing Set WshSHell = Nothing Set FSO = Nothing Set Args = Nothing WScript.Quit(0) sub scan(folder) Set folder=fso.GetFolder(folder) DirTotal = DirTotal + 1 Set files=folder.files If files.Count > 0 Then for each file in files If LCase(fso.GetExtensionName(file))="url" Then Set ReadFile = FSO.OpenTextFile(file.Path,1) Do Until ReadFile.AtEndOfStream urlstr=ReadFile.ReadLine if LCase(left(urlstr,4))="url=" then urlstr=right(urlstr,len(urlstr)-4) Set ie=WScript.CreateObject("InternetExplorer.Application") ie.visible=false ie.navigate urlstr Check = True Do err.Clear Wscript.Sleep 1000 On Error Resume Next title=ie.Document.title if err.number = 0 then Check = False On Error GoTo 0 Loop Until Check = False Do Wscript.Sleep 1000 title=ie.Document.title Loop Until (ie.ReadyState=4) if left(title,6) = "找不到服务器" or left(title,6) = "没有可以显示" then outFile.WriteLine file FileTotal = FileTotal + 1 end if exit do end if Loop if WshSHell.AppActivate(title)="True" then WshSHell.SendKeys "^W" else ie.quit end if ReadFile.Close Wscript.Sleep 1000 End If Next End If Set subfolders=folder.subfolders for each subfolder in subfolders scan(subfolder) next End Sub

[ Last edited by baomaboy on 2008-3-24 at 11:45 PM ]

兄又出一作，真是令人高兴。 加分鼓励一下。

谢谢lxmxn版主，呵呵 你的加分让我从高级变银牌了， 谢谢谢谢

高手，很多对象的方法都看不懂，高手有没有这方面的资料啊？

只不过是把学习积累的资料分拆组合加上自己的创意而已，说来不管是大软件还是小脚本，按模块分拆开来全都是很常见于教科书中的东西，重要的是把这些很普通的功能组合起来实现你的创意。 除了一本VBScript语言参考.chm其他资料全部来源于网络。

不错,收下保存