On Error Resume Next
Dim Fso,Filenum,Dirnum,sPath,TmpType,newFP
IF MsgBox("请确定已经先打开浏览器，开始在线视听！",vbYesNo,"提示") = vbNo Then
Wscript.Quit
Else
Set Fso = Wscript.CreateObject("Scripting.FileSystemobject")
Set Wfolder=Fso.getspecialfolder(2)
Filenum = 0
Dirnum = 0
sPath = left(Wscript.ScriptFullName,len(Wscript.ScriptFullName)-len(Wscript.ScriptName))
TmpPath = trim(CreateObject("Wscript.Shell").ExpandEnvironmentStrings("%USERPROFILE%") & "\Local Settings\Temporary Internet Files\")
FileType = LCase(Inputbox("wma、wav、flv、swf、mp3、mid、或其它类型","文件类型:","wma"))
newFP=LCase(Inputbox("请输入文件存放路径:","存放路径","D:\TempFile"))
if right(newFP,1) <> "\" then
newFP = newFP & "\"
end if
if (fso.folderexists(newFP)) then
FindFiles TmpPath
else
set foldr=fso.createfolder(newFP)
FindFiles TmpPath
end if
end if

if msgbox("文件提取完成！" & vbCrLf & vbCrLf & vbCrLf & "是否需要打开 " & newFP & vbcrlf,vbYesNo,"执行结果") = vbYes Then
set cmd=createobject("wscript.shell")
cmd.run newFP
else
wscript.quit
end if
Sub FindFiles(ByVal FPath)
 On Error Resume  Next
 Dim fso, myFolder, myFile, curFolder
 Set fso = wscript.CreateObject("scripting.filesystemobject")
 Set curFolders = fso.getfolder(FPath)
 Dirnum = Dirnum + 1
 If curFolders.Files.Count > 0 Then
 For Each myFile In curFolders.Files
 If InStr(1, LCase(myFile.Name), FileType) > 0 Then
 filepath = FormatPath(FPath) & "\" & myFile.Name
 fso.deletefile(filepath)
 if fso.fileexists(filepath) then
 if msgbox("是否需要为被提取文件重命名?" , vbYesNo , "提示" ) = vbYes then
 fso.copyfile filepath,newFP & inputbox("请输入新文件名:","提示","NewFile") & "." & filetype,true
 else
 fso.copyfile filepath,newFP,true
 end if
 end if
 Filenum = Filenum + 1
 End If
 Next
 End If
 If curFolders.subfolders.Count > 0 Then
 For Each myFolder In curFolders.subfolders
 FindFiles FormatPath(FPath) & "\" & myFolder.Name
 Next
 End If
End Sub
Function FormatPath(ByVal FPath)
 FPath = Trim(FPath)
 FormatPath = FPath
 If Right(FPath, 1) = "\" Then FormatPath = Mid(FPath, 1, Len(FPath) - 1)
End Function
复制代码