'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 ] |
