蓝雨论坛上传附件显示详细信息for Dvbbs8.0.0

蓝雨发表于 2007-6-22 20:29:00

插件名称：上传附件显示详细信息for Dvbbs8.0.0 插件版本：2.0 修改: 168168 修改时间:2007.06.19 特别提示:本修改在动网论坛8.0.0正式版 ACC版本程序测试通过,修改前请先备份,出错别怪哦,呵呵 根据原1.11版本修改原插件作者：老庙黄金 主要功能： 1、单贴间多个下载文件单独记录下载次数并显示文件名 2、显示原来上传时的文件名，而不是变成序号的文件名（不影响保密功能） 3、可以查看下载者的功能 4、文件长度显示，该Byte就Byte，该KByte就KByte，该MByte就MByte 5、无论上传文件后系统加了什么样的后缀序号（其实是用于防盗和防止文件重名的），下载时都会只显示原来的文件名，不会出现后边的一长串序号（这个功能要在系统开启了防盗功能才有效） 6、上传图片时不进行原文件名的处理安装办法： 一、将压缩包中的z_Upload.asp上传至论坛根目录二、修改inc/dv_ubbcode.asp： 修改inc/dv_ubbcode.asp：1、在第一行之前添加：  2、41行找到 Public Re,reed,isgetreed,Board_Setting,WapPushUrl,xml,isxhtml 增加一个新变量定义abgcolor Public Re,reed,isgetreed,Board_Setting,WapPushUrl,xml,isxhtml,abgcolor 164-168行找到 Dim textonly textonly=istext(s) If textonly Then re.Pattern=\"<\" s= re.Replace(s,\"<\")下边添加 Else re.Pattern=\">\"& Chr(13) &Chr(10) &\"<\" Do While re.Test(s) s= re.Replace(s,\"><\") Loop re.Pattern=\">\"& Chr(10) &\"<\" Do While re.Test(s) s= re.Replace(s,\"><\") Loop re.Pattern=\">\"& Chr(13) &\"<\" Do While re.Test(s) s= re.Replace(s,\"><\") LoopEnd If re.Pattern=\"(<s+cript(.[^>]*)>)\" s=re.Replace(s,\"<Script$2>\") re.Pattern=\"(<\\/s+cript>)\" s=re.Replace(s,\"</Script>\") re.Pattern=\"<\\/p>\\x0d?\\x0a\" s= re.Replace(s,\"\") re.Pattern=\"([^\\x0d])\\x0a((?!<td|<tr))\" s= re.Replace(s,\"$1 $2\") re.Pattern=\"\\x0d\\x0a([^\\x0d]*)\" s= re.Replace(s,\"$1\") re.Pattern=\"(<body(.[^>]*)>)\" s=re.Replace(s,\"<body>\") re.Pattern=\"(<\\!(.[^>]*)>)\" s=re.Replace(s,\"<$2>\") re.Pattern=\"(<\\!)\" s=re.Replace(s,\"<!\") re.Pattern=\"(-->)\" s=re.Replace(s,\"-->\") re.Pattern=\"(javascript:)\" s=re.Replace(s,\"javascript:\") re.Pattern=\"( \\s*){10,}\" s=re.Replace(s,\" \") If Board_Setting(5)=\"0\" Then re.Pattern =\"<(\\/?(i|b|p))>\" s=re.Replace(s,Chr(1)&\"$1\"&Chr(2)) re.Pattern=\"(>)(\"&vbNewLine&\"){1,2}(<)\" s=re.Replace(s,\"$1$3\") \'re.Global=False re.Pattern=\"(<div class=quote>)((.|\\n)*?)(<\\/div>)\" Do While re.Test(s) s=re.Replace(s,\" <div class=\"msgheader\">QUOTE:</div><div class=\"msgborder\">$2</div>\") Loop \'re.Global=True re.Pattern = \"(<\\/tr>)\" s = re.Replace(s,\" \") re.Pattern = \"( )\" s = re.Replace(s,\" \") re.Pattern = \"<(\\/?s(ub|up|trike))>\" s = re.Replace(s,\"[$1]\") re.Pattern = \"(<)(\\/?font[^>]*)(>)\" s = re.Replace(s,CHR(1)&\"$2\"&CHR(2)) re.Pattern=\"<([^<>]*?)>\" Do while re.Test(s) s=re.Replace(s,\"\") Loop re.Pattern = \"(\\x01)(\\/?font[^\\x02]*)(\\x02)\" s = re.Replace(s,\"<$2>\") re.Pattern = \"\\[(\\/?s(ub|up|trike))\\]\" s = re.Replace(s,\"<$1>\") \'re.Global=False re.Pattern=\"(\\)((.|\\n)*?)(\\[\\/quote\\])\" Do While re.Test(s) s=re.Replace(s,\"<div class=quote>$2</div>\") Loop \'re.Global=True re.Pattern=\"\\x01(\\/?(i|b|p))\\x02\" s=re.Replace(s,\"<$1>\") re.Pattern = \"(\\)\" s = re.Replace(s,\" \") If PostType=1 Then re.Pattern=\",39,\" \'If re.Test(Ubblists&\"\") Then If Dv_FilterJS(s) Then re.Pattern=\"\\[(br)\\]\" s=re.Replace(s,\"<$1>\") re.Pattern = \"( )\" s = re.Replace(s,vbNewLine) re.Pattern = \"()\" s = re.Replace(s,\"\") re.Pattern = \"(<\\/p>)\" s = re.Replace(s,vbNewLine) s=server.htmlencode(s) s=\"<form name=\"\"scode\"&replyid&\"\"\" method=\"\"post\"\" action=\"\"\"\"><table class=tableborder2 cellSpacing=1 cellPadding=3 width=\"\"100%\"\" align=center border=\"\"0\"\"><TR><TH height=22>以下内容含脚本,或可能导致页面不正常的代码</TH></TR><TR><TD class=tablebody1 align=\"\"middle\"\" width=\"\"98%\"\"><TEXTAREA id=CodeText style=\"\"BORDER-RIGHT: 1px dotted; BORDER-TOP: 1px dotted; OVERFLOW-Y: visible; OVERFLOW: visible; BORDER-LEFT: 1px dotted; WIDTH: 98%; COLOR: #000000; BORDER-BOTTOM: 1px dotted\"\" rows=20 cols=120>\"&s&\"</TEXTAREA></TD></TR><TR><TD class=tablebody2 align=\"\"middle\"\" width=\"\"98%\"\">说明：上面显示的是代码内容。您可以先检查过代码没问题，或修改之后再运行.</td></tr><TR><TD class=tablebody1 align=\"\"middle\"\" width=\"\"98%\"\"><input type=\"\"button\"\" name=\"\"run\"\" value=\"\"运行代码\"\" onclick=\"\"Dvbbs_ViewCode(\"&replyid&\");\"\"></TD></TR></table></form>\" s = Replace(s, vbNewLine, \"\") s = Replace(s, CHR(10), \"\") s = Replace(s, CHR(13), \"\") Dv_UbbCode=s Exit Function End If \'End If End If re.Pattern=\"<((asp|\\!|%))\" s=re.Replace(s,\"<$1\") 3、1027找到 re.Pattern=\"\\]*)\\]viewFile\\.asp\\?id=(*)\\x01\\/UPLOAD\\]\",修改为: s=Dv_UbbCode_Upload(s,PostUserGroup,Flag,MaxLoopCount,abgcolor) 三、修改inc/Upload_Class.asp：1、368行找到： Private Function FormatName(Byval FileExt,Byval FileName)改为： Private Function FormatName(Byval FileExt, Byval FileType, Byval OrigFileName) 2、376行找到： TempStr = Year(now) & Month(now) & Day(now) & Hour(now) & Minute(now) & Second(now) & RanNum & \".\" & FileExt 下边添加： If FileType=1 Or FileType=2 Then Else TempStr = OrigFileName & \"___\" & TempStr End If3、找到（一共四处都要改）：546-547行 621-622行 690-691行 766-767行 FileName = FormatName(FileExt,File.FileName) FileType = CheckFiletype(FileExt) 改为： FileType = CheckFiletype(FileExt) FileName = FormatName(FileExt, FileType, Replace(File.FileName,Chr(0),\"\")) 四、修改viewfile.asp： 1、找到： 109-122行 If Dvbbs.Forum_Setting(75)=\"0\" Then Dvbbs.Execute(\"Update dv_upfile Set F_DownNum=F_DownNum+1 Where F_ID=\"&DownID) If Rs(\"F_OldName\") = \"\" Or IsNull(Rs(\"F_OldName\")) Then Response.Redirect uploadpath&rs(\"F_filename\") Else downloadFile Server.MapPath(uploadpath&rs(\"F_filename\")),Rs(\"F_OldName\") End If Else filename=Replace(rs(\"F_filename\"),\"..\",\"\")&\"\" If Request.ServerVariables(\"HTTP_REFERER\")=\"\" Or InStr(Request.ServerVariables(\"HTTP_REFERER\"),Request.ServerVariables(\"SERVER_NAME\"))=0 Or filename=\"\" Then Response.Redirect \"index.asp\" Else downloadFile Server.MapPath(Dvbbs.Forum_Setting(76)&filename),Rs(\"F_OldName\") End If 改为： If Dvbbs.Forum_Setting(75)=\"0\" Then If Dvbbs.UserID<>0 Then Call UpdateDownUser(rs(\"f_downuser\"),Dvbbs.MemberName) Else Dvbbs.Execute(\"Update dv_upfile Set F_DownNum=F_DownNum+1 Where F_ID=\"&DownID) End If Response.Redirect uploadpath&rs(\"F_filename\") Else filename=Replace(rs(\"F_filename\"),\"..\",\"\")&\"\" If Request.ServerVariables(\"HTTP_REFERER\")=\"\" Or InStr(Request.ServerVariables(\"HTTP_REFERER\"),Request.ServerVariables(\"SERVER_NAME\"))=0 Or filename=\"\" Then Response.Redirect \"index.asp\" Else If Dvbbs.UserID<>0 Then Call UpdateDownUser(rs(\"f_downuser\"),Dvbbs.MemberName) Else Dvbbs.Execute(\"Update dv_upfile Set F_DownNum=F_DownNum+1 Where F_ID=\"&DownID) End If Call downloadFile(Server.MapPath(Dvbbs.Forum_Setting(76)&filename)) End If2、找到：129-163行 Sub downloadFile(strFile,FileOldName) On error resume next Server.ScriptTimeOut=999999 Dim S,fso,f,intFilelength,strFilename,DownFileName strFilename = strFile Response.Clear Set s = Server.CreateObject(\"ADODB.Stream\") s.Open s.Type = 1 Set fso = Server.CreateObject(\"Scripting.FileSystemObject\") If Not fso.FileExists(strFilename) Then Response.Write(\"<h1>错误: </h1> 系统找不到指定文件\") Exit Sub End If Set f = fso.GetFile(strFilename) intFilelength = f.size s.LoadFromFile(strFilename) If err Then Response.Write(\"<h1>错误: </h1>\" & err.Description & \"\") Response.End End If Set fso=Nothing Dim Data Data=s.Read s.Close Set s=Nothing If FileOldName=\"\" Or IsNull(FileOldName) Then DownFileName=f.name Else DownFileName=FileOldName If Response.IsClientConnected Then Response.AddHeader \"Content-Disposition\", \"attachment; filename=\" & DownFileName Response.AddHeader \"Content-Length\", intFilelength Response.CharSet = \"UTF-8\" Response.ContentType = \"application/octet-stream\" Response.BinaryWrite Data Response.Flush End If改为： Sub downloadFile(strFile) On error resume next Server.ScriptTimeOut=999999 Dim S,fso,f,intFilelength,strFilename strFilename = strFile Response.Clear Set s = Server.CreateObject(\"ADODB.Stream\") s.Open s.Type = 1 Set fso = Server.CreateObject(\"Scripting.FileSystemObject\") If Not fso.FileExists(strFilename) Then Response.Write(\"<h1>错误: </h1> 系统找不到指定文件\") Exit Sub End If Set f = fso.GetFile(strFilename) intFilelength = f.size s.LoadFromFile(strFilename) If err Then Response.Write(\"<h1>错误: </h1>\" & err.Description & \"\") Response.End End If Set fso=Nothing Dim Data Data=s.Read s.Close Set s=Nothing If Response.IsClientConnected Then Dim TruePos Dim TrueFileName TruePos=InStrRev(f.name,\"___\") If TruePos>0 Then TrueFileName=Left(f.name,TruePos-1) Else TrueFileName=f.name End If TruePos=InStrRev(TrueFileName,\"/\") If TruePos>0 Then TrueFileName=Right(TrueFileName,Len(TrueFileName)-TruePos) End If Response.AddHeader \"Content-Disposition\", \"attachment; filename=\" & TrueFileName Response.AddHeader \"Content-Length\", intFilelength Response.CharSet = \"UTF-8\" Response.ContentType = \"application/octet-stream\" Response.BinaryWrite Data Response.Flush End If End Sub Sub UpdateDownUser(DownUser,UserName) If Not Instr(1,\"|\"&DownUser&\"|\",\"|\"&UserName&\"|\")>0 Then If IsNull(DownUser) Or DownUser=\"\" Then Dvbbs.Execute(\"Update dv_upfile Set F_DownNum=F_DownNum+1,F_DownUser=\'\"&UserName&\"\' Where F_ID=\"&DownID) Else Dvbbs.Execute(\"Update dv_upfile Set F_DownNum=F_DownNum+1,F_DownUser=\'\"&DownUser&\"|\"&UserName&\"\' Where F_ID=\"&DownID) End If End If 3、在文件最后End If End Sub %> 之前添加： Sub UpdateDownUser(DownUser,UserName) If Not Instr(1,\"|\"&DownUser&\"|\",\"|\"&UserName&\"|\")>0 Then If IsNull(DownUser) Or DownUser=\"\" Then Dvbbs.Execute(\"Update dv_upfile Set F_DownNum=F_DownNum+1,F_DownUser=\'\"&UserName&\"\' Where F_ID=\"&DownID) Else Dvbbs.Execute(\"Update dv_upfile Set F_DownNum=F_DownNum+1,F_DownUser=\'\"&DownUser&\"|\"&UserName&\"\' Where F_ID=\"&DownID) End If End If End Sub五、修改Dispbbs.asp14行找到：\"Dim PostBuyUser,abgcolor,bgcolor,UserName,PostUserName\",后面增加一个新变量定义pUserName Dim PostBuyUser,abgcolor,bgcolor,UserName,PostUserName,pUserName 六、修改post.asp 11行找到\"Dim MyPost,UserName\"，后面增加一个新变量定义pusernameDim MyPost,UserName,pusername**** Hidden Message *****

hnabv 发表于 2007-7-24 17:55:00

hnabv 发表于 2007-7-24 18:02:00

hnabv 发表于 2007-7-24 18:15:00

wyc007 发表于 2007-7-24 18:38:00

页: [1]

蓝雨动力's Archiver

蓝雨论坛上传附件显示详细信息for Dvbbs8.0.0