＜% 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
注：本站部分文章源于互联网，版权归原作者所有！如有侵权，请原作者与本站联系，本站将立即删除！ 本站文章除特别注明外均可转载，但需注明出处！ [MinTao学以致用网] 
