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

Source: Internet
Author: User
Tags file url servervariables valid

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

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.