Use ASP to write a program to download all the resources in the Web page

Source: Internet
Author: User
Tags exit chr split trim

Read an article about downloading pictures in the Web page, it can only download images with HTTP headers, I made some improvements, you can download all the connection resources in the Web page, and according to the directory structure of the Web page to build a local directory, storage resources.

Download.asp?url= the page you want to download

The download.asp code is as follows:

<%
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) ' Chinese filename conversion
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) ' Directory-building program, if there is a multilevel directory, then one-level creation
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, str,instrrev). /") +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
' Sample code
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 the 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
%>

Related Article

Contact Us

The content source of this page is from Internet, which doesn't represent Alibaba Cloud's opinion; products and services mentioned on that page don't have any relationship with Alibaba Cloud. If the content of the page makes you feel confusing, please write us an email, we will handle the problem within 5 days after receiving your email.

If you find any instances of plagiarism from the community, please send an email to: info-contact@alibabacloud.com and provide relevant evidence. A staff member will contact you within 5 working days.

A Free Trial That Lets You Build Big!

Start building with 50+ products and up to 12 months usage for Elastic Compute Service

  • Sales Support

    1 on 1 presale consultation

  • After-Sales Support

    24/7 Technical Support 6 Free Tickets per Quarter Faster Response

  • Alibaba Cloud offers highly flexible support services tailored to meet your exact needs.