Dvbbs7.0修改 将远程的图片保存在本地空间

时间:05-11-29 栏目:网站&编程, 网络&技术 作者:wukong 评论:0 点击: 1,345 次

修改savepost.asp文件

找到mysessiondata(37)=Content 改为

mysessiondata(37) = ReplaceRemoteUrl(Content)

如果是SP3版本,则找到Dvbbs.MyUserInfo(40) = Content改为

Dvbbs.MyUserInfo(40) = ReplaceRemoteUrl(Content)

如果希望是管理员才能有这权限,则修改为

if dvbbs.master then

mysessiondata(37) = ReplaceRemoteUrl(Content)

else

mysessiondata(37) = Content

end if

在文件的最后一行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

'按月份自动明名上传文件夹,需要FSO组件支持。
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

以上代码参照动力文章系统修改而来,测试通过。但对于是否在Content = Dvbbs.Checkstr(Request.Form("body"))增加Content = ReplaceRemoteUrl(Content)还不十分确定。对于空间小的用户来说,这个功能比较可怕。有兴趣的不妨一试。

声明: 本文由( wukong )原创编译,转载请保留链接: Dvbbs7.0修改 将远程的图片保存在本地空间

Dvbbs7.0修改 将远程的图片保存在本地空间:等您坐沙发呢!

发表评论

您必须 [ 登录 ] 才能发表留言!

------====== 本站公告 ======------
大家有任何疑问和建议,请到这里留言:点击留言板

读者排行