数据编程 · 大数据建设-将远程的图片保存在本地空间通信圈

以文本方式查看主题

-  通信圈  (http://cntxj.net/bbs/index.asp)
--  数据编程 · 大数据建设  (http://cntxj.net/bbs/list.asp?boardid=74)
----  将远程的图片保存在本地空间  (http://cntxj.net/bbs/dispbbs.asp?boardid=74&id=2303)

--  作者：新月弯刀
--  发布时间：2006/10/18 12:04:15
--  将远程的图片保存在本地空间

修改savepost.asp文件

找到

Dvbbs.MyUserInfo(Dvbbs.UserInfoCount-1) = Content　　　\'222行左右

修改为

Dvbbs.MyUserInfo(Dvbbs.UserInfoCount-1) = ReplaceRemoteUrl(Content)

在最后的　End Function　和　%>　之间增加（一定要看清，是之间不是最后）

\'================================================== \'过程名：ReplaceRemoteUrl \'作用：替换字符串中的远程文件为本地文件并保存远程文件 \'参数：strContent ------ 要替换的字符串 \'================================================== function ReplaceRemoteUrl(strContent) if IsObjInstalled("Microsoft.XMLHTTP")=False then ReplaceRemoteUrl=strContent exit function end if dim re,RemoteFile,RemoteFileurl,SaveFileName,SaveFileType,arrSaveFileName,ranNum,UploadFiles,FormPath FormPath=CheckFolder&CreatePath() \'上传目录路径 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 SaveFileName = FormPath&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

\'************************************************** \'函数名：IsObjInstalled \'作用：检查组件是否已经安装 \'参数：strClassString ----组件名 \'返回值：True ----已经安装 \' False ----没有安装 \'************************************************** Function IsObjInstalled(strClassString) On Error Resume Next IsObjInstalled = False Err = 0 Dim xTestObj Set xTestObj = Server.CreateObject(strClassString) If 0 = Err Then IsObjInstalled = True Set xTestObj = Nothing Err = 0 End Function

\'按月份自动明名上传文件夹,需要ＦＳＯ组件支持。 Function CreatePath() Dim objFSO,Fsofolder,uploadpath uploadpath=year(now)&"-"&month(now) \'以年月创建上传文件夹，格式：2003－8 On Error Resume Next Set objFSO = Server.CreateObject("Scripting.FileSystemObject") If objFSO.FolderExists(Server.MapPath(CheckFolder&uploadpath))=False Then objFSO.CreateFolder Server.MapPath(CheckFolder&uploadpath) End If If Err.Number = 0 Then CreatePath=uploadpath&"/" Else CreatePath="" End If Set objFSO = Nothing End Function

\'读取上传目录 Function CheckFolder() If Dvbbs.Forum_Setting(76)="" Or Dvbbs.Forum_Setting(76)="0" Then Dvbbs.Forum_Setting(76)="UploadFile/" CheckFolder = Replace(Replace(Dvbbs.Forum_Setting(76),Chr(0),""),".","") \'在目录后加(/) If Right(CheckFolder,1)<>"/" Then CheckFolder=CheckFolder&"/" End Function

具体效果参考本站。使用本方法需要你的服务器支持FSO和XMLHTML组件。请在使用本修改前检测一下你的服务器是否支持FSO和XMLHTML组件。

将以下代码保存为check.asp文件，运行后即可知道你的服务器是否支持FSO和XMLHTML组件。

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> <HTML> <HEAD> <TITLE> New Document </TITLE> <META NAME="Generator" CONTENT="EditPlus"> <META NAME="Author" CONTENT=""> <META NAME="Keywords" CONTENT=""> <META NAME="Description" CONTENT=""> </HEAD>

<BODY> <% Function IsObjInstalled(s_ClassString) On Error Resume Next IsObjInstalled = False Err = 0 Dim xTestObj Set xTestObj = Server.CreateObject(s_ClassString) If 0 = Err Then IsObjInstalled = True Set xTestObj = Nothing Err = 0 End Function If IsObjInstalled("Microsoft.XMLHTTP") = False then Response.WRite "你的服务器不支持Microsoft.XMLHTTP组件，你不能使用本修改。" Else Response.WRite "你的服务器支持Microsoft.XMLHTTP组件，你可以使用。" End If %> </BODY> </HTML>