postsave.asp

来自「一个asp写的论坛源代码,论坛所需要的功能都有」· ASP 代码 · 共 573 行 · 第 1/2 页

			if Not Team.CodeIsTrue(code) Then
				team.error "验证码错误，请刷新后重新填写。"
			End If
		End If
		Dim rCreatactivity,rCreatereward,rRewardpricetype,rNames,rRunMsg
		Set Rs = team.execute("Select forumid,topic,Replies,Creatactivity,Createreward,Rewardpricetype,UserName,RunMsg,ID From ["&Isforum&"forum] Where ID="& tID)
		If Not Rs.Eof Then
			fID = Rs(0)
			fastReTopic = Rs(1)
			RsCountlist = Rs(2)
			rCreatactivity = Rs(3)
			rCreatereward = Rs(4)
			rRewardpricetype = RS(5)
			rNames = Rs(6)
			rRunMsg = RS(7)
		End if
		Rs.Close:Set Rs=Nothing
		Call ConfigSet
		If CID(rCreatactivity)=1 Then
			team.Execute("insert into ["&Isforum&"Message] (author,incept,content,Sendtime,MsgTopic) values ('"&rNames&"','"&TK_UserName&"','这是由论坛系统自动发送的通知短消息。<BR> 您发起的活动组织 [url=Thread.asp?tid="&tID&"] 『 "&fastReTopic&"  』[/url]有用户反馈，请查看详细情况',"&SqlNowString&",'活动消息回馈')")
			team.execute("Update ["&IsForum&"User] Set Newmessage=Newmessage+1 Where UserName='"&rNames&"'")
		End if
		If CID(rCreatereward)=1 and CID(rRewardpricetype)=0 Then
			If Trim(rNames) <> Trim(TK_UserName) Then
				team.Execute("insert into ["&Isforum&"Message] (author,incept,content,Sendtime,MsgTopic) values ('"&rNames&"','"&TK_UserName&"','这是由论坛系统自动发送的通知短消息。<BR>您悬赏的问题 [url=Thread.asp?tid="&tID&"]『 "&fastReTopic&"  』[/url]有用户反馈，请查看详细情况',"&SqlNowString&",'悬赏消息回馈')")
				team.execute("Update ["&IsForum&"User] Set Newmessage=Newmessage+1 Where UserName='"&rNames&"'")
			End if
		End If
		If CID(rRunMsg)=1 Then
			team.Execute("insert into ["&Isforum&"Message] (author,incept,content,Sendtime,MsgTopic) values ('"&rNames&"','"&TK_UserName&"','这是由论坛系统自动发送的通知短消息。<BR> 您发表的帖子 [url=Thread.asp?tid="&tID&"] 『 "&fastReTopic&"  』[/url]有用户回复，请查看详细情况',"&SqlNowString&",'回复帖子通知')")
			team.execute("Update ["&IsForum&"User] Set Newmessage=Newmessage+1 Where UserName='"&rNames&"'")
		End if
		
		team.execute ("insert into ["&Isforum & team.Club_Class(11)&"] (Topicid,UserName,ReTopic,Content,Posttime,Postip) values ("&tid&",'"&TK_UserName&"','"&ReTopic&"','"&Message&"',"&SqlNowString&",'"&Remoteaddr&"') ")
		team.execute(" Update ["&Isforum&"forum] Set Lasttime="&SqlNowString&",LastText='"&TK_UserName&"$@$"&Cutstr(Message,200)&"',Replies=Replies+1 Where ID="&tid)
		Call UpdateUserpostExc()
		RePage = Abs(int(-Abs(RsCountlist/team.Forum_setting(20))))
		If int(RePage)>1 Then
			Pageinfo = "&Page="& RePage
		End if
		Dim CacheRs,NextID
		NextID = team.execute("Select Followid From [bbsconfig] Where ID="& fID )(0)
		team.execute("Update ["&IsForum&"Bbsconfig] Set Board_Last='<A href=Thread.asp?tid="&tID&" target=""_blank"">"&Cutstr(fastReTopic,200)&"</a> →$@$"&TK_UserName&"$@$"&Now()&"',Tolrestore=Tolrestore+1,today=today+1 Where ID = "& fID )
		team.execute("update ["&IsForum&"ClubConFig] Set today=today+1,RepostNum=RepostNum+1")
		team.LockCache "RepostNum",Application(CacheName&"_RepostNum")+1
		team.LockCache "TodayNum", Application(CacheName&"_TodayNum") + 1		
		Set CacheRs = Team.Execute("Select Followid,ID From ["&IsForum&"bbsconfig] Where ID="& NextID)
		If Not CacheRs.Eof Then
			If Cid(CacheRs(0)) > 0 Then
				NextID = CacheRs(0)
				team.execute("Update ["&IsForum&"Bbsconfig] Set Board_Last='<A href=Thread.asp?tid="&tID&" target=""_blank"">RE:"&Cutstr(fastReTopic,200)&"</a> →$@$"&TK_UserName&"$@$"&Now()&"',today=today+1 Where ID = "& Cid(CacheRs(1)))
			End If
		End If	
		CacheRs.Close:Set CacheRs=Nothing
		Cache.DelCache("BoardLists")
		Session(CacheName&"_UserLogin")=""
		If Request.form("upfileid")<>"" Then
			Dim NewID
			NewID=Split(Replace(Replace(Request.Form("upfileid")," ",""),"'",""),",")
			For i=0 To Ubound(newid)-1
				team.execute("Update ["&IsForum&"Upfile] Set ID= "&tID&" Where FileID="& newid(i))
			Next
		End If
		Session(CacheName & "posttime") = Now()
		team.error1 "<li>回帖帖子成功<li><a href=Thread.asp?tid="& tID & Pageinfo &">返回主题</a><li><a href=Forums.asp?fid="&fID&">返回论坛</a><li><a href=""Default.asp"">返回论坛首页</a><meta http-equiv=refresh content=3;url=Thread.asp?tid="& tID & Pageinfo & "> "
	End Sub

	Private Sub UpdateUserpostExc()
		'用户积分部分
		Dim ExtCredits,MustOpen,ExtSort,MustSort,UExt,u
		Dim UserPostID,MY_ExtCredits,My_ExtSort
		If Not team.UserLoginED Then  Exit Sub
		ExtCredits = Split(team.Club_Class(21),"|")
		MustOpen = Split(team.Club_Class(22),"|")
		MY_ExtCredits=Split(Board_Setting(14),"|")
		If Request("action") = "saves" Then
			For U=0 to Ubound(ExtCredits)
				ExtSort=Split(ExtCredits(U),",")
				MustSort=Split(MustOpen(U),",")
				My_ExtSort=Split(MY_ExtCredits(U),",")
				If ExtSort(3)=1 Then
					If U = 0 Then
						IF Board_Setting(12) = 1 Then
							UExt = UExt &",Extcredits0=Extcredits0+"&My_ExtSort(0)&""
						Else
							UExt = UExt &",Extcredits0=Extcredits0+"&MustSort(0)&""
						End If
					ElseIf U = 1 Then
						IF Board_Setting(12) = 1 Then
							UExt = UExt &",Extcredits1=Extcredits1+"&My_ExtSort(0)&""
						Else
							UExt = UExt &",Extcredits1=Extcredits1+"&MustSort(0)&""
						End If
					ElseIf U = 2 Then
						IF Board_Setting(12) = 1 Then
							UExt = UExt &",Extcredits2=Extcredits2+"&My_ExtSort(0)&""
						Else
							UExt = UExt &",Extcredits2=Extcredits2+"&MustSort(0)&""
						End If
					Else
						UExt = UExt &",Extcredits"&U&"=Extcredits"&U&"+"&MustSort(0)&""
					End if
				End if
			Next
			team.execute("Update ["&IsForum&"User] Set Posttopic=Posttopic+1"&UExt&" Where ID = "& team.TK_UserID )
		ElseIf Request("action") = "resaves" Then
			For U=0 to Ubound(ExtCredits)
				ExtSort=Split(ExtCredits(U),",")
				MustSort=Split(MustOpen(U),",")
				My_ExtSort=Split(MY_ExtCredits(U),",")
				If ExtSort(3)=1 Then
					If U = 0 Then
						IF Board_Setting(13) = 1 Then
							UExt = UExt &",Extcredits0=Extcredits0+"&My_ExtSort(1)&""
						Else
							UExt = UExt &",Extcredits0=Extcredits0+"&MustSort(1)&""
						End If
					ElseIf U = 1 Then
						IF Board_Setting(13) = 1 Then
							UExt = UExt &",Extcredits1=Extcredits1+"&My_ExtSort(1)&""
						Else
							UExt = UExt &",Extcredits1=Extcredits1+"&MustSort(1)&""
						End If
					ElseIf U = 2 Then
						IF Board_Setting(13) = 1 Then
							UExt = UExt &",Extcredits2=Extcredits2+"&My_ExtSort(1)&""
						Else
							UExt = UExt &",Extcredits2=Extcredits2+"&MustSort(1)&""
						End If
					Else
						UExt = UExt &",Extcredits"&U&"=Extcredits"&U&"+"&MustSort(1)&""
					End if
				End if
			Next
			team.execute("Update ["&IsForum&"User] Set Postrevert=Postrevert+1"&UExt&" Where ID = "& team.TK_UserID )
		End If
		'发贴数字能整除十则更新用户等级
		Dim Rs
		Set Rs = team.execute("Select Posttopic From ["&IsForum&"User] Where ID = "& team.TK_UserID )
		If Not Rs.Eof Then
			If Rs(0) Mod 10 < 1 Then UpUserExc()
		End If
		Rs.close:Set Rs=Nothing
	End Sub

	Private Sub UpUserExc()
		Dim Rs,NewLevelName,NewClass,NewID
		Set Rs = team.execute("select GroupName,MemberRank,ID from ["&IsForum&"UserGroup] where ID="& team.UserGroupID)
		If Rs.Eof Or Rs.BOF Then
			Rs=Nothing : Set Rs = team.execute("select top 1 ID,GroupName,UserColor,UserImg,rank,Members,IsBrowse from ["&IsForum&"UserGroup] where not MemberRank=-1 and MemberRank <="&team.UserGroupExs&" ")
			If Not (Rs.Eof And Rs.Bof) Then
				NewLevelName = Rs(1)&"||"& Rs(2) &"||"& Rs(3) &"||"& Rs(4) & "||" & Split(Rs(6),"|")(21)
				NewClass = Rs(5)
				NewID = Rs(0)
			Else
				Set Rs = team.execute("select top 1 ID,GroupName,UserColor,UserImg,rank,Members,IsBrowse from ["&IsForum&"UserGroup] where not MemberRank=-1 and MemberRank = 0")
				If Not Rs.Eof Then
					NewLevelName = Rs(1)&"||"& Rs(2) &"||"& Rs(3) &"||"& Rs(4) & "||" & Split(Rs(6),"|")(21)
					NewClass = Rs(5)
					NewID = Rs(0)
				End If
			End If
			'组名称||颜色||图片||星星||签名UBB
		Else
			If Rs(1) = -1 Then
				Set Rs = team.execute("select ID,GroupName,UserColor,UserImg,rank,Members,IsBrowse from ["&IsForum&"UserGroup] where MemberRank = -1 and ID="& Rs(2))
				If Not Rs.Eof Then
					NewLevelName = Rs(1)&"||"& Rs(2) &"||"& Rs(3) &"||"& Rs(4) & "||" & Split(Rs(6),"|")(21)
					NewClass = Rs(5)
					NewID = Rs(0)	
				End if
			Else
				Set Rs = team.execute("select top 1 ID,GroupName,UserColor,UserImg,rank,Members,IsBrowse from ["&IsForum&"UserGroup] where not MemberRank=-1 and MemberRank <="&team.UserGroupExs&" ")
				If Not (Rs.Eof And Rs.Bof) Then
					NewLevelName = Rs(1)&"||"& Rs(2) &"||"& Rs(3) &"||"& Rs(4) & "||" & Split(Rs(6),"|")(21)
					NewClass = Rs(5)
					NewID = Rs(0)
				Else
					Set Rs = team.execute("select top 1 ID,GroupName,UserColor,UserImg,rank,Members,IsBrowse from ["&IsForum&"UserGroup] where not MemberRank=-1 and MemberRank = 0")
					If Not Rs.Eof Then
						NewLevelName = Rs(1)&"||"& Rs(2) &"||"& Rs(3) &"||"& Rs(4) & "||" & Split(Rs(6),"|")(21)
						NewClass = Rs(5)
						NewID = Rs(0)
					End If
				End If
			End If
		End If
		team.execute("Update ["&IsForum&"User] Set Members='"&NewClass&"',UserGroupID="&CID(NewID)&",Levelname='"&NewLevelName&"' Where ID="& Int(team.TK_UserID))
		Session(CacheName&"_UserLogin") = ""
	End Sub

	Private Sub ConfigSet()
		Dim Rs
		Cache.Name = "SaveThreadBoards_"&Fid
		Cache.Reloadtime = Cid(team.Forum_setting(44))
		If Not Cache.ObjIsEmpty() Then
			Boards = Cache.Value
		Else
			Set Rs=team.Execute("Select ID,Followid,bbsname,Board_Setting,Hide,Pass,Icon,Ismaster,Board_Key,Board_URL,toltopic,tolrestore,Board_Code,lookperm,postperm,downperm,upperm From ["&IsForum&"Bbsconfig] Where  ID = "& Fid)
			If Rs.Eof Then 
				Team.Error "你查询的版面ID错误。"
				Exit Sub
			Else
				Boards = Rs.GetRows(-1)
				Cache.Value = Boards
			End If
			RS.Close:Set RS=Nothing
		End If
		If isarray(Boards) Then
			Board_Setting = Split(Boards(3,0),"$$$")
		End If
		team.ChkPost()
		If Boards(1,0) = 0 Then
			team.Error "一类版块不允许发帖"
		End if
		If Not team.UserLoginED Then 
			team.Error " 您所在的组没有发帖的权限。"
		End if
		If Not IstrueName(tk_UserName) Then 
			team.Error " 您的用户名有错误的字符。 "
		End If
		If Not (Boards(13,0) = ",") Then
			If Instr(Boards(13,0),",") > 0 Then 
				If Not GetUserPower Then team.Error "您没有在本版发布或回复帖子的权限"
			End If
		End If	
		If Boards(5,0)<>"" And Not (team.IsMaster Or team.SuperMaster) Then
			If CID(Request.Cookies("Class")("LoginKey"& fid)) = 0 Then
				team.Error "您必须登陆到此密码板块才可以发布或回复帖子"
			End if
		End If		
	End Sub

	Private Function GetUserPower()
		GetUserPower = False
		Dim B_Lookperm,m
		B_Lookperm = Split(Boards(13,0),",")
		If Isarray(B_Lookperm) Then
			For m = 0 to Ubound(B_Lookperm)-1
				If Cid(B_Lookperm(m)) = Int(team.UserGroupID) Then GetUserPower = True
			Next 
		End  If
	End Function

	Function UpEditTags(uName,uTime)
		Dim tmp
		tmp = uName
		If Not (team.IsMaster Or team.SuperMaster ) Then
			If team.Forum_setting(95)=1 And DateDiff("s",uTime,Now())> 0 Then
				tmp = tmp & "<p align=right><font color=#000066> " &TK_UserName& " 最后编辑于 "&Now()&"</font></p>"
			End If
		End if
		UpEditTags = tmp
	End Function

	Function UpPostName(uName)
		Dim Hname,i
		UpPostName = False
		If Trim(uName) = Trim(TK_UserName) Then
			UpPostName=True 
		End if
		If team.Group_Manage(0) = 1 Then
			UpPostName=True 
		End if
	End Function

	Private Sub NewUserpostTime()
		If Cid(team.Forum_setting(14))>0 And team.UserLoginED And Not team.ManageUser Then
			If Not IsDate(team.User_SysTem(9)) Then team.User_SysTem(9) = Now()
			If DateDiff("n",CDate(team.User_SysTem(9)),Now()) < Cid(team.Forum_setting(14)) Then 
				team.error "新注册用户必须停留 <font color=red> "&team.Forum_setting(14)&" </font> 分钟以上才可发表帖子。"
			End if
		End If
	End Sub
	Private Sub CheckpostTime()
		If Clng(team.Forum_setting(50)) Then
			Exit Sub
		Else
			If DateDiff("s",Session(CacheName &"posttime"),Now())< Clng(team.Forum_setting(50)) Then
				team.Error "为防止有人用程序灌水，论坛限制单个用户两次发帖间隔必须大于"&team.Forum_setting(50)&"秒，您还需要等待 "&DateDiff("s",Session(CacheName &"posttime"),Now())&" 秒才可以发贴。"
			End If
		End if
	End Sub
End Class
team.htmlend
%>