<% Dim ToUserID,TopicID,ReplyID,Action,ChkAction,LogMsg Dvbbs.ErrType = 1 '设置错误提示信息显示模式 ChkAction = True ToUserID = Dv_Tools.CheckNumeric(Request("ToUserID")) '目标用户 TopicID = Dv_Tools.CheckNumeric(Request("TopicID")) '主题ID ReplyID = Dv_Tools.CheckNumeric(Request("ReplyID")) '回复ID Action = Dv_Tools.CheckNumeric(Request("Action")) '执行分类 If TopicID = 0 or ReplyID = 0 or Dvbbs.BoardID = 0 Then ChkAction = False Dvbbs.stats = "论坛道具使用" If Action=0 Then Dv_Tools.ChkToolsLogin Dvbbs.stats = "论坛道具使用=="&Dv_Tools.ToolsInfo(1) End If Dvbbs.LoadTemplates("") Dvbbs.Head() ToolsMain Dvbbs.Showerr() Dvbbs.mainsetting(0)="98%" Dvbbs.Footer() Dvbbs.PageEnd() '--------------------------------------------------- 'Dv_Tools.ToolsInfo 道具系统信息 'ID=0 ,ToolsName=1 ,ToolsInfo=2 ,IsStar=3 ,SysStock=4 ,UserStock=5 ,UserMoney=6 ,UserPost=7 ,UserWealth=8 ,UserEp=9 ,UserCp=10 ,UserGroupID=11 ,BoardID=12,UserTicket=13,BuyType=14,ToolsImg=15 '--------------------------------------------------- '事件记录过程：Call Dvbbs.ToolsLog(道具ID，发生数量，金币发生额，点券发生额，记录事件类型，备注内容，用户最后剩余金币和点券（金币|点券）) '--------------------------------------------------- Sub ToolsMain() Dv_Tools.ChkUseTools '检查道具使用权限 Select Case Dv_Tools.ToolsID Case 1 : Tools_1 Case 2 : Tools_2 Case 3 : Tools_3 Case 4 : Tools_4 Case 5 : Tools_5 Case 6 : Tools_6 Case 7 : Tools_7 Case 8 : Tools_8 Case 9 : Tools_9 Case 10 : Tools_10 Case 11 : Tools_11 Case 12 : Tools_12 Case 13 : Tools_13 Case 14 : Tools_14 Case 16 : Tools_16 Case 17 : Tools_17 Case 18 : Tools_18 Case 19 : Tools_19 Case 20 : Tools_20 Case 21 : Tools_21 Case 22 : Tools_22 Case 23 : Tools_23 Case 24 : Tools_24 Case 25 : Tools_25 Case 26 : Tools_26 Case 27 : Tools_27 Case 28 : Tools_28 Case 29 : Tools_29 Case Else Dv_Tools.ShowErr(3) End Select End Sub '------------------------------------------------------------------------------------------------------ '道具处理过程 '------------------------------------------------------------------------------------------------------ '--------------------------------------------------- '道具:转让器，可进行道具、金币和点券的转让 '--------------------------------------------------- Sub Tools_1() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable Dim iUserInfo ChkAction = True If ToUserID = 0 Then ChkAction = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(Request("ToUserID")) If Request("ToolsAction")="SendTools" Then Dim SendToolsID,SendToolsNum,SendMoneyNum,SendTicketNum SendToolsID = Dv_Tools.CheckNumeric(Request("SendToolsID")) SendToolsNum = Dv_Tools.CheckNumeric(Request("SendToolsNum")) SendMoneyNum = CCur(Abs(Dv_Tools.CheckNumeric(Request("SendMoneyNum")))) SendTicketNum = CCur(Abs(Dv_Tools.CheckNumeric(Request("SendTicketNum")))) If (SendToolsID=0 Or SendToolsNum=0) And SendMoneyNum=0 And SendTicketNum=0 Then LogMsg = "由于您没有正确填写相应的转让内容，使用道具不成功！" Else If Dvbbs.UserID = Clng(Dv_Tools.ToUserInfo(0)) Then Dv_Tools.ShowErr(14) Exit Sub End If LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功" '金币转让 If SendMoneyNum > 0 Then If CCur(Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text) < SendMoneyNum Then Dv_Tools.ShowErr(17) : Exit Sub Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text = cCur(Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text) - cCur(SendMoneyNum) LogMsg = LogMsg & "，转给"&Dv_Tools.ToUserInfo(1)&""&SendMoneyNum&"个金币" Dvbbs.Execute("Update Dv_User Set UserMoney = UserMoney - "&SendMoneyNum&" Where UserID=" & Dvbbs.UserID) Dvbbs.Execute("Update Dv_User Set UserMoney = UserMoney + "&SendMoneyNum&" Where UserID=" & Dv_Tools.ToUserInfo(0)) End If '点券转让 If SendTicketNum > 0 Then If CCur(Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) < SendTicketNum Then Dv_Tools.ShowErr(17) : Exit Sub Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text = cCur(Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) - cCur(SendTicketNum) LogMsg = LogMsg & "，转给"&Dv_Tools.ToUserInfo(1)&""&SendTicketNum&"张点券" Dvbbs.Execute("Update Dv_User Set UserTicket = UserTicket - "&SendTicketNum&" Where UserID=" & Dvbbs.UserID) Dvbbs.Execute("Update Dv_User Set UserTicket = UserTicket + "&SendTicketNum&" Where UserID=" & Dv_Tools.ToUserInfo(0)) End If '道具转让 If SendToolsID > 0 And SendToolsNum > 0 Then Dim Trs,UserToolsNum UserToolsNum = 0 Sql = "Select ID,UserID,UserName,ToolsID,ToolsName,ToolsCount,SaleCount,UpdateTime From [Dv_Plus_Tools_Buss] Where ToolsCount>0 and UserID="& Dvbbs.UserID &" and ToolsID="& SendToolsID Set Trs = Dvbbs.Plus_Execute(Sql) If Trs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 所选取转让的道具不存在，请购买了相应的道具再执行转让！&action=NoHeadErr" Exit Sub Else UserToolsNum = Trs(5) If UserToolsNum你目前只能转让("&UserToolsNum&")个道具！&action=NoHeadErr" Exit Sub End If End If Trs.Close Set Trs = Dvbbs.Plus_Execute("Select ToolsName From Dv_Plus_Tools_Info Where ID=" & SendToolsID) If Not (Trs.Eof And Trs.Bof) Then LogMsg = LogMsg & "，转给"&Dv_Tools.ToUserInfo(1)&""&SendToolsNum&"个"&Trs(0)&"道具" End If Trs.Close Set Trs=Nothing '更新用户和系统使用数量 Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) '更新用户道具数量 Call UpdateBussTools(Dvbbs.UserID,SendToolsID,SendToolsNum) Call UpdateBussTools(Dv_Tools.ToUserInfo(0),SendToolsID,-SendToolsNum) End If Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,2,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) End If Dvbbs.Dvbbs_Suc(LogMsg) Else %>
    使用道具 <%=Dv_Tools.ToolsInfo(1)%>
    说明：
    1、使用本道具可将您自己的金钱、点券或道具转让给目标用户
    2、目标用户的选择方法：通常在论坛的各种位置只要点击用户名连接即可进入该用户资料页面，浏览帖子过程可点击该贴用户“信息”图标，进入用户资料页面后点击“使用道具”连接即可进入具体的道具操作页面
    目标用户： <%=Dv_Tools.ToUserInfo(1)%>
    转让道具： 转让数量： 个
    您有 <%=Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text%> 个金币和 <%=Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text%> 张点券可供转让
    转让金币： 个
    转让点券： 个
    <% End If End Sub '--------------------------------------------------- '道具:后悔药，可删除自己发表的帖子，有回复则不能删 '--------------------------------------------------- Sub Tools_2() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable,ToolsParnetID,ToolsIsToday ToolsIsToday = 0 ' If ToUserID = 0 Then ChkAction = False ' If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(Dvbbs.UserID) If Dvbbs.UserID <> Clng(Dv_Tools.ToUserInfo(0)) Then Dv_Tools.ShowErr(15) Exit Sub End If Sql = "Select Title,UseTools,PostTable,Child From [Dv_Topic] Where TopicID="&TopicID&" And PostUserID="&Dvbbs.UserID Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在！&action=NoHeadErr" Exit Sub Else If Rs(3)>0 Then Response.redirect "showerr.asp?ErrCodes=
  • 该贴已有人回复，不能删除，您可自行编辑清除该贴相关内容！&action=NoHeadErr" Exit Sub End If T_PostTable = Rs(2) End If Rs.Close Set Rs=Dvbbs.Execute("Select Topic,UseTools,Body,ParentID,DateAndTime From "&T_PostTable&" Where AnnounceID="&ReplyID&" And PostUserID=" & Dvbbs.UserID) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该帖子不存在！&action=NoHeadErr" Exit Sub Else If Rs(0)="" Or IsNull(Rs(0)) Then T_Title = Left(Rs(2),25) Else T_Title = Rs(0) End If ToolsParnetID = Rs(3) T_UseTools = LoadUserTools(Rs(1),Dv_Tools.ToolsID) If DateDiff("d",Rs(4),Now())=0 Then ToolsIsToday = 1 End If Rs.Close If ToolsParnetID = 0 Then Sql = "Update Dv_Topic Set BoardID=444,locktopic="&Dvbbs.BoardID&",UseTools='"& T_UseTools &"' Where TopicID=" & TopicID Dvbbs.Execute(Sql) Sql = "Update "&T_PostTable&" Set BoardID=444,locktopic="&Dvbbs.BoardID&",UseTools='"& T_UseTools &"' Where AnnounceID=" & ReplyID Dvbbs.Execute(Sql) Else Sql = "Update "&T_PostTable&" Set BoardID=444,locktopic="&Dvbbs.BoardID&",UseTools='"& T_UseTools &"' Where AnnounceID=" & ReplyID Dvbbs.Execute(Sql) End If '更新所有版面帖子数 AllboardNumSub ToolsIsToday,1,1 '更新相关版面帖子数 Call BoardNumSub(Dvbbs.BoardID,1,1,ToolsIsToday) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&LoadTitle(T_Title)&"已成功删除入论坛回收站！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:一级特赦令，可解除单贴屏蔽 '--------------------------------------------------- Sub Tools_3() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable ' If ToUserID = 0 Then ChkAction = False ' If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 ' Dv_Tools.ChkToUseTools() Sql = "Select Title,UseTools,PostTable From [Dv_Topic] Where TopicID="&TopicID Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在！&action=NoHeadErr" Exit Sub Else T_PostTable = Rs(2) End If Rs.Close Set Rs=Dvbbs.Execute("Select topic,UseTools,Body,postuserid From "&T_PostTable&" Where AnnounceID="&ReplyID&" And LockTopic=2") If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该帖子不存在或不是屏蔽状态！&action=NoHeadErr" Exit Sub Else If Rs(0)="" Or IsNull(Rs(0)) Then T_Title = Left(Rs(2),25) Else T_Title = Rs(0) End If T_UseTools = LoadUserTools(Rs(1),Dv_Tools.ToolsID) End If '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(Rs(3)) Rs.Close Sql = "Update "&T_PostTable&" Set LockTopic=0,UseTools='"& T_UseTools &"' Where AnnounceID=" & ReplyID Dvbbs.Execute(Sql) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&LoadTitle(T_Title)&"已成功解除单贴屏蔽状态！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:二级特赦令，可解除主题锁定 '--------------------------------------------------- Sub Tools_4() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub Sql = "Select Title,UseTools,PostTable From [Dv_Topic] Where TopicID="&TopicID&" And LockTopic=1" Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在或不是锁定状态！&action=NoHeadErr" Exit Sub Else T_Title = Rs(0) T_UseTools = LoadUserTools(Rs(1),Dv_Tools.ToolsID) T_PostTable = Rs(2) End If Rs.Close Sql = "Update [Dv_Topic] Set LockTopic=0,UseTools='"& T_UseTools &"' Where TopicID="&TopicID Dvbbs.Execute(Sql) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&LoadTitle(T_Title)&"已成功解除锁定！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:三级特赦令，解除自己或他人的屏蔽或锁定状态 '--------------------------------------------------- Sub Tools_5() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable ChkAction = True If ToUserID = 0 Then ChkAction = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(ToUserID) Sql = "Select UserID From Dv_User Where UserID="&ToUserID&" And LockUser>0" Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该用户不存在或不是屏蔽或锁定状态！&action=NoHeadErr" Exit Sub Else Dvbbs.Execute("Update Dv_User Set LockUser=0 Where UserID="& Rs(0)) End If Rs.Close Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，用户"&Dv_Tools.ToUserInfo(1)&"已成功解除锁定或屏蔽状态！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:吖噗鸡，可使帖子提升到第一页 '--------------------------------------------------- Sub Tools_6() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub Sql = "Select Title,UseTools,PostTable From [Dv_Topic] Where TopicID="&TopicID&" And LockTopic=1" Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在或不是锁定状态！&action=NoHeadErr" Exit Sub Else T_Title = Rs(0) T_UseTools = LoadUserTools(Rs(1),Dv_Tools.ToolsID) T_PostTable = Rs(2) End If Rs.Close Sql = "Update [Dv_Topic] Set LastPostTime="&SqlNowString&",UseTools='"& T_UseTools &"' Where TopicID="&TopicID Dvbbs.Execute(Sql) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&LoadTitle(T_Title)&"已成功提升到第一页！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:醒目灯，可将主题变色 '--------------------------------------------------- Sub Tools_7() Dim Rs,Sql,i Dim T_Title,T_UseTools,T_PostTable,ToolsColorList If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub Sql = "Select Title,UseTools,PostTable From [Dv_Topic] Where TopicID="&TopicID Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在或不是锁定状态！&action=NoHeadErr" Exit Sub Else T_Title = Rs(0) T_UseTools = LoadUserTools(Rs(1),Dv_Tools.ToolsID) T_PostTable = Rs(2) End If Rs.Close ToolsColorList = "#000000,#F0F8FF,#FAEBD7,#00FFFF,#7FFFD4,#F0FFFF,#F5F5DC,#FFE4C4,#000000,#FFEBCD,#0000FF,#8A2BE2,#A52A2A,#DEB887,#5F9EA0,#7FFF00,#D2691E,#FF7F50,#6495ED,#FFF8DC,#DC143C,#00FFFF,#00008B,#008B8B,#B8860B,#A9A9A9,#006400,#BDB76B,#8B008B,#556B2F,#FF8C00,#9932CC,#8B0000,#E9967A,#8FBC8F,#483D8B,#2F4F4F,#00CED1,#9400D3,#FF1493,#00BFFF,#696969,#1E90FF,#B22222,#FFFAF0,#228B22,#FF00FF,#DCDCDC,#F8F8FF,#FFD700,#DAA520,#808080,#008000,#ADFF2F,#F0FFF0,#FF69B4,#CD5C5C,#4B0082,#FFFFF0,#F0E68C,#E6E6FA,#FFF0F5,#7CFC00,#FFFACD,#ADD8E6,#F08080,#E0FFFF,#FAFAD2,#90EE90,#D3D3D3,#FFB6C1,#FFA07A,#20B2AA,#87CEFA,#778899,#B0C4DE,#FFFFE0,#00FF00,#32CD32,#FAF0E6,#FF00FF,#800000,#66CDAA,#0000CD,#BA55D3,#9370DB,#3CB371,#7B68EE,#00FA9A,#48D1CC,#C71585,#191970,#F5FFFA,#FFE4E1,#FFE4B5,#FFDEAD,#000080,#FDF5E6,#808000,#6B8E23,#FFA500,#FF4500,#DA70D6,#EEE8AA,#98FB98,#AFEEEE,#DB7093,#FFEFD5,#FFDAB9,#CD853F,#FFC0CB,#DDA0DD,#B0E0E6,#800080,#FF0000,#BC8F8F,#4169E1,#8B4513,#FA8072,#F4A460,#2E8B57,#FFF5EE,#A0522D,#C0C0C0,#87CEEB,#6A5ACD,#708090,#FFFAFA,#00FF7F,#4682B4,#D2B48C,#008080,#D8BFD8,#FF6347,#40E0D0,#EE82EE,#F5DEB3,#FFFFFF,#F5F5F5,#FFFF00,#9ACD32" If Request("ToolsAction")="SendColor" Then If Instr("," & ToolsColorList & ",","," & Request("color") & ",")=0 Then Response.redirect "showerr.asp?ErrCodes=
  • 错误的颜色参数！&action=NoHeadErr" Exit Sub End If T_Title = ""&T_Title&"" Dvbbs.Execute("Update Dv_Topic Set Title='"&Replace(T_Title,"'","''")&"',TopicMode=1,UseTools='"& T_UseTools &"' Where TopicID=" & TopicID) Dvbbs.Execute("Update "&T_PostTable&" Set Topic='"&Replace(T_Title,"'","''")&"',UseTools='"& T_UseTools &"' Where RootID="&TopicID&" And ParentID=0") Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&Replace(Replace(LoadTitle(T_Title),"<","<"),">",">")&"已成功操作！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) Else ToolsColorList = Split(ToolsColorList,",") %>
    使用道具 <%=Dv_Tools.ToolsInfo(1)%>
    说明：本道具可使目标帖子标题变成您所选择的颜色，请在下面选择您所需要的颜色
    颜色列表：
    使用效果： <%=Server.HtmlEncode(T_Title)%>
    <% End If End Sub '--------------------------------------------------- '道具:水晶球，可查看发贴用户IP '--------------------------------------------------- Sub Tools_8() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable,ToUserToolsIP ' If ToUserID = 0 Then ChkAction = False ' If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 ' Dv_Tools.ChkToUseTools() Sql = "Select Title,UseTools,PostTable From [Dv_Topic] Where TopicID="&TopicID Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在！&action=NoHeadErr" Response.write "1" Exit Sub Else T_PostTable = Rs(2) End If Rs.Close Set Rs=Dvbbs.Execute("Select Topic,UseTools,Body,IP,postuserid From "&T_PostTable&" Where AnnounceID="&ReplyID) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该帖子不存在！&action=NoHeadErr" Exit Sub Else If Rs(0)="" Or IsNull(Rs(0)) Then T_Title = Left(Rs(2),25) Else T_Title = Rs(0) End If T_UseTools = LoadUserTools(Rs(1),Dv_Tools.ToolsID) ToUserToolsIP = Rs(3) End If '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(Rs(4)) Rs.Close Sql = "Update "&T_PostTable&" Set UseTools='"& T_UseTools &"' Where AnnounceID=" & ReplyID Dvbbs.Execute(Sql) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&LoadTitle(T_Title)&"中帖子编号为"&ReplyID&"的发贴IP是："&ToUserToolsIP&"！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:追踪器，可查看发贴用户的IP和来源 '--------------------------------------------------- Sub Tools_9() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable,ToUserToolsIP,ToUserToolsIP_1,ToUserToolsAddress ' If ToUserID = 0 Then ChkAction = False ' If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 ' Dv_Tools.ChkToUseTools() Sql = "Select Title,UseTools,PostTable From [Dv_Topic] Where TopicID="&TopicID Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在！&action=NoHeadErr" Exit Sub Else T_PostTable = Rs(2) End If Rs.Close Set Rs=Dvbbs.Execute("Select Topic,UseTools,Body,IP,postuserid From "&T_PostTable&" Where AnnounceID="&ReplyID) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该帖子不存在！&action=NoHeadErr" Exit Sub Else If Rs(0)="" Or IsNull(Rs(0)) Then T_Title = Left(Rs(2),25) Else T_Title = Rs(0) End If T_UseTools = LoadUserTools(Rs(1),Dv_Tools.ToolsID) ToUserToolsIP = Rs(3) End If '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(Rs(4)) Rs.Close Sql = "Update "&T_PostTable&" Set UseTools='"& T_UseTools &"' Where AnnounceID=" & ReplyID Dvbbs.Execute(Sql) ToUserToolsIP_1 = ToUserToolsIP ToUserToolsAddress = lookaddress(ToUserToolsIP_1) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&LoadTitle(T_Title)&"中帖子编号为"&ReplyID&"的发贴IP是："&ToUserToolsIP&"，来源是："&ToUserToolsAddress&"！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:一星龙珠，可将用户所有负分转为0 '--------------------------------------------------- Sub Tools_10() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable ChkAction = True If ToUserID = 0 Then ChkAction = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(ToUserID) '更新用户分值信息 Sql = "Select UserWealth,UserEP,UserCP,UserPower,UserDel From Dv_User Where UserID= " & Dv_Tools.ToUserInfo(0) Set Rs = Dvbbs.iCreateObject ("adodb.recordset") If Not IsObject(Conn) Then ConnectionDatabase Rs.Open Sql,Conn,1,3 If Rs("UserWealth") < 0 Then Rs("UserWealth") = 0 If Rs("UserEP") < 0 Then Rs("UserEP") = 0 If Rs("UserCP") < 0 Then Rs("UserCP") = 0 If Rs("UserPower") < 0 Then Rs("UserPower") = 0 If Rs("UserDel") < 0 Then Rs("UserDel") = 0 Rs.Update Rs.Close Set Rs=Nothing '更新用户和系统使用数量 Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，成功将用户"&Dv_Tools.ToUserInfo(1)&"的所有负分转正！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:二星龙珠，可将用户积分负分转为0 '--------------------------------------------------- Sub Tools_11() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable ChkAction = True If ToUserID = 0 Then ChkAction = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(ToUserID ) '更新用户分值信息 Sql = "Select UserEP From Dv_User Where UserID= " & Dv_Tools.ToUserInfo(0) Set Rs = Dvbbs.iCreateObject ("adodb.recordset") If Not IsObject(Conn) Then ConnectionDatabase Rs.Open Sql,Conn,1,3 If Rs("UserEP") < 0 Then Rs("UserEP") = 0 Rs.Update Rs.Close Set Rs=Nothing '更新用户和系统使用数量 Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，成功将用户"&Dv_Tools.ToUserInfo(1)&"的积分负分转正！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:狗仔队，可在用户上线第一时间获知 '--------------------------------------------------- Sub Tools_12() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable ChkAction = True If ToUserID = 0 Then ChkAction = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(ToUserID ) If Dvbbs.UserID = Clng(Dv_Tools.ToUserInfo(0)) Then Dv_Tools.ShowErr(14) Exit Sub End If '更新用户信息 Sql = "Select FollowMsgID From Dv_User Where UserID= " & Dv_Tools.ToUserInfo(0) Set Rs = Dvbbs.iCreateObject ("adodb.recordset") If Not IsObject(Conn) Then ConnectionDatabase Rs.Open Sql,Conn,1,3 If Rs(0)="" Or IsNull(Rs(0)) Then Rs(0) = Dvbbs.Membername Else Rs(0) = Rs(0) & "," & Dvbbs.Membername End If Rs.Update Rs.Close Set Rs=Nothing '更新用户和系统使用数量 Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，成功跟踪用户"&Dv_Tools.ToUserInfo(1)&"，用户上线后会第一时间通知您！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:救生圈，可将帖子固顶6小时 '--------------------------------------------------- Sub Tools_13() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable,LastPostTime If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub Sql = "Select Title,UseTools,PostTable From [Dv_Topic] Where TopicID="&TopicID Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在！&action=NoHeadErr" Exit Sub Else T_Title = Rs(0) T_UseTools = LoadUserTools(Rs(1),Dv_Tools.ToolsID) T_PostTable = Rs(2) End If Rs.Close LastPostTime = DateAdd("h",6,now) Sql = "Update [Dv_Topic] Set LastPostTime='"&LastPostTime&"',UseTools='"& T_UseTools &"' Where TopicID="&TopicID Dvbbs.Execute(Sql) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&LoadTitle(T_Title)&"已成功固顶6小时！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:大救生圈，可将帖子固顶12小时 '--------------------------------------------------- Sub Tools_14() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable,LastPostTime If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub Sql = "Select Title,UseTools,PostTable From [Dv_Topic] Where TopicID="&TopicID Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在！&action=NoHeadErr" Exit Sub Else T_Title = Rs(0) T_UseTools = LoadUserTools(Rs(1),Dv_Tools.ToolsID) T_PostTable = Rs(2) End If Rs.Close LastPostTime = DateAdd("h",12,now) Sql = "Update [Dv_Topic] Set LastPostTime='"&LastPostTime&"',UseTools='"& T_UseTools &"' Where TopicID="&TopicID Dvbbs.Execute(Sql) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&LoadTitle(T_Title)&"已成功固顶12小时！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:时空转移机 可将自已的帖子移动到任意版面（隐含、特殊限定版面除外）。 '--------------------------------------------------- Sub Tools_15() End Sub '--------------------------------------------------- '道具:照妖镜 可查看匿名发帖用户名。 '--------------------------------------------------- Sub Tools_16() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable,ToUserToolsName Sql = "Select Title,UseTools,PostTable From [Dv_Topic] Where TopicID="&TopicID Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在！&action=NoHeadErr" Exit Sub Else T_PostTable = Rs(2) End If Rs.Close Set Rs=Dvbbs.Execute("Select Topic,UseTools,Body,postuserid From "&T_PostTable&" Where AnnounceID="&ReplyID) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该帖子不存在！&action=NoHeadErr" Exit Sub Else If Rs(0)="" Or IsNull(Rs(0)) Then T_Title = Left(Rs(2),25) Else T_Title = Rs(0) End If T_UseTools = LoadUserTools(Rs(1),Dv_Tools.ToolsID) ToUserToolsName = Rs(3) End If '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(Rs(3)) Rs.Close Sql = "Update "&T_PostTable&" Set UseTools='"& T_UseTools &"' Where AnnounceID=" & ReplyID Dvbbs.Execute(Sql) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&LoadTitle(T_Title)&"的发贴人是："&Dv_Tools.ToUserInfo(1)&"！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:晶体探测器 可将匿名发帖用户信息直接转为真实信息，并公开显示状态。 '--------------------------------------------------- Sub Tools_17() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable,ToUserToolsName Sql = "Select Title,UseTools,PostTable From [Dv_Topic] Where TopicID="&TopicID Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在！&action=NoHeadErr" Exit Sub Else T_PostTable = Rs(2) End If Rs.Close Set Rs=Dvbbs.Execute("Select Topic,UseTools,Body,postuserid,ParentID From "&T_PostTable&" Where AnnounceID="&ReplyID) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该帖子不存在！&action=NoHeadErr" Exit Sub Else If Rs(0)="" Or IsNull(Rs(0)) Then T_Title = Left(Rs(2),25) Else T_Title = Rs(0) End If T_UseTools = LoadUserTools(Rs(1),Dv_Tools.ToolsID) ToUserToolsName = Rs(3) End If '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(Rs(3)) If Rs(4)=0 Then Dvbbs.Execute("Update Dv_Topic Set HideName=0 Where TopicID="&TopicID) Rs.Close Sql = "Update "&T_PostTable&" Set UseTools='"& T_UseTools &"',signflag=0 Where AnnounceID=" & ReplyID Dvbbs.Execute(Sql) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&LoadTitle(T_Title)&"的发贴人用户信息已转为显示状态！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:精灵弓，可破坏小救生圈效果，对大救生圈效果破坏1/6 '--------------------------------------------------- Sub Tools_18() Dim Rs,Sql,CanUserTools,UseTools Dim T_Title,T_UseTools,T_PostTable CanUserTools = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub Sql = "Select Title,UseTools,PostTable From [Dv_Topic] Where TopicID="&TopicID Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在！&action=NoHeadErr" Exit Sub Else T_Title = Rs(0) UseTools = Rs(1) If UseTools="" Or IsNull(UseTools) Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题没有被使用相关道具！&action=NoHeadErr" Exit Sub End If If InStr("," & UseTools & ",",",13,") Then CanUserTools = True If InStr("," & UseTools & ",",",14,") Then CanUserTools = True If Not CanUserTools Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题没有被使用相关道具！&action=NoHeadErr" Exit Sub End If T_UseTools = LoadUserTools(UseTools,Dv_Tools.ToolsID) T_PostTable = Rs(2) End If Rs.Close Sql = "" If IsSqlDataBase=1 Then If InStr("," & UseTools & ",",",13,")>0 Then Sql = "Update [Dv_Topic] Set LastPostTime=DateAdd(hour,-6,"&SqlNowString&"),UseTools='"& T_UseTools &"' Where TopicID="&TopicID ElseIf InStr("," & UseTools & ",",",14,")>0 Then Sql = "Update [Dv_Topic] Set LastPostTime=DateAdd(hour,-2,"&SqlNowString&"),UseTools='"& T_UseTools &"' Where TopicID="&TopicID End If Else If InStr("," & UseTools & ",",",13,")>0 Then Sql = "Update [Dv_Topic] Set LastPostTime=DateAdd('h',-6,"&SqlNowString&"),UseTools='"& T_UseTools &"' Where TopicID="&TopicID ElseIf InStr("," & UseTools & ",",",14,")>0 Then Sql = "Update [Dv_Topic] Set LastPostTime=DateAdd('h',-2,"&SqlNowString&"),UseTools='"& T_UseTools &"' Where TopicID="&TopicID End If End If If Sql<>"" Then Dvbbs.Execute(Sql) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&LoadTitle(T_Title)&"对目标帖子操作已成功！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:水之母，可延长大小救生圈固顶效果时限的1/6 '--------------------------------------------------- Sub Tools_19() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable,CanUserTools,UseTools CanUserTools = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub Sql = "Select Title,UseTools,PostTable From [Dv_Topic] Where TopicID="&TopicID Set Rs = Dvbbs.Execute(Sql) If Rs.Eof Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题不存在！&action=NoHeadErr" Exit Sub Else T_Title = Rs(0) UseTools = Rs(1) If UseTools="" Or IsNull(UseTools) Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题没有被使用相关道具！&action=NoHeadErr" Exit Sub End If If InStr("," & UseTools & ",",",13,") Then CanUserTools = True If InStr("," & UseTools & ",",",14,") Then CanUserTools = True If Not CanUserTools Then Response.redirect "showerr.asp?ErrCodes=
  • 该主题没有被使用相关道具！&action=NoHeadErr" Exit Sub End If T_UseTools = LoadUserTools(UseTools,Dv_Tools.ToolsID) T_PostTable = Rs(2) End If Rs.Close Sql = "" If IsSqlDataBase=1 Then If InStr("," & UseTools & ",",",13,")>0 Then Sql = "Update [Dv_Topic] Set LastPostTime=DateAdd(hour,1,"&SqlNowString&"),UseTools='"& T_UseTools &"' Where TopicID="&TopicID ElseIf InStr("," & UseTools & ",",",14,")>0 Then Sql = "Update [Dv_Topic] Set LastPostTime=DateAdd(hour,2,"&SqlNowString&"),UseTools='"& T_UseTools &"' Where TopicID="&TopicID End If Else If InStr("," & UseTools & ",",",13,")>0 Then Sql = "Update [Dv_Topic] Set LastPostTime=DateAdd('h',1,"&SqlNowString&"),UseTools='"& T_UseTools &"' Where TopicID="&TopicID ElseIf InStr("," & UseTools & ",",",14,")>0 Then Sql = "Update [Dv_Topic] Set LastPostTime=DateAdd('h',2,"&SqlNowString&"),UseTools='"& T_UseTools &"' Where TopicID="&TopicID End If End If If Sql<>"" Then Dvbbs.Execute(Sql) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，"&LoadTitle(T_Title)&"对目标帖子操作已成功！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:转生之炎,可将更改自已在论坛的用户名。。 '--------------------------------------------------- Sub Tools_20() ChkAction = True Dim NewUserName,TempLateStr,i,Rs,Sql If Request("ToolsAction")="ChangID" Then NewUserName = Dvbbs.Checkstr(Trim(Request.Form("name"))) If Dvbbs.chkpost = False Then Dvbbs.AddErrCode(16):Exit Sub '验证用户名字符长度是否符合论坛标准 If NewUserName = "" or Dvbbs.strLength(NewUserName)>Cint(Dvbbs.Forum_Setting(41)) or Dvbbs.strLength(NewUserName)0 or Instr(NewUserName,chr(32))>0 or Instr(NewUserName,"?")>0 or Instr(NewUserName,"&")>0 or Instr(NewUserName,";")>0 or Instr(NewUserName,",")>0 or Instr(NewUserName,"'")>0 or Instr(NewUserName,chr(34))>0 or Instr(NewUserName,chr(9))>0 or Instr(NewUserName,"")>0 or Instr(NewUserName,"$")>0 or Instr(NewUserName,"§")>0 Then Dvbbs.AddErrCode(19) ChkAction = False End If '验证用户名是注册过禁止字符； Dim RegSplitWords RegSplitWords = Split(Dvbbs.Forum_setting(4),",") For i = 0 To Ubound(RegSplitWords) If Instr(NewUserName,RegSplitWords(i))>0 Then Dvbbs.AddErrCode(19) ChkAction = False Exit For End If Next If ChkAction = False Then Exit Sub '新用户名是否有重复 Set Rs = Dvbbs.Execute("Select top 1 UserID From [Dv_user] Where UserName = '"&NewUserName&"'") If Not Rs.eof Then Dvbbs.AddErrCode(21) '您输入的用户名已经被注册。 Exit Sub End If Rs.close '------------------------------------------------------------------------------------------------------------- '更新道具表用户名数据 Dvbbs.Plus_Execute("update [Dv_Plus_Tools_Buss] set UserName = '"&NewUserName&"' Where UserID = "&Dvbbs.UserID) Dvbbs.Plus_Execute("update [Dv_MoneyLog] set AddUserName = '"&NewUserName&"' Where AddUserID = "&Dvbbs.UserID) '更新论坛用户名所有数据 Conn.Execute("update [Dv_Admin] set adduser = '"&NewUserName&"' Where adduser = '"&Dvbbs.MemberName&"'") Dvbbs.Execute("update [Dv_User] set username = '"&NewUserName&"' Where UserID = "&Dvbbs.UserID) Dvbbs.Execute("update [Dv_BbsNews] set username = '"&NewUserName&"' Where username = '"&Dvbbs.MemberName&"'") Dvbbs.Execute("update [Dv_BestTopic] set PostUserName = '"&NewUserName&"' Where PostUserID = "&Dvbbs.UserID) Dvbbs.Execute("update [Dv_BookMark] set username = '"&NewUserName&"' Where username = '"&Dvbbs.MemberName&"'") Dvbbs.Execute("update [Dv_Friend] set F_username = '"&NewUserName&"' Where F_userid = "&Dvbbs.UserID) Dvbbs.Execute("update [Dv_Friend] set F_friend = '"&NewUserName&"' Where F_friend = '"&Dvbbs.MemberName&"'") Dvbbs.Execute("update [Dv_Log] set l_username = '"&NewUserName&"' Where l_username = '"&Dvbbs.MemberName&"'") Dvbbs.Execute("update [Dv_Message] set sender = '"&NewUserName&"' Where sender = '"&Dvbbs.MemberName&"'") Dvbbs.Execute("update [Dv_Message] set incept = '"&NewUserName&"' Where incept = '"&Dvbbs.MemberName&"'") Dvbbs.Execute("update [Dv_Online] set username = '"&NewUserName&"' Where UserID = "&Dvbbs.UserID) Dvbbs.Execute("update [Dv_SmallPaper] set S_UserName = '"&NewUserName&"' Where S_UserName = '"&Dvbbs.MemberName&"'") Dvbbs.Execute("update [DV_Upfile] set F_Username = '"&NewUserName&"' Where F_UserID = "&Dvbbs.UserID) Dvbbs.Execute("update [Dv_Topic] set PostUserName = '"&NewUserName&"' Where PostUserID = "&Dvbbs.UserID) '更新圈子用户名所有数据 Dvbbs.Execute("update [Dv_GroupName] set AppUserName = '"&NewUserName&"' Where AppUserID = "&Dvbbs.UserID) Dvbbs.Execute("update [Dv_GroupUser] set UserName = '"&NewUserName&"' Where UserID = "&Dvbbs.UserID) Dvbbs.Execute("update [Dv_Group_Topic] set PostUserName = '"&NewUserName&"' Where PostUserID = "&Dvbbs.UserID) Dvbbs.Execute("update [Dv_Group_BBS] set UserName = '"&NewUserName&"' Where PostUserID = "&Dvbbs.UserID) SQL = "Select TableName,TableType From Dv_TableList" Set Rs = Dvbbs.Execute(SQL) Do while Not Rs.eof Dvbbs.Execute("update "&Rs(0)&" set UserName = '"&NewUserName&"' Where PostUserID = "&Dvbbs.UserID) 'Response.Write SQL(1,i)&"更新完成！
    " Rs.Movenext Loop Rs.close '更新版块出现的用户名 TempStr1="" SQL = "Select Boardid,BoardMaster,LastPost,boarduser From [Dv_Board]" SET Rs = Dvbbs.Execute(SQL) If Not Rs.eof Then SQL = Rs.GetRows(-1) Rs.close For i = 0 To Ubound(SQL,2) If GetInstr(SQL(1,i),Dvbbs.MemberName,"|")=True or GetInstr(SQL(2,i),Dvbbs.MemberName,"$")=True or GetInstr(SQL(3,i),Dvbbs.MemberName,",")=True Then TempStr1 = StrReplace(SQL(1,i),"|",Dvbbs.MemberName,NewUserName) TempStr2 = StrReplace(SQL(2,i),"$",Dvbbs.MemberName,NewUserName) TempStr3 = StrReplace(SQL(3,i),",",Dvbbs.MemberName,NewUserName) Dvbbs.Execute("update [Dv_Board] set BoardMaster = '"& TempStr1 &"',LastPost = '"& TempStr2 &"',boarduser = '"& TempStr3 &"' Where Boardid = "&SQL(0,i)) '更新版面缓存 Dvbbs.ReloadBoardInfo(SQL(0,i)) End If Next Else Rs.close End If Dim TempStr1,TempStr2,TempStr3 '更新主题回复用户名==================>考虑取消(>_<) TempStr2 = Dvbbs.MemberName & "$" SQL = "Select TopicID,LastPost From [Dv_Topic] where LastPost Like '"&TempStr2&"%'" SET Rs = Dvbbs.Execute(SQL) If Not Rs.eof Then SQL = Rs.GetRows(-1) Rs.close:Set Rs = Nothing For i = 0 To Ubound(SQL,2) If GetInstr(SQL(1,i),Dvbbs.MemberName,"$")=True Then TempStr1 = StrReplace(SQL(1,i),"$",Dvbbs.MemberName,NewUserName) Dvbbs.Execute("update [Dv_Topic] set LastPost = '"& TempStr1 &"' Where TopicID = "&SQL(0,i)) End If Next Else Rs.close:Set Rs = Nothing End If '更新用户和系统使用数量 Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，成功将用户名："&Dvbbs.MemberName&"改为："&NewUserName&"！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) '更新用户Session,Cookies信息 Dvbbs.MemberName = NewUserName Dvbbs.TrueCheckUserLogin Dvbbs.NewPassword Dvbbs.Dvbbs_Suc(LogMsg) Else %>
    使用道具 <%=Dv_Tools.ToolsInfo(1)%>
  • <%=Dv_Tools.ToolsInfo(2)%>
  • 注册用户名长度限制为：<%=Dvbbs.Forum_Setting(40)%> －<%=Dvbbs.Forum_Setting(41)%>字符；
  • 改名后下一次将会用新用户名ID登陆，所以更改前务必记下新用户ID；
  • 注意事项，由于大量数据更新，所以更新时请不要刷新，直到提示完成为止！
    • 新论坛用户名：
       
    <% End If End Sub '--------------------------------------------------- '道具:群发器,可发送论坛短消息给所有在线用户。 '--------------------------------------------------- Sub Tools_21() ChkAction = True If Request("ToolsAction")="SendMsg" Then If Dvbbs.chkpost = False Then Dvbbs.AddErrCode(16):Exit Sub Dim MsgTitle,MsgBody,ErrCodes,Rs,Sql,SendUser,i MsgTitle = Dvbbs.Checkstr(Trim(Request.Form("MsgTitle"))) MsgBody = Dvbbs.Checkstr(Trim(Request.Form("MsgBody"))) If MsgTitle="" or Dvbbs.strLength(MsgTitle)>50 Then ErrCodes = ErrCodes & "
  • 标题内容不能为空或超过50字节！" If MsgBody="" or Dvbbs.strLength(MsgBody)>Clng(Dvbbs.GroupSetting(34)) Then ErrCodes = ErrCodes & "
  • 内容不能为空或超过"&Dvbbs.GroupSetting(34)&"字节！" If ErrCodes<>"" Then Response.redirect "showerr.asp?ErrCodes="&ErrCodes&"&action=NoHeadErr" Exit Sub End If LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，在线短信已发送完毕！" Sql = "Select username From Dv_online Where UserID>0 and UserID<>"&Dvbbs.UserID SET Rs = Dvbbs.Execute(SQL) If Not Rs.eof Then SendUser=Rs.GetRows(-1) Else Dvbbs.Dvbbs_Suc(LogMsg) Exit Sub End If Rs.close:Set Rs = Nothing MsgTitle = Dv_Tools.ToolsInfo(1)&"--"&MsgTitle MsgTitle = Dvbbs.Checkstr(MsgTitle) For i=0 To Ubound(SendUser,2) SendUser(0,i) = Dvbbs.Checkstr(SendUser(0,i)) Sql="Insert into Dv_Message (incept,sender,title,content,sendtime,flag,issend) values ('"& SendUser(0,i)&"','"&Dvbbs.MemberName&"','"&MsgTitle&"','"&MsgBody&"',"&SqlNowString&",0,1)" Dvbbs.Execute(SQL) UPDATE_User_Msg(SendUser(0,i)) Next '更新用户和系统使用数量 Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = LogMsg &"共发出"& i &"条论坛短信。" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) Else %>
    使用道具 <%=Dv_Tools.ToolsInfo(1)%>
  • <%=Dv_Tools.ToolsInfo(2)%>
    • 短信标题： (*请在50个字符以内！)
    短信内容：
       
    <% End If End Sub '--------------------------------------------------- '道具:偷窥器，可查看他人金币、点券和道具等保密信息 '--------------------------------------------------- Sub Tools_22() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable ChkAction = True If ToUserID = 0 Then ChkAction = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(ToUserID ) %> <% Set Rs=Dvbbs.Plus_Execute("Select ToolsName,ToolsCount From [Dv_Plus_Tools_Buss] Where ToolsCount>0 and UserID="& Dv_Tools.ToUserInfo(0)&" Order By ToolsCount Desc") Do While Not Rs.Eof %> <% Rs.MoveNext Loop Rs.Close Set Rs=Nothing %>
    使用道具 <%=Dv_Tools.ToolsInfo(1)%>
    目标用户： <%=Dv_Tools.ToUserInfo(1)%>
    金币数量： <%=Dv_Tools.ToUserInfo(5)%> 个
    点券数量： <%=Dv_Tools.ToUserInfo(6)%> 张
    该用户道具信息
    <%=Rs(0)%> <%=Rs(1)%> 个
    <% Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，查看"&Dv_Tools.ToUserInfo(1)&"的用户信息！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) 'Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:查税卡，可对用户的金币执行一定比例的税收，收入归使用者，比例由系统定义 '--------------------------------------------------- Sub Tools_23() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable Dim GetPercent,GetPercentMoney Dim iUserInfo ChkAction = True If ToUserID = 0 Then ChkAction = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(ToUserID) If Dvbbs.UserID = Clng(Dv_Tools.ToUserInfo(0)) Then Dv_Tools.ShowErr(14) Exit Sub End If GetPercent = cCur(Dv_Tools.ToolsSetting(4)) GetPercentMoney = cCur(Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text) + cCur(Dv_Tools.ToUserInfo(5)) * GetPercent Dvbbs.Execute("Update Dv_User Set UserMoney="&GetPercentMoney&" Where UserID="&Dvbbs.UserID) Dvbbs.Execute("Update Dv_User Set UserMoney=UserMoney - "&cCur(Dv_Tools.ToUserInfo(5)) * GetPercent&" Where UserID="&Dv_Tools.ToUserInfo(0)) Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text = GetPercentMoney '发短信通知目标用户 Sql="Insert into Dv_Message (incept,sender,title,content,sendtime,flag,issend) values ('"& Dv_Tools.ToUserInfo(1)&"','"&Dvbbs.MemberName&"','您在论坛上被"&Dvbbs.Membername&"使用了查税卡','您在论坛上被"&Dvbbs.Membername&"使用了查税卡，被该用户收走了 "&cCur(Dv_Tools.ToUserInfo(5)) * GetPercent&" 个金币，被收走的税额为您总金币值的比例为 "&GetPercent&"，关于查税卡和相关的道具信息请看论坛道具中心，感谢您的参与。',"&SqlNowString&",0,1)" Dvbbs.Execute(SQL) UPDATE_User_Msg(Dv_Tools.ToUserInfo(1)) Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，收取"&Dv_Tools.ToUserInfo(1)&"用户"&cCur(Dv_Tools.ToUserInfo(5)) * GetPercent&"个金币！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,GetPercentMoney&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:均富卡，可使使用用户和目标用户金币数相同 '--------------------------------------------------- Sub Tools_24() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable Dim GetPercentMoney Dim iUserInfo ChkAction = True If ToUserID = 0 Then ChkAction = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(ToUserID ) If Dvbbs.UserID = Clng(Dv_Tools.ToUserInfo(0)) Then Dv_Tools.ShowErr(14) Exit Sub End If GetPercentMoney = cCur(Dv_Tools.ToUserInfo(5)) Dvbbs.Execute("Update Dv_User Set UserMoney="&GetPercentMoney&" Where UserID="&Dvbbs.UserID) Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text = GetPercentMoney Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，利润为"&GetPercentMoney - cCur(Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text)&"个金币！" Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,GetPercentMoney&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:均贫卡，可使目标用户和使用用户金币数相同 '--------------------------------------------------- Sub Tools_25() Dim Rs,Sql Dim T_Title,T_UseTools,T_PostTable Dim GetPercentMoney Dim iUserInfo ChkAction = True If ToUserID = 0 Then ChkAction = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(ToUserID ) If Dvbbs.UserID = Clng(Dv_Tools.ToUserInfo(0)) Then Dv_Tools.ShowErr(14) Exit Sub End If If cCur(Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text)"& Dv_Tools.ToolsInfo(1) &"成功，目标用户"& Dv_Tools.ToUserInfo(1) &"的金币数已经和您相等！" '短信通知目标用户 Sql="Insert into Dv_Message (incept,sender,title,content,sendtime,flag,issend) values ('"& Dv_Tools.ToUserInfo(1)&"','"&Dvbbs.MemberName&"','您在论坛上被"&Dvbbs.Membername&"使用了均贫卡','您在论坛上被"&Dvbbs.Membername&"使用了均贫卡，目前金币值为 "&GetPercentMoney&" 个，被系统收走了 "&cCur(Dv_Tools.ToUserInfo(5)) - cCur(Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text)&" 个金币，关于均贫卡和相关的道具信息请看论坛道具中心，感谢您的参与。',"&SqlNowString&",0,1)" Dvbbs.Execute(SQL) UPDATE_User_Msg(Dv_Tools.ToUserInfo(1)) Else '更新使用用户 GetPercentMoney = cCur(Dv_Tools.ToUserInfo(5)) Dvbbs.Execute("Update Dv_User Set UserMoney="&GetPercentMoney&" Where UserID="&Dvbbs.UserID) Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text = GetPercentMoney LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，您的金币数已经和目标用户"& Dv_Tools.ToUserInfo(1) &"相等，利润为"&GetPercentMoney - cCur(Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text)&"个金币！" End If Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:抢夺卡，可随机抢夺目标用户身上1/3到1/2的卡片 '--------------------------------------------------- Sub Tools_26() Dim Rs,Sql Dim rndnum,n,i Dim ToolsCount,SucMsg ChkAction = True If ToUserID = 0 Then ChkAction = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(ToUserID ) If Dvbbs.UserID = Clng(Dv_Tools.ToUserInfo(0)) Then Dv_Tools.ShowErr(14) Exit Sub End If Randomize rndnum=Cint(9999*rnd+1) If rndnum Mod 2 = 0 Then n = 1 Else n = 2 End If Sql = "Select Count(ID) From [Dv_Plus_Tools_Buss] Where ToolsCount>0 and UserID="&ToUserID ToolsCount = Dvbbs.Plus_Execute(Sql)(0) If ToolsCount=0 Then Dv_Tools.ShowErr(18) Exit Sub End If Select Case n '获取目标用户1/3道具 Case 1 ToolsCount = ToolsCount \ 3 '获取目标用户1/2道具 Case 2 ToolsCount = ToolsCount \ 2 End Select Sql = "Select TOP "&ToolsCount&" ID,UserName,ToolsID,ToolsName From [Dv_Plus_Tools_Buss] Where ToolsCount>0 and UserID="&ToUserID Set Rs = Dvbbs.Plus_Execute(SQL) SQL = Rs.GetRows(-1) Rs.close Set Rs = Nothing For i=0 To Ubound(SQL,2) Call UpdateBussTools(Dvbbs.UserID,Sql(2,i),-1) '给用户添加道具 Dvbbs.Plus_Execute("Update [Dv_Plus_Tools_Buss] Set ToolsCount = ToolsCount-1 Where ID="&Sql(0,i)) LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，你已成功从"&Sql(1,i)&"用户获取道具卡《"&Sql(3,i)&"》。" Call Dvbbs.ToolsLog(Sql(2,i),1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) SucMsg = SucMsg &"
  • "& LogMsg Next SucMsg = SucMsg & "
  • 总共获得"&Ubound(SQL,2)+1&"张道具。" Dvbbs.Dvbbs_Suc(SucMsg) End Sub '--------------------------------------------------- '道具:复仇卡，当被人使用恶性道具引起损失，此道具会自动使用并惩罚所使用恶性道具方用户 '--------------------------------------------------- Sub Tools_27() Dim Rs,Sql ChkAction = True If ToUserID = 0 Then ChkAction = False If ChkAction = False Then Dvbbs.AddErrCode(42) : Exit Sub '判断目标用户使用权限并取出目标用户信息 Dv_Tools.ChkToUseTools(ToUserID) If Dvbbs.UserID = Clng(Dv_Tools.ToUserInfo(0)) Then Dv_Tools.ShowErr(14) Exit Sub End If Dim GetPercent,GetPercentMoney LogMsg = "使用："& Dv_Tools.ToolsInfo(1) &"成功，您的金币数已经和目标用户相等，利润为"&GetPercentMoney - cCur(Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text)&"个金币！" Call UpdateUserTools(Dvbbs.UserID,Dv_Tools.ToolsID,1) Call Dvbbs.ToolsLog(Dv_Tools.ToolsID,1,0,0,1,LogMsg,Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text&"|"&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@userticket").text) Dvbbs.Dvbbs_Suc(LogMsg) End Sub '--------------------------------------------------- '道具:获赠金币帖 回复用户可自定数量金币赠送给帖主，赠送总数量在帖子中特殊显示。 '--------------------------------------------------- Sub Tools_28() Response.redirect "showerr.asp?ErrCodes=
  • 该道具只能对采用相关属性类型的帖子进行操作！&action=NoHeadErr" End Sub '--------------------------------------------------- '道具:金币购买帖 发帖者可以定义帖子出售金币值，浏览者需要支付金币购买才可以查看帖子全部内容。 '--------------------------------------------------- Sub Tools_29() Response.redirect "showerr.asp?ErrCodes=
  • 该道具只能对采用相关属性类型的帖子进行操作！&action=NoHeadErr" End Sub '------------------------------------------------------------------------------------------------------ ' '------------------------------------------------------------------------------------------------------ '更新用户及系统道具数量(用户ID，道具ID，减少数量) Sub UpdateUserTools(U_UserID,U_ToolsID,n) Dim Sql,Rs,UpdateNum If Clng(n)<0 Then UpdateNum = "+" & -n Else UpdateNum = "-" & n End If Set Rs = Dvbbs.Plus_Execute("Select ID From [Dv_Plus_Tools_Buss] Where UserID="& U_UserID &" and ToolsID="& U_ToolsID) If Rs.Eof And Rs.Bof Then Dim Trs Set Trs = Dvbbs.Plus_Execute("Select ToolsName From Dv_Plus_Tools_Info Where ID=" & U_ToolsID) If Not (Trs.Eof And Trs.Bof) Then Sql = "Insert Into [Dv_Plus_Tools_Buss] (UserID,UserName,ToolsID,ToolsName,ToolsCount) Values ("&U_UserID&",'"&Dv_Tools.ToUserInfo(1)&"',"&U_ToolsID&",'"&Trs(0)&"',"&Clng(Replace(Replace(UpdateNum,"+",""),"-",""))&")" Dvbbs.Plus_Execute(Sql) End If Trs.Close Set Trs=Nothing Else Sql = "Update [Dv_Plus_Tools_Buss] Set ToolsCount = ToolsCount"&UpdateNum&" Where UserID="& U_UserID &" and ToolsID="& U_ToolsID Dvbbs.Plus_Execute(Sql) End If Rs.Close Set Rs=Nothing Sql = "Update [Dv_Plus_Tools_Info] Set UserStock = UserStock"&UpdateNum&" Where ID="& U_ToolsID Dvbbs.Plus_Execute(Sql) End Sub '更新用户道具数量(用户ID，道具ID，减少数量) Sub UpdateBussTools(U_UserID,U_ToolsID,n) Dim Sql,Rs,UpdateNum If n<0 Then UpdateNum = "+" & -n Else UpdateNum = "-" & n End If Set Rs = Dvbbs.Plus_Execute("Select ID From [Dv_Plus_Tools_Buss] Where UserID="& U_UserID &" and ToolsID="& U_ToolsID) If Rs.Eof And Rs.Bof Then Dim Trs Set Trs = Dvbbs.Plus_Execute("Select ToolsName From Dv_Plus_Tools_Info Where ID=" & U_ToolsID) If Not (Trs.Eof And Trs.Bof) Then Sql = "Insert Into [Dv_Plus_Tools_Buss] (UserID,UserName,ToolsID,ToolsName,ToolsCount) Values ("&U_UserID&",'"&Dv_Tools.ToUserInfo(1)&"',"&U_ToolsID&",'"&Trs(0)&"',"&Clng(Replace(Replace(UpdateNum,"+",""),"-",""))&")" Dvbbs.Plus_Execute(Sql) End If Trs.Close Set Trs=Nothing Else Sql = "Update [Dv_Plus_Tools_Buss] Set ToolsCount = ToolsCount"&UpdateNum&" Where UserID="& U_UserID &" and ToolsID="& U_ToolsID Dvbbs.Plus_Execute(Sql) End If Rs.Close Set Rs=Nothing End Sub Function LoadTitle(Str) LoadTitle = "帖子《"&Server.HtmlEncode(Str)&"》" LoadTitle = Dvbbs.Checkstr(LoadTitle) End Function Function LoadUserTools(Str,AddID) If Str="" or IsNull(Str) Then _ LoadUserTools = AddID _ Else _ LoadUserTools = Str & "," & AddID LoadUserTools = Dvbbs.Checkstr(LoadUserTools) End Function '参数：旧原始值，分隔字符，旧名，替换的新名 Function StrReplace(str,splits,oldstr,newstr) If str<>"" or Not Isnull(str) Then Dim TempStr TempStr = splits & str & splits TempStr = Replace(TempStr , splits & oldstr & splits , splits & newstr & splits) TempStr = Mid(TempStr,2,Len(TempStr)-2) '去掉先后临时分隔符 StrReplace = Dvbbs.CheckStr(TempStr) Else StrReplace = "" End If End Function '参数：目标字符，比较字符，分隔字符 Function GetInstr(Str1,Str2,Strings) GetInstr = False If Str1="" or IsNull(Str1) Then Exit Function If Instr(Strings & Str1 & Strings,Strings & Str2 & Strings) Then GetInstr = True End Function '短信相关更新 Sub UPDATE_User_Msg(username) Dim msginfo If newincept(username)>0 Then msginfo=newincept(username) & "||" & inceptid(3,username) Else msginfo="0||0||null" End If Dvbbs.Execute("update [dv_user] set UserMsg='"&Dvbbs.CheckStr(msginfo)&"' where username='"&Dvbbs.CheckStr(username)&"'") End Sub Function inceptid(stype,iusername) Dim Rs Set Rs=Dvbbs.Execute("Select top 1 id,sender From Dv_Message Where Flag=0 and issend=1 and delR=0 And incept ='"& iusername &"'") If stype=1 then inceptid=Rs(0) ElseIf stype=2 Then inceptid=Rs(1) Else inceptid=Rs(0) &"||"& Rs(1) End If Set Rs = Nothing End Function '统计留言 Function newincept(iusername) Dim Rs Rs=Dvbbs.Execute("Select Count(id) From Dv_Message Where Flag=0 and issend=1 and delR=0 And incept='"& iusername &"'") newincept = Rs(0) Set Rs=Nothing If IsNull(newincept) Then newincept=0 End Function '查看用户来源 Function lookaddress(sip) Dim str1,str2,str3,str4 Dim num Dim irs,SQL If isnumeric(left(sip,2)) Then If sip="127.0.0.1" Then sip="192.168.0.1" str1=left(sip,instr(sip,".")-1) sip=mid(sip,instr(sip,".")+1) str2=left(sip,instr(sip,".")-1) sip=mid(sip,instr(sip,".")+1) str3=left(sip,instr(sip,".")-1) str4=mid(sip,instr(sip,".")+1) If isNumeric(str1)=0 Or isNumeric(str2)=0 Or isNumeric(str3)=0 Or isNumeric(str4)=0 Then Else num=cint(str1)*256*256*256+cint(str2)*256*256+cint(str3)*256+cint(str4)-1 Dim adb,aConnStr,AConn adb = "data/ipaddress.mdb" aConnStr = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(adb) Set AConn = Dvbbs.iCreateObject("ADODB.Connection") aConn.Open aConnStr sql="select country,city from dv_address where ip1 <="&num&" and ip2 >="&num Set irs=aConn.Execute(sql) If irs.eof And irs.bof Then lookaddress=template.Strings(12) Else Do While Not irs.eof lookaddress=lookaddress & "
    " &irs(0) & irs(1) irs.movenext Loop End If irs.close Set irs=nothing Set AConn=Nothing End If Else lookaddress=template.Strings(12) End If End Function '所有论坛发帖数减少 Function AllboardNumSub(todayNum,postNum,topicNum) Dvbbs.Execute("Update dv_Setup Set Forum_TodayNum=Forum_TodayNum-"&todaynum&",Forum_PostNum=Forum_PostNum-"&postNum&",Forum_TopicNum=Forum_TopicNum-"&TopicNum) Dvbbs.ReloadSetupCache CLng(Dvbbs.CacheData(7,0))-TopicNum,7 Dvbbs.ReloadSetupCache CLng(Dvbbs.CacheData(8,0))-postNum,8 Dvbbs.ReloadSetupCache CLng(Dvbbs.CacheData(9,0))-todaynum,9 End Function '版面发帖数减少 Sub BoardNumSub(boardID,topicNum,postNum,todayNum) Dim iUpdateBoardID,UpdateBoardID Dim trs,LastPostTime,LastpostuserID,Lastid,uploadpic_n Dim Lasttopic,LastRootid,LastPostUser,LastPost,i,sql UpdateBoardID = Application(Dvbbs.CacheName&"_boardlist").documentElement.selectSingleNode("board[@boardid='"&Dvbbs.BoardID&"']/@parentstr").text & "," & Dvbbs.BoardID Set trs=Dvbbs.Execute("select top 1 T.title,b.Announceid,b.dateandtime,b.username,b.postuserid,b.rootid from "&Dvbbs.NowUseBBS&" b inner join dv_Topic T on b.rootid=T.TopicID where b.boardid="&boardid&" order by b.Announceid desc") If not(trs.eof and trs.bof) Then Lasttopic=replace(left(trs(0),15),"$","") LastRootid=trs(1) LastPostTime=trs(2) LastPostUser=trs(3) LastPostUserid=trs(4) Lastid=trs(5) else LastTopic="无" LastRootid=0 LastPostTime=now() LastPostUser="无" LastPostUserid=0 Lastid=0 End If trs.close Set trs=nothing LastPost=LastPostUser & "$" & LastRootid & "$" & LastPostTime & "$" & LastTopic & "$" & uploadpic_n & "$" & LastPostUserID & "$" & LastID & "$" & BoardID '更新最后回复及帖子数 2005-12-13 Dv.Yz Dvbbs.Execute("UPDATE Dv_Board SET Postnum = Postnum - " & PostNum & ", TopicNum = TopicNum - " & TopicNum & ", TodayNum = TodayNum - " & TodayNum & ", LastPost = '" & Dvbbs.CheckStr(LastPost) & "' WHERE BoardID IN (" & UpdateBoardID & ")") iUpdateBoardID = Split(UpdateBoardID,",") For i=0 To Ubound(iUpdateBoardID) Dvbbs.LoadBoardinformation iUpdateBoardID(i) Next End Sub %>