Wolf's ASP Toolbox-automatically get remote pictures #Write by Jaron

Program implementation function: Automatically download pictures of files from remote pages to local server

' Save the following as Save2local.asp
' Test: save2local.asp?url=http://ent.sina.com.cn/s/m/2003-11-11/1411231388.html

<%
' Parameter settings start
url = Request ("url")
LOCALADDR = Server. MapPath ("images_remote/") ' Save to local directory
Localdir = "images_remote/" ' relative path to HTTP access
allowfileext = filename format supported by "Jpg|bmp|png|gif"
' Parameter set complete

If Createdir (localaddr) = False Then
Response. Write "Failed to create directory, please check directory permissions"
Response. End
End If
Response. Write convert2localaddr (Url,localaddr,localdir)

function Convert2localaddr (url,localaddr,localdir)
' Parameter description
' URL page address
' LOCALADDR Save the local physical address
' Localdir relative path
strcontent = gethttppage (URL)
Set objRegExp = New Regexp
Objregexp.ignorecase = True
Objregexp.global = True
Objregexp.pattern = "Set matches =objregexp.execute (strcontent)
For the Match in matches
Retstr = retstr & Getremoteimages (Match.value)
Next
Imagesarray=split (retstr, "| |")
Remoteimage= ""
Localimage= ""
For I=1 to UBound (Imagesarray)
If Imagesarray (i) <> "" and InStr (Remoteimage,imagesarray (i)) <1 then
Fname=baseurl&cstr (I&mid (Imagesarray (i), InStrRev (Imagesarray (i), "."))
Imagesfilename = Imagesarray (i)
Allowfileextarray = Split (Allowfileext, "|")
Isgetfile = False
For tmp = 0 To UBound (allowfileextarray)
If LCase (Getfileext (imagesfilename)) = Allowfileextarray (TMP) Then
Isgetfile=true
End If
Next
If Isgetfile = True Then
NewFileName = Generaterandomfilename (fname)
Call Save2local (Imagesfilename,localaddr & "/" & NewFileName)
remoteimage=remoteimage& "| |" & Imagesfilename
localimage=localimage& "| |" & LOCALDIR & NewFileName
End If
End If
Next
Arrnew=split (localimage, "| |")
Arrall=split (remoteimage, "| |")
For I=1 to UBound (arrnew)
Strcontent=replace (Strcontent,arrall (i), arrnew (i))
Next
CONVERT2LOCALADDR = strcontent
End Function

function Getremoteimages (str)
Set OBJREGEXP1 = New Regexp
Objregexp1.ignorecase = True
Objregexp1.global = True
Objregexp1.pattern = "http://.+?"
Set Mm=objregexp1.execute (str)
For each Match1 in mm
Tmpaddr = Left (Match1.value,len (Match1.value)-1)
getremoteimages=getremoteimages& "| |" & REPLACE (replace (TMPADDR, "" "," ")," "", "")
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 gethttpimg (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
Gethttpimg=http.responsebody
Set http=nothing
If Err.number<>0 then err. Clear
End Function

function Save2local (from,tofile)
Dim Geturl,objstream,imgs
Geturl=trim (from)
Imgs=gethttpimg (Geturl)
Set objstream = Server.CreateObject ("ADODB. Stream ")
objStream.Type =1
objStream.Open
Objstream.write IMGs
Objstream. SaveToFile tofile,2
Objstream. Close ()
Set objstream=nothing
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
Getu