'Retrieves and saves all designated links on a page
'Can pass arguments INDEX URL, DEST FOLDER, TARGET EXTENSION
'or you will be asked interactively for them.

Option Explicit

Main

Sub Main
	Dim strUrl, strDest, strExt, strGuessFolder
	strUrl = GetUrl()
	If strUrl = "" Then Exit Sub
	strGuessFolder = UrlDocName(strUrl) 
	strDest = GetFolder(strGuessFolder)
	If strDest = "" Then Exit Sub
	strExt = GetFileExtension()
	If strExt = "" Then Exit Sub
	Slurp strUrl, strDest, strExt
End Sub

Function GetUrl()
Dim strUrl
	'Get the starting URL -- pretty much an index page linking to all the files we want
	If WScript.Arguments.Count = 0 Then
		strUrl = InputBox("Enter URL of page with links you want slurped. The http:// header is mandatory.", "Link Page URL", "http://")
	Else
		strUrl = WScript.Arguments(0)
	End If
	If Instr(strUrl, "http://") = 0 Then
		MsgBox "URL is missing the leading http://"
		GetUrl = ""
	Else
		GetUrl = strUrl
	End If
End Function

Function GetFolder(strGuess)
Dim fs, strDest
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Get the local path where desired files will be stored
	If WScript.Arguments.Count < 2 Then
		strDest = InputBox("Enter the local path where you want the files stored.", "Destination", fs.BuildPath(fs.GetParentFolderName(WScript.ScriptFullName), strGuess))
	Else
		strDest = WScript.Arguments(1)
	End If
	If Not fs.FolderExists(strDest) Then
		'Maybe we can create it. Does the parent folder exist?
		If Not fs.FolderExists(fs.GetParentFolderName(strDest)) Then
			MsgBox "Folder doesn't exist, and neither does the parent."
			GetFolder = ""
			Exit Function
		Else
			On Error Resume Next
			fs.CreateFolder(strDest)
			On Error Goto 0
		End If
	End If
	If Not fs.FolderExists(strDest) Then
		MsgBox "Folder doesn't exist and I can't create it."
		GetFolder = ""
		Exit Function
	End If
	GetFolder = strDest
End Function

