- 原程序轉帖而來，不過virus free是可以保證的。否則寥寥百十行如果真有virus，KD眾高手也一定會看出來。
- 可考慮先按piaoyao說的辦法修改McAfee的設置，然後試試下麵的新版（字符串http://被隱藏了，但願它就是McAfee指認的virus
<html>
<title>Music downloader</title>
<head>
<HTA:APPLICATION
SINGLEINSTANCE="yes"
BORDER="thin"
/>
</head>
<script language="VBScript">
Option Explicit
Dim https
https="h"&"t"&"t"&"p"&":"&"/"&"/"
Sub Window_OnLoad
'bbs.wenxuecity.com/music-album/630946.html
'bbs.wenxuecity.com/music-album/637616.html
url2.value=https&"bbs.wenxuecity.com/music-album/630946.html"
url2.focus
url2.select
moveto screen.width/2 - 650/2,screen.height/2 - 550/2
resizeto 650,550
End Sub
Sub PrintText(Text,Flag)
TextArea.InnerHTML = TextArea.InnerHTML & Text
If Flag Then
TextArea.InnerHTML = TextArea.InnerHTML & "<br>"
End If
document.body.doScroll("pageDown")
Sleep 10
End Sub
Function GetURL(URL)
Dim http
Set http = CreateObject("Microsoft.XmlHttp")
http.open "GET", URL, False
http.send ""
GetURL=http.ResponseText
End Function
Function GetURLBinary(URL)
Dim http
Set http = CreateObject("Microsoft.XmlHttp")
http.open "GET", URL, True
http.send ""
Do While (http.readyState <> 4) 'http.status <> 200) 'http.readyState <> 4 Or
Sleep 2000
Loop
If (http.status = 200) Then
GetURLBinary=http.ResponseBody
End If
End Function
Function RegExpMatches(patrn, strng)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.IgnoreCase = True
regEx.Global = True
Set RegExpMatches = regEx.Execute(strng)
End Function
Function ReplaceString(Str, patrn, replStr)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = patrn
regEx.IgnoreCase = True
ReplaceString = regEx.Replace(Str, replStr)
End Function
Sub WriteBinary(bstr, path)
Dim bs
Set bs = CreateObject("ADODB.Stream")
bs.Type = 1
bs.Open
bs.Write bstr
bs.SaveToFile path, 2
End Sub
Sub Sleep(MSecs)
Dim fso, objOutputFile
Set fso = CreateObject("Scripting.FileSystemObject")
If Fso.FileExists("helper.vbs")=False Then
Set objOutputFile = fso.CreateTextFile("helper.vbs", True)
objOutputFile.Write "wscript.sleep WScript.Arguments(0)"
objOutputFile.Close
End If
CreateObject("WScript.Shell").Run "helper.vbs "&MSecs,1,True
End Sub
Sub ButtonClick
Dim URL, File, Content, Match, Matches
URL = url2.value
'PrintText "URL = "+URL,True
Content = GetURL(URL)
Set Matches = RegExpMatches("file=[""']?(.*?\.xml)", Content)
If Matches.Count = 0 Then
Set Matches = RegExpMatches("src=[""']?(.*?\.m3u)", Content)
End If
If Matches.Count = 0 Then
Set Matches = RegExpMatches("playlist_url=[""']?(.*?\.xspf)", Content)
End If
If Matches.Count = 0 Then
PrintText "No playlist found. Now trying to download from the post",True
End If
For Each Match in Matches
'URL = Mid(Match.Value,6) ' This number needs to be reviewed
URL = Match.SubMatches.Item(0)
PrintText "<br>Playlist = "+URL,True
Content = GetURL(URL)
PrintText Content&"<br/>",True
Next
Set Matches = RegExpMatches(https&"[\w\d:#@%/;$()~_?\+=\\\.&-]*\.(mp3|wma)", Content)
For Each Match in Matches
URL=Match.Value
If (File = "") Then
PrintText "***** Files in "&CreateObject("wscript.shell").CurrentDirectory&"<br/>",True
End If
File = ReplaceString(URL, ".*/", "")
PrintText "Downloading "+URL+" ... ",False
URL=GetURLBinary(URL)
If (LenB(URL) = 0) Then
PrintText "Not found",True
Else
WriteBinary URL, File
PrintText "Done",True
End If
Next
If Matches.Count <> 0 Then
PrintText "<br/>Enjoy the music!",True
Else
PrintText "No music files found.",True
End If
End Sub
</script>
<body STYLE="color:white;
filter:progid:DXImageTransform.Microsoft.Gradient
(GradientType=1, StartColorStr='#000000', EndColorStr='#0000FF')">
<input type="text" name="url2" size=70>
<input class="button" TYPE=BUTTON value="Download" name="btnTestButton" onClick="ButtonClick">
<span id = "TextArea"></span>
</body>
</html>
