ASP save remote picture (broken anti-theft chain system)

Simple instance One

This is available to the XMLHTTP and file Object FSO,

The code is as follows

Copy Code

<% Function saveremotefile (Ssavepath,sremotefileurl) on Error Resume Next Saveremotefile = False Dim oxml: Set oXML = Server.CreateObject ("Microsoft.XMLHTTP") with oXML . Open "Get", Sremotefileurl,false, "", "" . Send If. status<>200 Then Exit Function Remotedate =. Responsebody End With Set oxml = Nothing Dim ostream:set ostream = Server.CreateObject ("ADODB.stream") with Ostream . Type = 1 . Open . Write remotedate . SaveToFile ssavepath,2 If err.number=0 Then saveremotefile = True . Close () End With Set ostream = Nothing End Function ' calls the method as follows Saveaddr=server.mappath ("Demo.gif") Sourceurl= "Http://www.google.cn/intl/zh-CN/images/logo_cn.gif" Call Saveremotefile (saveaddr,sourceurl) %

Instance 1 Save the picture locally and generate a thumbnail

The ASP obtains the remote picture stream data through the XMLHTTP, and saves to the local, the first picture gathers the image to generate the thumbnail image.

The specific code is as follows:

The code is as follows

Copy Code

<% '================================================== ' Function name: CHECKDIR2 ' Function: Check if folder exists ' Parameter: FolderPath------folder Address '================================================== Function CheckDir2 (ByVal folderpath) Dim fso Folderpath=server.mappath (".") & "" &folderpath Set FSO = Server.CreateObject ("Scripting.FileSystemObject") If FSO. FolderExists (FolderPath) Then ' Existence CheckDir2 = True Else ' does not exist CheckDir2 = False End If Set FSO = Nothing End Function '================================================== ' Function name: MAKENEWSDIR2 ' Function: Create a new Folder ' Parameters: FolderName------folder name '================================================== Function MakeNewsDir2 (ByVal foldername) Dim fso Set FSO = Server.CreateObject ("Scripting.FileSystemObject") Fso. CreateFolder (Server.MapPath (".") & "" &foldername) If FSO. FolderExists (Server.MapPath (".") & "&foldername" Then MakeNewsDir2 = True Else MakeNewsDir2 = False End If Set FSO = Nothing End Function '================================================== ' Function name: Definiteurl ' Function: Converts a relative address to an absolute address ' Parameter: Primitiveurl------The relative address to convert ' Parameter: Consulturl------Current page address '================================================== Function Definiteurl (Byval primitiveurl,byval consulturl) Dim Contemp,pritemp,pi,ci,priarray,conarray If primitiveurl= "" or consulturl= "" or primitiveurl= "$False $" Then Definiteurl= "$False $" Exit Function End If If Left (consulturl,7) <> "http://" and left (consulturl,7) <> "http://" Then Consulturl= "http://" & Consulturl End If Consulturl=replace (Consulturl, "://", ": \") If Right (consulturl,1) <> "/" Then If Instr (Consulturl, "/") >0 Then If Instr (Consulturl,len (Consulturl)-instrrev (Consulturl, "/"), ".") >0 Then Else Consulturl=consulturl & "/" End If Else Consulturl=consulturl & "/" End If End If Conarray=split (Consulturl, "/") If Left (primitiveurl,7) = "http://" then Definiteurl=replace (Primitiveurl, "://", ": \") ElseIf Left (primitiveurl,1) = "/" Then Definiteurl=conarray (0) & Primitiveurl ElseIf Left (primitiveurl,2) = "./" Then Definiteurl=conarray (0) & Right (Primitiveurl,len (Primitiveurl)-1) ElseIf Left (primitiveurl,3) = ". /"Then Do While left (primitiveurl,3) = ". /" Primitiveurl=right (Primitiveurl,len (Primitiveurl)-3) Pi=pi+1 Loop For Ci=0 to (Ubound (ConArray) -1-pi) If definiteurl<> "" Then Definiteurl=definiteurl & "/" & ConArray (Ci) Else Definiteurl=conarray (Ci) End If Next Definiteurl=definiteurl & "/" & Primitiveurl Else If Instr (Primitiveurl, "/") >0 Then Priarray=split (Primitiveurl, "/") If Instr (Priarray (0), ".") >0 Then If Right (primitiveurl,1) = "/" Then Definiteurl= "http:\" & Primitiveurl Else If Instr (Priarray (Ubound (Priarray)-1), ".") >0 Then Definiteurl= "http:\" & Primitiveurl Else Definiteurl= "http:\" & Primitiveurl & "/" End If End If Else If Right (consulturl,1) = "/" Then Definiteurl=consulturl & Primitiveurl Else Definiteurl=left (Consulturl,instrrev (Consulturl, "/")) & Primitiveurl End If End If Else If Instr (Primitiveurl, ".") >0 Then If Right (consulturl,1) = "/" Then If Right (primitiveurl,3) = '. Cn ' or Right (primitiveurl,3) = ' com ' or right (primitiveurl,3) = ' net ' or right (primitiveurl,3) = "org" Then Definiteurl= "http:\" & Primitiveurl & "/" Else Definiteurl=consulturl & Primitiveurl End If Else If Right (primitiveurl,3) = '. Cn ' or Right (primitiveurl,3) = ' com ' or right (primitiveurl,3) = ' net ' or right (primitiveurl,3) = "org" Then Definiteurl= "http:\" & Primitiveurl & "/" Else Definiteurl=left (Consulturl,instrrev (Consulturl, "/")) & "/" & Primitiveurl End If End If Else If Right (consulturl,1) = "/" Then Definiteurl=consulturl & Primitiveurl & "/" Else Definiteurl=left (Consulturl,instrrev (Consulturl, "/")) & "/" & Primitiveurl & "/" End If End If End If End If If Left (definiteurl,1) = "/" Then Definiteurl=right (Definiteurl,len (Definiteurl)-1) End If If definiteurl<> "" Then Definiteurl=replace (Definiteurl, "//", "/") Definiteurl=replace (Definiteurl, ": \", "://") Else Definiteurl= "$False $" End If End Function '================================================== ' Function name: replacesaveremotefile ' Function: Replace, save remote file ' Parameter: constr------The string to replace ' Parameters: Starstr-----Leading ' Parameters: Overstr----- ' Parameters: Inclul------ ' Parameters: Inclur------ ' Parameter: SAVETF------Whether to save the file, False not save, true save ' Parameter: savefilepath-Save folder ' Parameter: Tisturl------Current page address '================================================== Function Replacesaveremotefile (Constr,startstr,overstr,inclul,inclur,savetf,savefilepath,tisturl) If constr= "$False $" or constr= "" Then Replacesaveremotefile= "$False $" Exit Function End If Dim Tempstr,tempstr2,ref,matches,match,tempi,temparray,temparray2,overtypearray Set ReF = New Regexp Ref.ignorecase = True Ref.global = True Ref.pattern = "(" &StartStr& "). +? ("&OverStr&") " Set matches =ref.execute (CONSTR) For the Match in matches If Instr (tempstr,match.value) =0 Then If tempstr<> "" Then Tempstr=tempstr & "$Array $" & Match.value Else Tempstr=match.value End If End If Next Set matches=nothing Set ref=nothing If tempstr= "" or IsNull (TEMPSTR) =true Then Replacesaveremotefile=constr Exit function End If If Inclul=false Then Tempstr=replace (Tempstr,startstr, "") End If If Inclur=false Then If Instr (overstr, "|") >0 Then Overtypearray=split (overstr, "|") For tempi=0 to Ubound (Overtypearray) Tempstr=replace (Tempstr,overtypearray (tempi), "") Next Else Tempstr=replace (Tempstr,overstr, "") End If End If Tempstr=replace (TempStr, "" "", "") Tempstr=replace (TempStr, "'", "") Dim Remotefile,remotefileurl,savefilename,savefiletype,arrsavefilename,rannum If Right (savefilepath,1) = "/" Then Savefilepath=left (Savefilepath,len (Savefilepath)-1) End If If Savetf=true Then If CheckDir2 (savefilepath) =false Then If MakeNewsDir2 (savefilepath) =false Then Savetf=false End If End If End If Savefilepath=savefilepath & "/" ' Picture conversion/Save Temparray=split (TempStr, "$Array $") For tempi=0 to Ubound (Temparray) Remotefileurl=definiteurl (Temparray (tempi), Tisturl) If remotefileurl<> "$False $" and savetf=true Then ' save picture Arrsavefilename = Split (Remotefileurl, ".") Savefiletype=arrsavefilename (Ubound (arrsavefilename)) ' File type Rannum=int (900*RND) +100 Savefilename = Savefilepath&year (now) &month (now) &day (now) &hour (now) &minute Now) &ranNum& "." &savefiletype Call Saveremotefile (Savefilename,remotefileurl) Constr=replace (Constr,temparray (tempi), savefilename) ElseIf remotefileurl<> "$False $" and savetf=false Then ' do not save pictures Savefilename=remotefileurl Constr=replace (Constr,temparray (tempi), savefilename) End If If remotefileurl<> "$False $" Then If uploadfiles= "" Then Uploadfiles=savefilename Else Uploadfiles=uploadfiles & "|" & Savefilename End If End If Next Replacesaveremotefile=constr End Function '================================================== ' Procedure name: Saveremotefile ' Function: Save remote files to local ' Parameter: localfilename------local filename ' Parameter: remotefileurl------remote File URL '================================================== Sub Saveremotefile (Localfilename,remotefileurl) Dim ads,retrieval,getremotedata Set retrieval = Server.CreateObject ("Microsoft.XMLHTTP") With retrieval . Open "Get", Remotefileurl, False, "", "" . Send Getremotedata =. Responsebody End With Set retrieval = Nothing Set Ads = Server.CreateObject ("ADODB.stream") With Ads . Type = 1 . Open . Write Getremotedata . SaveToFile server. MapPath (LocalFilename), 2 . Cancel () . Close () End With Set ads=nothing End Sub '================================================== ' Procedure name: getimg ' function: Get the first picture in the article ' Parameters: str------article content ' Parameter: strpath------Save the path to the picture '================================================== Function getimg (Str,strpath) Set Objregex = new REGEXP Objregex.ignorecase = True Objregex.global = True Zzstr= "&strpath&" (. +?). (jpg|gif|png|bmp) " Objregex.pattern = Zzstr Set matches = Objregex.execute (str) For the match in matches Retstr = retstr & "|" & Match.value Next If retstr<> "" Then Imglist=split (retstr, "|") Imgone=replace (Imglist (1), strpath, "") Getimg=imgone Else Getimg= "" End If End Function %> Cases: Program code <form id= "Form1" Name= "Form1" method= "Post" action= "Action=test" > <textarea name= "Body" cols= "rows=" 5 "id=" Body "> </textarea> <input type= "Submit" name= "Submission" value= "submitted"/> </form> <% If request. QueryString ("action") = "Test" Then ' The string that starts the picture Filesstartstr= "Src=" ' End of picture string Filesoverstr= "Gif|jpg|bmp" ' Save the picture folder Filespath= "QQ" ' Get the URL of the website that holds the picture automatically to judge is absolute or relative path Newsurl= "Http://news.163.com" ' Get the content of the article Content =request.form ("Body") ' Start saving pictures Content=replacesaveremotefile (Content,filesstartstr,filesoverstr,false,true,true,filespath,newsurl) ' Create a thumbnail image of the first picture in the news If Getimg (content,filespath) <> "" Then Imgsrc=getimg (Content,filespath) Imgsrc=replace (Imgsrc,filespath, "") Set Jpeg = Server.CreateObject ("Persits.jpeg") Path = Server.MapPath ("&FilesPath&") & "&Imgsrc&" Jpeg.open Path ' If the picture is wider than or equal to 120 or less than 90, the thumbnail is not created If jpeg.originalwidth<=120 and jpeg.height<=90 then Jpeg.width = Jpeg.originalwidth Jpeg.height = Jpeg.originalheight smallimg=filespath& "" &getimg (Content,filespath) Else ' Picture width height/2 Jpeg.width = JPEG.ORIGINALWIDTH/2 Jpeg.height = JPEG.ORIGINALHEIGHT/2 Jpeg.save Server.MapPath ("&FilesPath&") & "Small_" &Imgsrc& "" Smallimg= "" &FilesPath& "/small_" &Imgsrc& "" End If End If ' Show results Response. Write ("The first picture in the news is:") Response. Write ("Response. Write ("<br> thumbnail of the first picture in the news is:") Response. Write ("Response. Write ("<br> New news content (picture is local):<br>") Response.Write (Content) Response.End () End If %>

Note: If some network anti-theft even if the picture can not be saved, we need to imitate IE browser release information to the user normal browsing mode to download, code such as

The code is as follows

Copy Code

<% ' Hotlinking judgment Dim SERVER_V1,SERVER_V2 Server_v1=cstr (Request.ServerVariables ("Http_referer")) Server_v2=cstr (Request.ServerVariables ("SERVER_NAME")) If Mid (Server_v1,8,len (SERVER_V2)) <>server_v2 Then Response.Write "Illegal hotlinking." Response.End End If Dim URL, body, mycache url = request.querystring ("url") Set Mycache = new cache Mycache.name = "Picindex" &url If Mycache.valid Then BODY = Mycache.value Else BODY = getwebdata (URL) Mycache.add Body,dateadd ("D", 1,now) End If If Err.Number = 0 Then Response.Charset = "UTF-8" Response.ContentType = "Application/octet-stream" Response.BinaryWrite Body Response.Flush Else WScript.Echo Err.Description End If ' Get the data Public Function Getwebdata (ByVal strurl) Dim Curlpath Curlpath = Mid (Strurl,1,instr (8,strurl, "/") Dim Retrieval Set retrieval = Server.CreateObject ("Microsoft.XMLHTTP") With retrieval . Open "Get", strURL, False, "", "" . setRequestHeader "Referer", Curlpath . Send Getwebdata =. Responsebody End With Set retrieval = Nothing End Function ' Cache class Class Cache Private obj ' cache content Private Expiretime ' Expiration time Private Expiretimename ' Expired time application name Private CacheName ' cache content application name Private path ' URL Private Sub Class_Initialize () Path=request.servervariables ("url") Path=left (Path,instrrev (Path, "/") End Sub Private Sub Class_Terminate () End Sub Public Property Get Blempty ' Is empty If IsEmpty (obj) Then Blempty=true Else Blempty=false End If End Property Public Property Get Valid ' is available (expired) If IsEmpty (obj) or not isDate (expiretime) Then Valid=false ElseIf CDate (expiretime) <now Then Valid=false Else Valid=true End If End Property Public Property Let name (str) ' Set cache name CACHENAME=STR & Path Obj=application (CacheName) EXPIRETIMENAME=STR & "Expires" & Path Expiretime=application (Expiretimename) End Property Public Property Let Expires™ ' Reset Expiration Time Expiretime=tm Application.Lock Application (Expiretimename) =expiretime Application.UnLock End Property Public Sub Add (Var,expire) ' Assign value If IsEmpty (Var) or not isDate (expire) Then Exit Sub End If Obj=var Expiretime=expire Application.Lock Application (CacheName) =obj Application (Expiretimename) =expiretime Application.UnLock End Sub Public Property Get Value ' Take value If IsEmpty (obj) or not isDate (expiretime) Then Value=null ElseIf CDate (expiretime) <now Then Value=null Else Value=obj End If End Property Public Sub Makeempty () ' Release application Application.Lock Application (CacheName) =empty Application (Expiretimename) =empty Application.UnLock Obj=empty Expiretime=empty End Sub Public function equal (VAR2) ' Comparison If TypeName (obj) <>typename (var2) Then Equal=false ElseIf TypeName (obj) = "Object" Then If obj is var2 then Equal=true Else Equal=false End If ElseIf TypeName (obj) = "Variant ()" Then If join (obj, "^") =join (var2, "^") Then Equal=true Else Equal=false End If Else If Obj=var2 Then Equal=true Else Equal=false End If End If End Function End Class %>

These code can effectively crack the picture anti-theft chain system. such as NetEase albums. Directly save the following code as a pic.asp, and then call it with the pic.asp?url= picture path. Increased caching technology