<% Dvbbs.LoadTemplates("dispbbs") Dim Rootid,PostTable,Action,RootID_a Dim AnnounceID,Rs,SQL,i Action = Request("action") PostTable=Request("PostTable") PostTable=Checktable(PostTable) Rootid=Request("ID") RootID_a=Request("rootid") AnnounceID=Request("ReplyID") Select Case Action Case "view" : Dvbbs.stats="查看购买贴子的用户" Case "buy" : Dvbbs.stats="金币购买帖子" Case "Send" : Dvbbs.stats="悬赏金币" Case "Close" : Dvbbs.stats="结帖操作" Case Else Dvbbs.stats="购买帖子" End Select Dvbbs.Nav() Dvbbs.Head_var 1,Application(Dvbbs.CacheName&"_boardlist").documentElement.selectSingleNode("board[@boardid='"&Dvbbs.BoardID&"']/@depth").text,"","" If Rootid="" Or Not IsNumeric(Rootid) Then Dvbbs.AddErrCode(35) If AnnounceID="" or Not IsNumeric(AnnounceID) Then Dvbbs.AddErrCode(35) If Dvbbs.UserID=0 Then Dvbbs.AddErrCode(6) Dvbbs.ShowErr() Select Case Action Case "view" : view() Case "buy" : Buy() Case "Send" : SendMoney() Case "Close" : Close() Case Else main() End Select Dvbbs.ShowErr() Dvbbs.Activeonline() Dvbbs.Footer Dvbbs.PageEnd() '结帖操作 Sub Close() Dim PostBuyUser,ToUserName,PostUserID,GetMoney,Topic,TopAnnounceID,LogMsg Dim TempStr Sql = "Select Top 1 PostBuyUser,GetMoney,Topic,AnnounceID From "&PostTable&" where RootID="&Rootid&" and ParentID=0 and GetMoneyType=1 and PostUserID="&Dvbbs.UserID Set Rs=Dvbbs.Execute(Sql) If Rs.eof and Rs.bof Then Dvbbs.AddErrCode(32) Exit Sub Else PostBuyUser = Rs(0) GetMoney = Rs(1) Topic = Rs(2) TopAnnounceID = Rs(3) End If Rs.Close TempStr = Split(PostBuyUser,"|||",2) TempStr(0) = cCur(TempStr(0)) If Request.Form("ReAct")="SaveClose" Then Dim SendMoney If Not Dvbbs.ChkPost Then Dvbbs.AddErrCode(16) Exit Sub End If SendMoney = GetMoney-TempStr(0) If SendMoney<0 Then SendMoney = 0 '更新用户,返还金币 If SendMoney>0 Then Dvbbs.Execute("update [Dv_user] set UserMoney=UserMoney+"&SendMoney&" where userid="&Dvbbs.UserID) Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text = cCur(Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text )+SendMoney '用户金币数量 End If '更新帖子类型 Dvbbs.Execute("update Dv_Topic set GetMoneyType=5 where TopicID="&Rootid) Dvbbs.Execute("update "&PostTable&" set GetMoneyType=5 where AnnounceID="&TopAnnounceID) LogMsg = "结帖操作:悬赏金币帖主题《"&Topic&"》结帖成功,还返金币数为:"&SendMoney&"" Dim Dv_LogMsg Dv_LogMsg = "结帖操作:悬赏金币帖主题《"&Topic&"》结帖成功,还返金币数为:"&SendMoney Dvbbs.Execute("Insert Into Dv_Log (l_AnnounceID,l_BoardID,l_touser,l_username,l_content,l_ip,l_type) values (" & Rootid & "," & Dvbbs.BoardID & ",'" & Dvbbs.MemberName & "','" & Dvbbs.MemberName & "','" & Dvbbs.CheckStr(Dv_LogMsg) & "','" & Dvbbs.UserTrueIP & "',5)") Dvbbs.Dvbbs_Suc(LogMsg) Else %>
《 <%=Topic%> 》 悬赏金币结帖操作
  • 执行结帖后,帖子关闭,不允许其他会员回复。
  • 悬赏金币总数: <%=GetMoney%>
    已悬赏金币总数: <%=TempStr(0)%>
    返还用户金币数: <%=GetMoney-TempStr(0)%>
    <% End If End Sub '悬赏金币帖 Sub SendMoney() Dim PostBuyUser,ToUserName,PostUserID,GetMoney,Topic,TopAnnounceID,LogMsg Dim TempStr,IsSendUser Sql = "Select Top 1 PostBuyUser,GetMoney,Topic,AnnounceID From "&PostTable&" where RootID="&Rootid&" and ParentID=0 and GetMoneyType=1 and PostUserID="&Dvbbs.UserID Set Rs=Dvbbs.Execute(Sql) If Rs.eof and Rs.bof Then Dvbbs.AddErrCode(32) Exit Sub Else PostBuyUser = Rs(0) GetMoney = Rs(1) Topic = Rs(2) TopAnnounceID = Rs(3) End If Rs.Close ToUserName = Request("UserName") TempStr = Split(PostBuyUser,"|||",2) TempStr(0) = cCur(TempStr(0)) If Instr(PostBuyUser,"|||"&ToUserName&",")>0 Then IsSendUser = "[已悬赏]" Else IsSendUser = "[未悬赏]" End If If Request.Form("ReAct")="SaveMoney" Then If Not Dvbbs.ChkPost Then Dvbbs.AddErrCode(16) Exit Sub End If Dim SendMoney SendMoney = Request.Form("SendMoney") If Not Isnumeric(SendMoney) Then Dvbbs.AddErrCode(35) Exit Sub Else SendMoney = cCur(SendMoney) End If If TempStr(0) < 0 Then Response.redirect "showerr.asp?ErrCodes=
    "+"
  • 悬赏的金币数太少或已超出了剩余金币数。&action=OtherErr" TempStr(0) = TempStr(0)+SendMoney If SendMoney<1 or TempStr(0)>GetMoney Then Response.redirect "showerr.asp?ErrCodes=
    "+"
  • 悬赏的金币数太少或已超出了剩余金币数。&action=OtherErr" Exit Sub End If '读取回复用户信息,更新GetMoney数值 Sql = "Select username,PostUserID,GetMoney From "&PostTable&" where AnnounceID="&AnnounceID Dvbbs.SqlQueryNum=Dvbbs.SqlQueryNum+1 set Rs=Dvbbs.iCreateObject("adodb.recordset") Rs.open sql,conn,1,3 If Rs.eof and Rs.bof Then Dvbbs.AddErrCode(32) Dvbbs.ShowErr() Else ToUserName = Rs(0) PostUserID = Rs(1) If PostUserID=Dvbbs.UserID Then Response.redirect "showerr.asp?ErrCodes=
    "+"
  • 悬赏金币帖不能对自已悬赏金币。&action=OtherErr" Exit Sub End If Rs(2) = Rs(2)+SendMoney Rs.Update End If Rs.close TempStr(1) = TempStr(1) & "|||" &ToUserName&","&SendMoney PostBuyUser = TempStr(0) & "|||" & TempStr(1) '更新目标用户,增加金币 Dvbbs.Execute("update [Dv_user] set UserMoney=UserMoney+"&SendMoney&" where userid="&PostUserID) '更新分表中主题行PostBuyUser数据 Dvbbs.Execute("update "&PostTable&" set PostBuyUser = '"&PostBuyUser&"' where AnnounceID="&TopAnnounceID) LogMsg = "关于回复主题《"&Topic&"》的帖子悬赏金币成功,"&ToUserName&"获得金币数为:"&SendMoney&",剩余可悬赏金币数为:"& GetMoney-TempStr(0) &"。" Dvbbs.Dvbbs_Suc(LogMsg) Else %>
    《 <%=Topic%> 》 悬赏金币操作
    悬赏金币总数: <%=GetMoney%>
    已悬赏金币总数: <%=TempStr(0)%>
    悬赏目标用户: <%=Server.HtmlEncode(ToUserName)%> <%=IsSendUser%>
    设置悬赏金币个数: 剩余<%=(GetMoney-TempStr(0))%>金币。
    <% End If End Sub '金币帖子购买 Sub Buy() Dim PostBuyUser,ToUserName,PostUserID,GetMoney,GetMoneyType,IsUpdate,LogMsg,Topic,TempStr IsUpdate = False Sql = "Select PostBuyUser,username,PostUserID,GetMoney,GetMoneyType,Topic From "&PostTable&" where RootID="&Rootid&" and ParentID=0 and GetMoneyType=3" If Not IsObject(Conn) Then ConnectionDatabase Dvbbs.SqlQueryNum=Dvbbs.SqlQueryNum+1 Set Rs = Dvbbs.iCreateObject("adodb.recordset") Rs.open Sql,conn,1,3 If Rs.eof and Rs.bof Then Dvbbs.AddErrCode(32) Dvbbs.ShowErr() Else PostBuyUser = Rs(0) ToUserName = Rs(1) PostUserID = Rs(2) GetMoney = Rs(3) GetMoneyType = Rs(4) Topic = Rs(5) If Not IsNumeric(GetMoney) Then GetMoney=0 If GetMoney < 0 Then Response.redirect "showerr.asp?ErrCodes=
    "+"
  • 由于此贴金币设置数据错误,购买失败。&action=OtherErr" If Instr(PostBuyUser,"|||$PayMoney|||") AND Dvbbs.UserID<>PostUserID AND GetMoney<>0 and InStr(PostBuyUser,"|||"&Dvbbs.Membername&"|||")=0 Then TempStr = Split(Rs(0),"|||",2) Dim BuyMoneyInfo BuyMoneyInfo = Split(TempStr(0),"@@@") BuyMoneyInfo(1) = cCur(BuyMoneyInfo(1)) BuyMoneyInfo(2) = Clng(BuyMoneyInfo(2)) '购买数量限制(设置为“-1”则不限制) If BuyMoneyInfo(1)=0 Then Response.redirect "showerr.asp?ErrCodes=
    "+"
  • 本帖子已售完。&action=OtherErr" Exit Sub ElseIf BuyMoneyInfo(1)>0 Then BuyMoneyInfo(1) = BuyMoneyInfo(1) - 1 End If '当VIP不需要付费时将GetMoney清为0 'If BuyMoneyInfo(2)=0 and Dvbbs.VipGroupUser Then 'GetMoney = 0 'End If '可购买用户名单限制(每个用户名用英文逗号“,”分隔符分开,注意区分大小写) If BuyMoneyInfo(3)<>"" Then If Instr(","&BuyMoneyInfo(3)&",",","&Dvbbs.Membername&",")=0 Then Response.redirect "showerr.asp?ErrCodes=
    "+"
  • 购买失败,非作者指定的用户不能购买该帖。&action=OtherErr" Exit Sub End If End If If GetMoney>CCur(Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text) Then Response.redirect "showerr.asp?ErrCodes=
    "+"
  • 你的用户金币不足,购买该帖失败。&action=OtherErr" Exit Sub End If BuyMoneyInfo(0) = cCur(BuyMoneyInfo(0)) + GetMoney '*ToolsSetting(4) TempStr(0) = BuyMoneyInfo(0) & "@@@" & BuyMoneyInfo(1) & "@@@" & BuyMoneyInfo(2) & "@@@" & BuyMoneyInfo(3) Rs(0) = TempStr(0) & "|||" & TempStr(1) & Dvbbs.Membername & "|||" Rs.Update Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text = Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text -GetMoney Dvbbs.Execute("update [Dv_user] set UserMoney="&Dvbbs.UserSession.documentElement.selectSingleNode("userinfo/@usermoney").text &" where userid="&Dvbbs.userid) Dvbbs.Execute("update [Dv_user] set UserMoney=UserMoney+"&GetMoney&" where userid="&PostUserID) IsUpdate = True Else Response.redirect "showerr.asp?ErrCodes=
    "+"
  • 你不能重复购买或者不能购买自已的金币帖子。&action=OtherErr" Exit Sub End If End If Rs.Close : Set Rs=Nothing If IsUpdate Then LogMsg = "购买金币帖《"&Topic&"》成功,支付金币数为:"&GetMoney&""&ToUserName&"得到金币为:"&GetMoney Dvbbs.Dvbbs_Suc(LogMsg) End If End Sub Sub Main() dim re dim po,ii dim reContent dim strContent dim PostBuyUser po=0 ii=0 dim usermoney If Rootid_a="" Or Not IsNumeric(Rootid_a) Then Dvbbs.AddErrCode(35) set rs=Dvbbs.Execute("select userWealth from [Dv_user] where userid="&Dvbbs.Userid) usermoney=rs(0) Dvbbs.SqlQueryNum=Dvbbs.SqlQueryNum+1 set rs=Dvbbs.iCreateObject("adodb.recordset") sql="select body,PostBuyUser,username,PostUserID,GetMoneyType From "&PostTable&" where Announceid="&Announceid rs.open sql,conn,1,3 If rs.eof and rs.bof Then Dvbbs.AddErrCode(32) Dvbbs.ShowErr() Else If rs(4)>0 Then Response.redirect "showerr.asp?ErrCodes=
    "+"
  • 由于帖子使用了特殊类型,所以不能采用金钱购买帖。&action=OtherErr" Exit Sub End If strContent=Dvbbs.HTMLEncode(rs(0)) PostBuyUser=Trim(rs(1)) 'Response.Write PostBuyUser 'Response.End Set re=new RegExp re.IgnoreCase =true re.Global=True re.Pattern="(^.*)(\[UseMoney=*([0-9]*)\])(.*)(\[\/UseMoney\])(.*)" po=re.Replace(strContent,"$3") If IsNumeric(po) Then ii=int(po) Else ii=0 End If Set re=Nothing If Dvbbs.membername=rs(2) Then response.write "" ElseIf usermoney >ii then If (not isnull(PostBuyUser)) Or PostBuyUser<>"" Then If InStr("|"&PostBuyUser&"|","|"&Dvbbs.membername&"|")>0 Then response.write "" Else Dvbbs.Execute("update [Dv_user] set userWealth=userWealth-"&ii&" where userid="&Dvbbs.userid) Dvbbs.Execute("update [Dv_user] set userWealth=userWealth+"&ii&" where userid="&rs(3)) If IsNull(Rs(1)) or Rs(1)="" Then rs(1)=Dvbbs.membername Else rs(1)=rs(1) & "|" & Dvbbs.membername End If Rs.Update response.write "" End If Else Dvbbs.Execute("update [Dv_user] set userWealth=userWealth-"&ii&" where userid="&Dvbbs.userid) Dvbbs.Execute("update [Dv_user] set userWealth=userWealth+"&ii&" where userid="&rs(3)) rs(1)=Dvbbs.membername Rs.Update response.write "" End If Else response.write "" End If End If Rs.Close Set Rs=Nothing Response.Write "" End Sub Sub view() Dim PostBuyUser sql="select PostBuyUser from "&PostTable&" where Announceid="&Announceid Set rs=Dvbbs.Execute(sql) PostBuyUser=Trim(rs(0)) Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "" Response.Write "
    查看购买贴子的用户
    " If (not isnull(PostBuyUser)) Or PostBuyUser<>"" Then PostBuyUser=Replace(PostBuyUser,"|","
  • ") Response.Write "
  • "&PostBuyUser Else Response.Write "
  • 还未有人购买!" End If Response.Write "
  • " Set rs=Nothing End Sub Function checktable(Table) Table=Right(Trim(Table),2) If Not IsNumeric(table) Then Table=Right(Trim(Table),1) If Not IsNumeric(table) Then Dvbbs.AddErrCode(35) checktable="Dv_bbs"&table End Function %>