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

蓝雨

插件名称：上传附件显示详细信息for Dvbbs8.0.0
插件版本：2.0
修改: 168168
修改时间:2007.06.19
特别提示:本修改在动网论坛8.0.0正式版[2007-6-18 18:10更新] 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,\"><\")
Loop

End If
re.Pattern=\"(]*)>)\"
s=re.Replace(s,\"\")
re.Pattern=\"<\\/p>\\x0d?\\x0a

\"
s= re.Replace(s,\"

\")
re.Pattern=\"([^\\x0d])\\x0a((?!s= re.Replace(s,\"$1
$2\")
re.Pattern=\"\\x0d\\x0a([^\\x0d]*)\"
s= re.Replace(s,\"

$1

\")
re.Pattern=\"(]*)>)\"
s=re.Replace(s,\"\")
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=\"(

)((.|\\n)*?)(<\\/div>)\"
Do While re.Test(s)
s=re.Replace(s,\"

QUOTE:

$2

\")
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=\"(\\[quote\\])((.|\\n)*?)(\\[\\/quote\\])\"
Do While re.Test(s)
s=re.Replace(s,\"

$2

\")
Loop
\'re.Global=True
re.Pattern=\"\\x01(\\/?(i|b|p))\\x02\"
s=re.Replace(s,\"<$1>\")
re.Pattern = \"(\\[br\\])\"
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=\"

class=tableborder2 cellSpacing=1 cellPadding=3 width=\"\"100%\"\" align=center border=\"\"0\"\">

以下内容含脚本,或可 能导致页面不正常的代码
<p>-RIGHT: 1px dotted; BORDER-TOP: 1px dotted; OVERFLOW-Y: visible; OVERFLOW: visible; BORDER-LEFT: 1px dotted; WIDTH: 98%; </p><p>COLOR: #000000; BORDER-BOTTOM: 1px dotted\"\" rows=20 cols=120>\"&s&\"
align=\"\"middle\"\" width=\"\"98%\"\">说明：上面显示的是代码内容。您可以先检查过代码没问题，或修改之后再运 行.
onclick=\"\"Dvbbs_ViewCode(\"&replyid&\");\"\">

\"
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=\"\\[upload=(\\w{3})(,|)([^\\]]*)\\]viewFile\\.asp\\?id=([0-9]*)\\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 If

3、找到（一共四处都要改）：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 If

2、找到：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(\"

错误:

系统找不到指定文件\")
Exit Sub
End If
Set f = fso.GetFile(strFilename)
intFilelength = f.size
s.LoadFromFile(strFilename)
If err Then
Response.Write(\"

错误:

\" & 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(\"

错误:

系统找不到指定文件\")
Exit Sub
End If
Set f = fso.GetFile(strFilename)
intFilelength = f.size
s.LoadFromFile(strFilename)
If err Then
Response.Write(\"

错误:

\" & 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.asp

14行找到：\"Dim PostBuyUser,abgcolor,bgcolor,UserName,PostUserName\",后面增加一个新变量定义pUserName

Dim PostBuyUser,abgcolor,bgcolor,UserName,PostUserName,pUserName

六、修改post.asp
11行找到\"Dim MyPost,UserName\"，后面增加一个新变量定义pusername

Dim MyPost,UserName,pusername

游客，如果您要查看本帖隐藏内容请回复