<% 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,Dvbbs.BoardNode.attributes.getNamedItem("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 '结帖操作 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.MyUserInfo(37) = cCur(Dvbbs.MyUserInfo(37))+SendMoney '用户金币数量 Session(Dvbbs.CacheName & "UserID") = Dvbbs.MyUserInfo 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=server.createobject("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 = Server.createobject("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" Dvbbs.MyUserInfo(37) = cCur(Dvbbs.MyUserInfo(37)) '用户金币数量 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>Dvbbs.MyUserInfo(37) 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.MyUserInfo(37) = Dvbbs.MyUserInfo(37)-GetMoney Dvbbs.Execute("update [Dv_user] set UserMoney="&Dvbbs.MyUserInfo(37)&" 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 Session(Dvbbs.CacheName & "UserID")=Dvbbs.MyUserInfo 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=server.createobject("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 %>