Just need 4 steps.
- Create a directory, like C:/media
- Copy this code and paste into an editor like NOTEPAD
- Save the file in the directory created above, naming it download.hta (Be careful here not to save as .txt [Save as type=All files])
- Double-click download.hta, paste YYKD link and click [Download]
<html>
<title>Music downloader</title>
<head>
<HTA:APPLICATION
SINGLEINSTANCE="yes"
BORDER="thin"
/>
</head>
<script language="VBScript">
Option Explicit
Dim https, fso, http, urlregex
https="h"&"t"&"t"&"p"&":"&"/"&"/"
urlregex = https&"[\w\d:!#@%/;$()~_?\+=\\\. -]*?(\.mp3|wma)"
Set fso = CreateObject("Scripting.FileSystemObject")
Sub Window_OnLoad
url2.value="http://bbs.wenxuecity.com/music/662080.html"
url2.focus
url2.select
moveto screen.width/2 - 750/2,screen.height/2 - 550/2
resizeto 900,550
SetLocale(2052)
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 Recursion(DirectoryPath)
If DirectoryPath = "" Or fso.FolderExists(DirectoryPath) Then Exit Function
Call Recursion(fso.GetParentFolderName(DirectoryPath))
fso.CreateFolder(DirectoryPath)
End Function
Sub PrintError
If Err.Number <> 0 Then
WScript.Echo "Error: " & Err.Number
WScript.Echo "Error (Hex): " & Hex(Err.Number)
WScript.Echo "Source: " & Err.Source
WScript.Echo "Description: " & Err.Description
Err.Clear
End If
End Sub
Sub CreateHTTP
On Error Resume Next
Set http = CreateObject("MSXML2.ServerXMLHTTP.4.0")
IF Err.Number = 0 Then
http.setRequestHeader "charset", "gb2312"
http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
Exit Sub
End If
Err.Clear
Set http = CreateObject("MSXML2.ServerXMLHTTP.3.0")
IF Err.Number = 0 Then
http.setRequestHeader "charset", "utf-8"
http.setRequestHeader "Content-Type", "content=text/html; charset=utf-8"
Exit Sub
End If
Set http = CreateObject("Microsoft.XmlHttp")
End Sub
Function GetURL(URL)
http.open "GET", URL, False
http.send ""
GetURL=StripNonASCII(http.ResponseBody)
End Function
Function GetURLBinary(URL)
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
regEx.Global = 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 objOutputFile
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
Function StripNonASCII(Binary)
Dim I, S
For I = 1 To LenB(Binary)
If AscB(MidB(Binary, I, 1)) >= 32 And AscB(MidB(Binary, I, 1)) < 128 Then
S = S & Chr(AscB(MidB(Binary, I, 1)))
End If
Next
StripNonASCII = S
End Function
Function ArrayConcat(arr1, arr2)
Dim i, ele, ele2, flag
ReDim ret(UBound(arr1) + arr2.Count)
i = 0
For Each ele in arr1
ret(i) = ele
i = i + 1
Next
For Each ele in arr2
flag=0
For Each ele2 in ret
If StrComp(ele2,ele) = 0 Then
flag=1
End If
Next
If flag = 0 Then
ret(i) = ele
i = i + 1
End If
Next
ReDim ret2(i-1)
Do While i > 0
i=i-1
ret2(i)=ret(i)
Loop
ArrayConcat = ret2
End Function
Sub DownloadLocal(File)
Dim Array2, objFile, Dir, URL, File2
Const ForReading = 1
Dir="cd"
If Not fso.FileExists(File) Then
PrintText File&" does not exist.",True
Exit Sub
End If
Set objFile = fso.OpenTextFile(File, ForReading, False, -1)
Recursion(Dir)
PrintText "Current directory is ["&Dir&"]",True
Do Until objFile.AtEndOfStream
Dim line
line=objFile.ReadLine
Set Array2=RegExpMatches("^\s*Dir\s*=\s*(.*?)\s*$", line)
If Array2.Count > 0 Then
Dir=Array2.Item(0).Submatches(0)
PrintText "Changing directory to ["&Dir&"]",True
Recursion(Dir)
End If
Set Array2=RegExpMatches("^\s*("&urlregex&")\s+(.*?)\s*$", line)
If Array2.Count > 0 Then
URL=Array2.Item(0).Submatches(0)
File2=Dir & "\" & Array2.Item(0).Submatches(2) & Array2.Item(0).Submatches(1)
If fso.FileExists(File2) Then
PrintText "<font color='green'>" & URL & "...exists in " & File2 & "</font>",True
Else
PrintText Array2.Item(0).Submatches(0)&"...",False
WriteBinary GetURLBinary(URL), File2
PrintText "Done",True
End If
End If
Loop
objFile.Close
PrintText "<br/>Enjoy the music!",True
End Sub
Sub ButtonClick
Dim URL, File, Content, Content2, Musics, Match, Matches, curdir
CreateHTTP
curdir = CreateObject("wscript.shell").CurrentDirectory
If RegExpMatches("("&https&")", url2.value).Count = 0 Then
PrintText "<br />* Music files are put in subdirectories of "&curdir&"<br/>",True
DownloadLocal(url2.value)
Exit Sub
End If
URL = url2.value
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 "<br>Trying to download links from the post as no playlist found",True
End If
Musics=Array()
For Each Match in Matches
URL = Match.SubMatches.Item(0)
PrintText "<br>Playlist = "+URL,True
Content2 = GetURL(URL)
PrintText "<br />"&Content2&"<br />",True
Musics = ArrayConcat(Musics, RegExpMatches(urlregex, Content2))
Next
Dim objTextFile
Set objTextFile = fso.CreateTextFile("download.log", 8, True)
objTextFile.Write Content
Musics = ArrayConcat(Musics, RegExpMatches(urlregex, Content))
For Each URL in Musics
Do
If (File = "") Then
PrintText "* Music files are put in subdirectories of "&curdir&"<br/>",True
End If
File = ReplaceString(URL, https, "")
File = ReplaceString(File, "/", "\")
File = ReplaceString(File, "\?", "@")
If fso.FileExists(File) Then
PrintText "<font color='green'>" & URL & "..." & "Exists</font>",True
Exit Do
End If
PrintText URL+" ... ",False
Recursion(fso.GetParentFolderName(File))
If 1=1 Then
URL=GetURLBinary(URL)
If (LenB(URL) = 0) Then
PrintText "Not found",True
Else
WriteBinary URL, File
PrintText "Done",True
End If
End If
Loop While False
Next
If UBound(Musics) >= 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 style="width:60px"></span><input TYPE=BUTTON value="Quit" onClick="Self.Close">
<span id = "TextArea"></span>
</body>
</html>
Second method of using the program.
When you have music links on your computer and want to download them and classify them into different directories, please follow this procedure:
- Start "notepad" and put music links and their names in the following way:
Dir=Mozart
There should be no spaces in music links, if there are, replaces each of them with %20
http://space.wenxuecity.com/media/201205/16/1111111111.mp3 name 1
http://space.wenxuecity.com/media/201205/16/2222222222.mp3 name 2
Dir=Debussy
http://space.wenxuecity.com/media/201205/16/3333333333.mp3 name 3
http://space.wenxuecity.com/media/201205/16/4444444444.mp3 name 4
Names can contain chinese characters and spaces. - Save the content to "C:/media/playlist.txt" (without quites). MAKE SURE you choose encoding as "UNICODE".
- Now, put "playlist.txt" in the address bar and clicking "Download" button will put 1&2 in C:/media/Mozart and 3&4 in C:/media/Debussy.
