z_love.asp

本程序蓝本为6kbbs 默认前台管理员的帐号是:woodcoal

<!--#include file=up.asp-->

<%=ttop%>
<div align='center'>
 <center>
<table width="<%=tbw%>" border="1" bordercolor="<%=c1%>" cellspacing="0" class=tableBorder6 cellspacing='0' style='border-collapse: collapse'>
 <tr>
<td class=td1 bgcolor="<%=c1%>" background="<%=tbg%>" height="28">&nbsp;<img src="pic/gl.gif" border="0"><font color="<%=c3%>">☆幸福恋人☆</font></td>
 </tr>
 </table>
 </center>
</div>
<div align='center'>
 <center>
<%
if lguserid="" then response.redirect"login.asp"
if request("action")<>"" then
select case request("action")
case "over"
	call doover()
case "love"
	call dolove()
case "agree"
	call agree()
end select
end if

call main()
%><%call down%><%
sub main()	
response.write "<table border=0 align=center cellpadding=0 cellspacing=0 width=""&tbw&""><tr><td valign=top width=""25%"">"
call mylove()
call loveme()
response.write "</td><td valign=top width=""75%"">"
Call alllove()
call guize()
response.write "</td></tr></table>"&tbottom&""
end sub
sub mylove()
dim sql,rs
response.write "<br><table border=1 bordercolor="&c1&" align=center cellpadding=3 cellspacing=1>"
response.write "<form name=""form1"" method=""get"" action=""z_love.asp"">"
response.write "<tr><td align=center height=25>我的丘比特</td></tr>"
response.write "<tr><td align=center height=23>"
sql="select wife,wantlove from [user] where name='"&lgname&"'"
set rs=conn.execute(sql)
if rs("wife")<>"" and rs("wife")<>"无" then
response.write "<br>您的恋人是："&Rs("wife")&"<br><br>"
response.write "<div align=right><a href='?action=over'>我要解除恋爱关系</a></div>"
elseif rs("wantlove")>"" then
response.write "<br>您目前正在向"&Rs("wantlove")&"求爱<br><br>"
response.write "<input name=""username"" type=""text"" id=""username"" size=""12"" maxlength=""16""><input type=""submit"" value=""移情别恋""><br><br>"
else	
response.write "<br><input name=""username"" type=""text"" id=""username"" size=""12"" maxlength=""16""><input type=""submit""  value=""向他求爱""><br><br>"
end if
response.write "</td></tr>"
response.write "<input name=""action"" type=""hidden"" id=""action"" value=""love""></form>"
response.write "</table><br>"
end sub