Function GetFileExtension()
Dim strExt, intCounter
	'Get the extensions (file types) of the links we are after
	If WScript.Arguments.Count <> 3 Then
		strExt = InputBox("Enter the extension (no dots) of the files you want slurped.", "File Type", "mp3")
	Else
		strExt = WScript.Arguments(2)
	End If
	If strExt = "" Then
		MsgBox "No extension"
		GetFileExtension = ""
		Exit Function
	End If
	strExt = LCase(strExt)
	For intCounter = 1 To Len(strExt)
		If InStr("qwertyuiopasdfghjklzxcvbnm1234567890", Mid(strExt, intCounter, 1)) = 0 Then
			MsgBox "The character """ &  Mid(strExt, intCounter, 1) & """ is not allowed."
			Exit Function
			GetFileExtension = ""
		End If
	Next
	GetFileExtension = strExt
End Function

Function UrlDocName(strUrl)
Dim strDocName, intCounter
	'Get the last word in the URL
	If Right(strUrl, 1) = "/" Then
		strDocName = Left(strUrl, Len(strUrl) - 1)
		strDocName = Mid(strDocName, InStrRev(strDocName, "/") + 1)
	Else
		strDocName = Mid(strUrl, InStrRev(strUrl, "/") + 1)
	End If
	'Don't include file extensions
	If InStr(strDocName, ".") <> 0 Then
		strDocName = Left(strDocName, InStr(strDocName, ".") - 1)
	End If
	'Don't include CGI arguments
	If InStr(strDocName, "?") <> 0 Then
		strDocName = Left(strDocName, InStr(strDocName, "?") - 1)
	End If
	'Clean up any URL-encoding
	strDocName = Unescape(strDocName)
	'Replace illegal characters
	For intCounter = 1 To Len("/\:*?""<>|")
		strDocName = Replace(strDocName, Mid("/\:*?""<>|", intCounter, 1), "-")
	Next
	UrlDocName = strDocName  
End Function

Sub Slurp(strUrl, strDest, strExt)
Dim strLink, strPage, strFile
Dim intCounter
Dim fs
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Get the index page contents (has all the links)
	strPage = GetPage(strUrl)
	'Walk the page looking for links
	Do While GetFirstLink(strPage) <> ""
		'Get the first link in the page
		strLink = GetFirstLink(strPage)
		'Trim the first link away so we don't see it next time
		strPage = Mid(strPage, InStr(1, strPage, "<a href=", vbTextCompare))
		strPage = Mid(strPage, Len("<a href="))
		'Convert the relative (?) link we got into an absolute link
		strLink = MakeAbsolute(strLink, strUrl)
		'Is our link one of the targeted extensions?
		If Lcase(Right(strLink, Len(strExt) + 1)) = "." & strExt Then
			Status strLink
			'Does the destination file already exist?
			strFile = Mid(strLink, InStrRev(strLink, "/") + 1)
			strFile = fs.BuildPath(strDest, strFile)
			If fs.FileExists(strFile) Then
				Status vbTab & "Already downloaded"
			Else
				'Save the file. Verify the file exists and retry if needed.
				Status vbTab & "SAVING " & strFile
				If SaveBinary(strLink, strFile) Then
					If fs.FileExists(strFile) Then
						Status vbTab & "SUCCESS!"
					Else
						Status vbTab & "RETRYING " & strFile
						If SaveBinary(strLink, strFile) Then
							If fs.FileExists(strFile) Then
								Status vbTab & "SUCCESS!"
							Else
								Status vbTab & "################# FAILED #################"
							End If
						Else
							Status vbTab & "################# FAILED #################"
						End If
					End If
				Else
					Status vbTab & "RETRYING " & strFile
					If SaveBinary(strLink, strFile) Then
						If fs.FileExists(strFile) Then
							Status vbTab & "SUCCESS!"
						Else
							Status vbTab & "################# FAILED #################"
						End If
					Else
						Status vbTab & "################# FAILED #################"
					End If
				End If
			End If
		End If
	Loop
End Sub

Function GetPage(strUrl) 'As String
Dim web
Const WinHttpRequestOption_EnableRedirects = 6
	Set web = CreateObject("WinHttp.WinHttpRequest.5.1")
	web.Option(WinHttpRequestOption_EnableRedirects) = True
	web.Open "GET", strURL, False
	web.Send
	If web.Status = "200" Then
		GetPage = web.ResponseText
	Else
		GetPage = ""
	End If
End Function

Function SaveBinary(strUrl, strFile) 'As Boolean
Dim bin, web, varByteArray, strData, lngCounter, obj
Const adTypeBinary = 1
Const adSaveCreateOverWrite = 2
	On Error Resume Next
	Err.Clear
	Set web = CreateObject("WinHttp.WinHttpRequest.5.1")
	web.Open "GET", strURL, False
	web.Send
	If Err.Number <> 0 Then
		SaveBinary = False
		Exit Function
	End If
	If web.Status <> "200" Then
		SaveBinary = False
		Exit Function
	End If
	On Error Resume Next
	varByteArray = web.ResponseBody
	Set bin = Nothing
	Set bin = CreateObject("ADODB.Stream")
	If bin Is Nothing Then
		strData = ""
		For lngCounter = 0 to UBound(varByteArray)
			strData = strData & Chrw(Ascw(Chr(Ascb(Midb(varByteArray,lngCounter+1,1)))))
		Next
		String2File strData, strFile
		SaveBinary = True
	Else
		bin.Type = adTypeBinary
		bin.Open
		bin.Write varByteArray
		bin.SaveToFile strFile, adSaveCreateOverWrite
		If Err.Number = 0 Then
			SaveBinary = True
		Else
			SaveBinary = False
		End If
	End If
End Function

Function GetFirstLink(strPage)
Dim strUrl
Dim lngMarker
Dim strPeekText
	lngMarker = InStr(1, strPage, "<a href=", vbTextCompare)
	'Make sure the marker exists
	If lngMarker = 0 Then
		GetFirstLink = ""
		Exit Function
	End If
	lngMarker = InStr(lngMarker, strPage, "</a", vbTextCompare)
	If lngMarker = 0 Then
		GetFirstLink = ""
		Exit Function
	End If
	'Trim everything after the marker
	strPeekText = Left(strPage, lngMarker)
	'See if an "a" tag exists
	If InStrRev(strPeekText, "<a", Len(strPeekText), vbTextCompare) = 0 Then
		GetFirstLink = ""
		Exit Function
	End If
	'Trim everything before the "a" tag
	strPeekText = Mid(strPeekText, InStrRev(strPeekText, "<a", Len(strPeekText), vbTextCompare))
	If InStr(strPeekText, ">") = 0 Then
		'The marker is INSIDE the URL we are looking for. Push it to the end of the tag.
		lngMarker = InStr(lngMarker, strPage, ">")
	End If
	'Now we have a marker at or after the end of an "a" tag
	'Trim everything past the marker
	strUrl = Left(strPage, lngMarker)
	'Trim everything before the href tag
	strUrl = Mid(strUrl, InStrRev(strUrl, "href=", Len(strUrl), vbTextCompare) + 5)
	'If we have quotes, use them
	If Left(strUrl, 1) = Chr(34) Then strUrl = Mid(strUrl, 2)
	If InStr(strUrl, Chr(34)) <> 0 Then strUrl = Left(strUrl, InStr(strUrl, Chr(34)) - 1)
	'If we have apostrophes, use them instead of quotes
	If Left(strUrl, 1) = "'" Then strUrl = Mid(strUrl, 2)
	If InStr(strUrl, "'") <> 0 Then strUrl = Left(strUrl, InStr(strUrl, "'") - 1)
	'We might have a leading space. Not sure how, but trim to be safe.
	strUrl = Trim(strUrl)
	'Trim everything past the first tag end
	If InStr(strUrl, ">") <> 0 Then strUrl = Left(strUrl, InStr(strUrl, ">") - 1)
	'Trim everything past the first space
	If InStr(strUrl, " ") <> 0 Then strUrl = Left(strUrl, InStr(strUrl, " "))
	'Trim everything past the first tab
	If InStr(strUrl, vbTab) <> 0 Then strUrl = Left(strUrl, InStr(strUrl, vbTab))
	'That should be all!
	GetFirstLink = strUrl
End Function


Function MakeAbsolute(strHref, strCurrentPage)
'Converts strHref from root or relative link to absolute link.
'strCurrentPage MUST be an absolute URL. 
Dim strMakeAbsolute, strRoot
	strMakeAbsolute = strHref
	'Is it already absolute?
	If Left(strMakeAbsolute, 7) = "http://" Then
		MakeAbsolute = strMakeAbsolute
		Exit Function
	End If
	'Figure out what the root page is
	strRoot = strCurrentPage
	If InStr(8, strRoot, "/") <> 0 Then
		'Make the root so it DOES NOT have a trailing slash
		strRoot = Left(strRoot, InStr(8, strRoot, "/") - 1)
	End If
	'Is a root reference used?
	If Left(strMakeAbsolute, 1) = "/" Then
		MakeAbsolute = strRoot & strMakeAbsolute
		Exit Function
	End If
	'A relative link is used (it must be at this point!)
	MakeAbsolute = Left(strCurrentPage, InStrRev(strCurrentPage, "/")) & strMakeAbsolute
End Function

Sub String2File(strData, strFileName)
'Writes a string to a file
Dim fs 'As Scripting.FileSystemObject
Dim ts 'As Scripting.TextStream
Dim lngChar, strBlock, intChar
Const ForWriting = 2
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set ts = fs.OpenTextFile(strFileName, ForWriting, True)
	Err.Clear
	On Error Resume Next
	ts.Write strData
	If Err.Number <> 0 Then
		'Must have hit one of the "problem characters" between 128 and 159
		For lngChar = 1 To Len(strData) Step 100
			Err.Clear
			ts.Write Mid(strData, lngChar, 100)
			If Err.Number <> 0 Then
				'This block of 100 must have the problem. Write them one-at-a-time
				strBlock = Mid(strData, lngChar, 100)
				For intChar = 1 To Len(strBlock)
					ts.Write Chr(255 And AscW(Mid(strBlock, intChar)))
				Next
			End If
		Next
	End If
	ts.Close
End Sub

Sub Status(strMessage)
	If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then
		Wscript.Echo strMessage
	End If
End Sub