远程贴图功能的实现

首发于BBSXP官方论坛,现在摘回来

 远程贴图功能的实现
此源码非绝对原创,但其中代码是根据ASP文章管理系统中的部分代码组合后自己修改而成,应属原创

转帖请注明原作者

很简单就可以实现了

<%
'==================================================
'制作人:NETTON.CN
'过程名：ReplaceRemoteUrl
'作  用：替换字符串中的远程文件为本地文件并保存远程文件
'参  数：strContent ------ 要替换的字符串
'==================================================
function ReplaceRemoteUrl(strContent)
 if IsObjInstalled("Microsoft.XMLHTTP")=False or EnableSaveRemote="No" then
  ReplaceRemoteUrl=strContent
  exit function
 end if
   
 dim re,RemoteFile,RemoteFileurl,SaveFilePath,SaveFileName,SaveFileType,arrSaveFileName,ranNum
 SaveFilePath = "UpFile/img"   '文件保存的本地路径
 if right(SaveFilePath,1)<>"/" then SaveFilePath=SaveFilePath&"/"
 Set re=new RegExp
 re.IgnoreCase =true
 re.Global=True
 re.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}((\w)+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(gif|jpg|png|bmp)))"
 Set RemoteFile = re.Execute(strContent)
 For Each RemoteFileurl in RemoteFile
  arrSaveFileName = split(RemoteFileurl,".")
  SaveFileType=arrSaveFileName(ubound(arrSaveFileName))
  ranNum=int(900*rnd)+100
  
  
  
  Set fso = Server.CreateObject("Scripting.FileSystemObject")

               strDir="UpFile/img/"&year(now)&"-"&month(now)&""
                if not fso.folderexists(Server.MapPath(strDir)) then fso.CreateFolder(Server.MapPath(strDir))
 strDir=strDir&"/"

  SaveFileName = strDir&year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&ranNum&"."&SaveFileType 
  call SaveRemoteFile(SaveFileName,RemoteFileurl)
  strContent=Replace(strContent,RemoteFileurl,SaveFileName)
  if UploadFiles="" then
   UploadFiles=SaveFileName
  else
   UploadFiles=UploadFiles & "|" & SaveFileName
  end if
 Next
 ReplaceRemoteUrl=strContent
end function

'==================================================
'过程名：SaveRemoteFile
'作  用：保存远程的文件到本地
'参  数：LocalFileName ------ 本地文件名
'   RemoteFileUrl ------ 远程文件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

%>

结合本人图像防盗链功能http://bbs.yuzi.net/ShowPost.asp?ThreadID=641947

http://www.netton.cn/bbs/ShowPost.asp?ThreadID=2423

这才不至于你的服务器流量过大.

明白的就用,看不懂的话别改,改了麻烦也不少.