sub loveme()
dim i,sql,rs
response.write "<table border=1 bordercolor="&c1&" align=center cellpadding=3 cellspacing=1>"
response.write "<form name=""form1"" method=""get"" action=""z_love.asp?action=agree"">"
response.write "<tr><td align=center height=25>我的追求者</td></tr>"
response.write "<tr><td align=center height=23>"	
sql="select name from [user] where wantlove='"&lgname&"'"
Set Rs=Server.CreateObject("ADODB.Recordset")
Rs.open sql,conn,3,2
if Rs.recordcount=0 then
response.write "<br><br>暂时没人向您求爱相信自己<br><br><br>"
else
response.write "<br><select name=""username"">"
for i=1 to Rs.recordcount	
response.write "<option value="""&Rs("name")&""">"&Rs("name")&"</option>"
Rs.movenext
next
response.write "</select>"
response.write "<input type=""submit""  class=submit value=""接受求爱"" name=""action2""><br><input type=""submit"" class=submit value=""拒绝求爱"" name=""action2""><br>"
end if
response.write "</td></tr>"
response.write "<input name=""action"" type=""hidden"" id=""action"" value=""agree""></form>"
response.write "</table>"
end sub

sub alllove()
dim sql,rs,i,l
l=0
sql="select name,wife,userinfo from [user] where wife<>'' order by userid"
response.write "<table border=0 bordercolor="&c1&" align=center cellpadding=20  align=center cellspacing=1>"
response.write "<tr><td align=center height=25>所有恋人</td></tr>"
response.write "<tr><td>"
Set Rs=Server.CreateObject("ADODB.Recordset")
Rs.open sql,conn,3,2
if Rs.recordcount=0 then
response.write "<br><br>目前暂时没有论坛恋人<br><br><br>"
else
response.write "<marquee height=150 direction=up width=200 scrollamount=2 onMouseOver=this.stop() onMouseOut=this.start()><table align=center width='100%'><tr>"
for i=1 to Rs.recordcount	
response.write "<td width='100%'><img src=pic/tl.gif>"&Rs("name")&" <img src=pic/tl.gif>"&Rs("wife")&"<br><br></td>"
l=l+1
if l=1 then
response.write "</tr><tr>"
l=0
end if
Rs.movenext
next
response.write "</tr></table></marquee>"
end if
response.write "</td></tr>"
response.write "</table><br>"
end sub

sub guize()
response.write "<table border=0 align=center cellpadding=3 cellspacing=1>"
response.write "<tr><td align=center height=25>丘比特规则</td></tr>"
response.write "<tr><td align=left height=23>"
response.write "<ol>"
response.write "<li><b>恋爱自由</b><br>　　只要双方都愿意即可确定恋爱关系</li>"
response.write "<li><b>解除恋爱关系同样自由</b><br>　　只要一方申请即可解除恋爱关系</li>"
response.write "<li><b>专一原则</b><br>　　如果您已经有恋人了，必须解除恋爱关系才能向其他人求爱。<br>　　如果您还没有恋人，同一时间您也只能向一个人求爱。</li>"
response.write "<li><b>恋爱开放原则</b><br>　　即使对方已经有恋人了，您还是可以向他求爱。</li>"
response.write "<li><b>求爱保密原则</b><br>　　除了当事人，其他任何人都无法知道您的求爱记录。</li>"
response.write "</ol>"
response.write "</td></tr>"
response.write "</table>"
end sub

sub doover()
dim rs,sql
sql="select wife from [user] where name='"&lgname&"'"
set rs=conn.execute(sql)
if rs("wife")="" or rs("wife")="无" then
call pageTo("您已经是单身贵族了。","z_love.asp")
else
conn.execute("update [user] set wife='',[mark]=mark-50 where wife='"&lgname&"'")
conn.execute("update [user] set wife='',[mark]=mark-50 where wife='"&rs("wife")&"'")
call pageTo("成功解除了你们的恋爱关系。\r欢迎你回到单身贵族的行列。","z_love.asp")
end if
end sub

sub dolove()
dim sql,rs,wantlove,rs2,notice
wantlove=replace(request("username"),"'","''")
sql="select wantlove from [user] where name='"&lgname&"'"
set rs=conn.execute(sql)
if wantlove=lgname then
notice=notice&"你没有搞错啊，居然向自己求婚。我看你是被爱情冲昏了头了。\r"
	call pageTo(notice&"你不能向自己求婚啊！祝你早日找到对象！","z_love.asp")
else
if Rs("wantlove")=wantlove then
setAlert("死缠烂打是没有用的。\r求爱宣言发一次就够了。")	
elseif rs("wantlove")>"" then
conn.execute("update [User] set wantlove='',[mark]=mark-50 where name='"&lgname&"'")
notice="您移情别恋，扣除了50点积分,\r\r"
end if
sql="select wife from [User] where name='"&wantlove&"'"
set rs2=conn.execute(sql)
if rs2.eof then
call pageTo(notice&"没有找到您要求爱的对象，请检查您的输入。","z_love.asp")
elseif Rs("wantlove")=Rs2("wife") then '如果允许同性恋就在本行最前面加上'
call pageTo(notice&"汗~~自已找自已~喂精神病院啊你们那边有没有一个病人逃出来了？！","z_love.asp")'同上
elseif Rs2("wife")<>"" then
conn.execute("update [User] set wantlove='"&wantlove&"',mark=mark-10 where name='"&lgname&"'")
conn.execute("update [user] set [mark]=mark+10 where name='"&wantlove&"'")
notice=notice&"您向"&wantlove&"求爱，增加了10点积分。\r"
notice=notice&wantlove&"增加了10点积分。\r\r"			
call pageTo(notice&"你爱的人已经有恋人了。\r您的求爱宣言也许要很久以后才会有回音。","z_love.asp")
end if
conn.execute("update [User] set wantlove='"&wantlove&"',[mark]=mark-20 where name='"&lgname&"'")
conn.execute("update [user] set [mark]=mark+10 where name='"&wantlove&"'")
notice=notice&"您向"&wantlove&"求爱，扣20点积分。\r"
notice=notice&wantlove&"增加了10点积分。\r\r"			
	call pageTo(notice&"已经为你传递了向"&wantlove&"的求爱宣言。","z_love.asp")
end if
end sub

sub agree()
dim sql,rs,wantlove,rs2,notice
	wantlove=server.htmlencode(replace(request("username"),"'","''"))
	sql="select [wantlove] from [User] where name='"&wantlove&"'"
	set rs=conn.execute(sql)		
	if rs.eof then
		call pageTo("该用户不存在。\r请检查您是否从本站安全链接进入。","z_love.asp")
	elseif rs("wantlove")<>lgname then
	call pageTo("该用户没有向您发出求爱请求。\r或许该请求已被回应，或许对方已经撤回请求。","z_love.asp")
	end if
	
if request("action2")="接受求爱" then	
	sql="select wife from [User] where name='"&lgname&"'"
	set rs=conn.execute(sql)		
	if rs("wife")>"" then
		call setAlert("您必须先和您的恋人解除恋爱关系才可以接受别人的求爱。")
	end if
	
	conn.execute("update [user] set wantlove='',wife='"&wantlove&"',[mark]=mark+100 where name='"&lgname&"'")
	conn.execute("update [User] set wantlove='',wife='"&lgname&"',[mark]=mark+100 where name='"&wantlove&"'")				
	call pageTo("恭喜你们成功确定了恋爱关系！\r你和您的恋人各加100积分！\r记得请大家吃糖哦^_^","z_love.asp")
else
	conn.execute("update [User] set wantlove='',[mark]=mark-50 where name='"&wantlove&"'")
	call pageTo("拒绝了对方的求爱。\r并减去他50点积分。","z_love.asp")
end if	
end sub

Const Text1="<html><head><meta http-equiv=Content-Type content=text/html; charset=gb2312><title>提示</title><meta http-equiv=pragma content=no-cache>"
Const Text2="</head><body></body></html>"
sub setAlert(str)
   response.write Text1&"<SCRIPT language=JavaScript>alert('"&str&"');javascript:history.go(-1)</SCRIPT>"&Text2
   response.end
end sub
sub setAlert2(str)
   response.write Text1&"<SCRIPT language=JavaScript>alert('"&str&"');javascript:history.go(-2)</SCRIPT>"&Text2
   response.end
end sub
sub pageTo(alerttext,topage)
   response.write Text1&"<SCRIPT language=JavaScript>alert('"&alerttext&"');location.href='"&topage&"';</SCRIPT>"&Text2
   response.end
end sub
sub closewin(alerttext)
   response.write Text1&"<SCRIPT language=JavaScript>alert('"&alerttext&"');window.close();</SCRIPT>"&Text2
   response.end
end sub
%>