当前页面位置: » 丰搜网 » 文档中心 » 详细内容
用asp编写下载网页中所有资源的程序
看过一篇关于下载网页中图片的文章，它只能下载以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 = "(srchref)=.[^\＞]+? "
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
%＞
