用ASP编写下载网页中所有资源的程序

发布时间：2011-06-11 00:32:06作者：知识屋

看过一篇关于下载网页中图片的文章，它只能下载以http头的图片，我做了些改进，可以下载网页中的所有连接资源，并按照网页中的目录结构建立本地目录，存放资源。

　　download.asp?url=你要下载的网页

　　download.asp代码如下：

＜%

	Server.ScriptTimeout=9999

	function SaveToFile(from,tofile)

	on error resume next

	dim geturl,objStream,imgs

	geturl=trim(from)

	Mybyval=getHTTPstr(geturl)

	Set objStream = Server.CreateObject("ADODB.Stream")

	objStream.Type =1

	objStream.Open

	objstream.write Mybyval

	objstream.SaveToFile tofile,2

	objstream.Close()

	set objstream=nothing

	if err.number＜＞0 then err.Clear

	end function

	

	function geturlencodel(byval url)'中文文件名转换

	Dim i,code

	geturlencodel=""

	if trim(Url)="" then exit function

	for i=1 to len(Url)

	code=Asc(mid(Url,i,1))

	if code＜0 Then code = code + 65536

	If code＞255 Then

	geturlencodel=geturlencodel&"%"&Left(Hex(Code),2)&"%"&Right(Hex(Code),2)

	else

	geturlencodel=geturlencodel&mid(Url,i,1)

	end if

	next

	end function

	function getHTTPPage(url)

	on error resume next

	dim http

	set http=Server.createobject("Msxml2.XMLHTTP")

	Http.open "GET",url,false

	Http.send()

	if Http.readystate＜＞4 then exit function

	getHTTPPage=bytes2BSTR(Http.responseBody)

	set http=nothing

	if err.number＜＞0 then err.Clear

	end function

	

	Function bytes2BSTR(vIn)

	dim strReturn

	dim i,ThisCharCode,NextCharCode

	strReturn = ""

	For i = 1 To LenB(vIn)

	ThisCharCode = AscB(MidB(vIn,i,1))

	If ThisCharCode ＜ &H80 Then

	strReturn = strReturn & Chr(ThisCharCode)

	Else

	NextCharCode = AscB(MidB(vIn,i+1,1))

	strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))

	i = i + 1

	End If

	Next

	bytes2BSTR = strReturn

	End Function

	

	function getFileName(byval filename)

	if instr(filename,"/")＞0 then

	fileExt_a=split(filename,"/")

	getFileName=lcase(fileExt_a(ubound(fileExt_a)))

	if instr(getFileName,"?")＞0 then

	getFileName=left(getFileName,instr(getFileName,"?")-1)

	end if

	else

	getFileName=filename

	end if

	end function

	

	function getHTTPstr(url)

	on error resume next

	dim http

	set http=server.createobject("MSXML2.XMLHTTP")

	Http.open "GET",url,false

	Http.send()

	if Http.readystate＜＞4 then exit function

	getHTTPstr=Http.responseBody

	set http=nothing

	if err.number＜＞0 then err.Clear

	end function

	

	

	Function CreateDIR(ByVal LocalPath) '建立目录的程序，如果有多级目录，则一级一级的创建

	　On Error Resume Next

	　LocalPath = Replace(LocalPath, "", "/")

	　Set FileObject = server.CreateObject("Scripting.FileSystemObject")

	　patharr = Split(LocalPath, "/")

	　path_level = UBound(patharr)

	　For I = 0 To path_level

	　　If I = 0 Then pathtmp = patharr(0) & "/" Else pathtmp = pathtmp & patharr(I) & "/"

	　　　cpath = Left(pathtmp, Len(pathtmp) - 1)

	　　If Not FileObject.FolderExists(cpath) Then FileObject.CreateFolder cpath

	　Next

	　Set FileObject = Nothing

	　If Err.Number ＜＞ 0 Then

	　　CreateDIR = False

	　　Err.Clear

	　Else

	　　CreateDIR = True

	　End If

	End Function

	

	function GetfileExt(byval filename)

	　fileExt_a=split(filename,".")

	　GetfileExt=lcase(fileExt_a(ubound(fileExt_a)))

	end function

	

	function getvirtual(str,path,urlhead)

	　if left(str,7)="http://" then

	　　url=str

	　elseif left(str,1)="/" then

	　　start=instrRev(str,"/")

	　　if start=1 then

	　　　url="/"

	　　else

	　　　url=left(str,start)

	　　end if

	　　url=urlhead&url

	　　elseif left(str,3)="../" then

	　　str1=mid(str,inStrRev(str,"../")+2)

	　　ar=split(str,"../")

	　　lv=ubound(ar)+1

	　　ar=split(path,"/")

	　　url="/"

	　　for i=1 to (ubound(ar)-lv)

	　　　url=url&ar(i)

	　　next

	　　url=url&str1

	　　url=urlhead&url

	　else

	　　url=urlhead&str

	　end if

	　getvirtual=url

	end function

	'示例代码

	dim dlpath

	

	virtual="/downweb/"

	truepath=server.MapPath(virtual)

	if request("url")＜＞ "" then

	　url=request("url")

	　fn=getFileName(url)

	　urlhead=left(url,(instr(replace(url,"//",""),"/")+1))

	　urlpath=replace(left(url,instrRev(url,"/")),urlhead,"")

	　strContent = getHTTPPage(url)

	　mystr=strContent

	　Set objRegExp = New Regexp

	　objRegExp.IgnoreCase = True

	　objRegExp.Global = True

	　objRegExp.Pattern = "(src|href)=.[^＞]+? "

	　Set Matches =objRegExp.Execute(strContent)

	　For Each Match in Matches

	　　str=Match.Value

	　　str=replace(str,"src=","")

	　　str=replace(str,"href=","")

	　　str=replace(str,"""","")

	　str=replace(str,"'","")

	filename=GetfileName(str)

	　　getRet=getVirtual(str,urlpath,urlhead)

	　　temp=Replace(getRet,"//","**")

	　　start=instr(temp,"/")

	　　endt=instrRev(temp,"/")-start+1

	　　if start＞0 then

	　　　repl=virtual&mid(temp,start)&" "

	　　　'response.Write repl&"＜br＞"

	　　　mystr=Replace(mystr,str,repl)

	

	　　dir=mid(temp,start,endt)

	　　temp=truepath&Replace(dir,"/","")

	　　CreateDir(temp)

	　　'response.Write getRet&"||"&temp&filename&"＜br＞＜br＞"

	　　SaveToFile getRet,temp&filename

	　end if

	Next

	set Matches=nothing

	end if

	

	%＞