21.显示在线人数
*********GLOBAL.ASA***********
<SCRIPT LANGUAGE=VBScript RUNAT=Server>
Sub Application_onStart
Application("OnLine") = 0
End Sub
Sub Session_onStart
Application.Lock
Application("OnLine") = Application("OnLine") + 1
Application.Unlock
End Sub
Sub Session_OnEnd
Application.Lock
Application("OnLine") = Application("OnLine") - 1
Application.Unlock
End Sub
</SCRIPT>
*************end*******
<%@language=VBscript%>
<Html>
<head>
<title>
显示在线人数
</title>
</head>
<body>
<center>
欢迎光临本网站,当前共有<%=Application("OnLine")%>在线
</center>
</body>
22.井字游戏
<%
response.Expires=0
%>
<html>
<title>井字游戏</title>
<body>
<Table border=1 align=center>
<%
function test4(m,n)
if m>3 or n>3 or m<0 or n<0 then exit function
if a(m,1)=a(m,2) and a(m,2)=a(m,3) then
if a(m,1)=1 then
test4=1
exit function
end if
end if
if a(1,n)=a(2,n) and a(2,n)=a(3,n) then
if a(1,n)=1 then
test4=1
exit function
end if
end if
if a(1,1)=a(2,2) and a(1,1)=a(3,3) then
if a(2,2)=1 then
test4=1
exit function
end if
end if
if a(1,3)=a(2,2) and a(2,2)=a(3,1) then
if a(2,2)=1 then
test4=1
exit function
end if
end if
test4=0
end function
function test3(m)
dim i
for i=1 to 3
if a(i,1)=a(i,2) and a(i,3)=0 then
if a(i,1)=m then
a(i,3)=2
test3=1
exit function
end if
elseif a(i,2)=a(i,3) and a(i,1)=0 then
if a(i,2)=m then
a(i,1)=2
test3=1
exit function
end if
elseif a(i,1)=a(i,3) and a(i,2)=0 then
if a(i,1)=m then
a(i,2)=2
test3=1
exit function
end if
end if
next
for i=1 to 3
if a(1,i)=a(2,i) and a(3,i)=0 then
if a(1,i)=m then
a(3,i)=2
test3=1
exit function
end if
elseif a(2,i)=a(3,i) and a(1,i)=0 then
if a(2,i)=m then
a(1,i)=2
test3=1
exit function
end if
elseif a(1,i)=a(3,i) and a(2,i)=0 then
if a(1,i)=m then
a(2,i)=2
test3=1
exit function
end if
end if
next
if a(1,1)=a(2,2) and a(3,3)=0 then
if a(1,1)=m then
a(3,3)=2
test3=1
exit function
end if
elseif a(1,1)=a(3,3) and a(2,2)=0 then
if a(1,1)=m then
a(2,2)=2
test3=1
exit function
end if
elseif a(2,2)=a(3,3) and a(1,1)=0 then
if a(2,2)=m then
a(1,1)=2
test3=1
exit function
end if
elseif a(1,3)=a(3,1) and a(2,2)=0 then
if a(1,3)=m then
a(2,2)=2
test3=1
exit function
end if
elseif a(1,3)=a(2,2) and a(3,1)=0 then
if a(2,2)=m then
a(3,1)=2
test3=1
exit function
end if
elseif a(2,2)=a(3,1) and a(1,3)=0 then
if a(2,2)=m then
a(1,3)=2
test3=1
exit function
end if
end if
test3=0
end function
function test2
dim m,n
dim RowArray(10)
dim LineArray(10)
dim Count
dim Rand
Count=0
for m=1 to 3
for n=1 to 3
if a(m,n)=0 then
count=count+1
LineArray(count)=m
RowArray(count)=n
end if
next
next
if count=0 then
test2=0
exit function
else
randomize
Rand=Int(rnd * Count + 1 )
a(LineArray(Rand),RowArray(Rand))=2
test2=1
end if
end function
dim a(3,3)
dim over
x=request("X")
y=request("Y")
if x>0 and y>0 and x<4 and y<4 then
a(x,y)=1
elseif x=0 then
if y=0 then
session("a")=a
session("race")=-1
else
session("a")=a
session("race")=-2
end if
end if
session("race")=session("race")+1
for j=1 to 3
for i=1 to 3
if session("a")(i,j)=1 then
a(i,j)=1
elseif session("a")(i,j)=2 then
a(i,j)=2
end if
next
next
over=0
if session("race")>=0 then
if test4(x,y)=1 then
over=1
response.write "You won"
elseif test3(2)=1 then
response.write "I won"
session("race")=session("race")+1
over=2
elseif test3(1)=1 then
session("race")=session("race")+1
elseif test2=1 then
session("race")=session("race")+1
else
over=3
end if
else
session("race")=0
end if
response.write " "
if session("race")=9 then
response.write "Game Over"
end if
session("a")=a
for j=1 to 3
response.write "<tr>"
for i=1 to 3
if session("a")(i,j)=0 then
if over=0 then
response.write "<td><a href=Game.asp?X=" & i & "&Y=" & j & " > <font color=white><b> ⊙ </b></font></a></td>"
else
response.write "<td><font color=white><b> ⊙ </b></font></td>"
end if
elseif session("a")(i,j)=1 then
response.write "<td><font color=blue><b> ★ </b></font></td>"
elseif session("a")(i,j)=2 then
response.write "<td><font color=red><b> ⊙ </b></font></td>"
end if
next
response.write "</tr> "
next
%>
</table>
<hr>
<center>重新开始<br>
<a href=Game.asp?X=0&Y=-1>你先</a>
<a href=Game.asp?X=0&Y=0>我先</a>
<%=session("race")%>
</center>
23.猜数字游戏
<%@ LANGUAGE = VBScript %>
<% Option Explicit %>
<Html>
<title>猜数字游戏</title>
<body>
<%
'设置页面不使用缓存
Response.Expires = 0
%>
<%
dim GuessNum
on error resume next
GuessNum=Request("Number")
if GuessNum="" then GuessNum="0" End if
GuessNum=Clng(GuessNum)
Session("Count")=Session("Count") + 1
if Session("Count") < 10 and GuessNum <> session("Number") then
%>
<form action="guessNumber.asp">
<input type="text" name="Number">
<input type="submit" value="提交">
</form>
<hr>
<%
end if
if GuessNum<0 or guessNum>100 then
Response.write "请输入1~100之间的整数"
elseif GuessNum=0 then
session("Count") = 0
Randomize
session("Number") = Int(rnd * 100 + 1)
Response.write "请输入1~100之间的整数"
elseif GuessNum > session("Number") then
response.write "你猜的太大了"
elseif GuessNum < session("Number") then
response.write "你猜的太小了"
elseif GuessNum = session("Number") then
response.write "祝贺你,猜对了"
end if
Response.write "<br>共猜了" & Session("Count") & "次"
if Session("Count")=10 then
Response.write "答案是" & Session("Number")
end if
%>
<a href="guessnumber.asp?Number=0">重新猜</a>
</body>
</html>
24.500-100错误
<%@ language="VBScript" %>
<%
Option Explicit
Const lngMaxFormBytes = 200
Dim objASPError, blnErrorWritten, strServername, strServerIP, strRemoteIP
Dim strMethod, lngPos, datNow, strQueryString, strURL
If Response.Buffer Then
Response.Clear
Response.Status = "500 Internal Server Error"
Response.ContentType = "text/html"
Response.Expires = 0
End If
Set objASPError = Server.GetLastError
%>
<html>
<title>本页无法显示</title>
<META HTTP-EQUIV="Content-Type" Content="text-html; charset=gb2312">
<body bgcolor="FFFFFF">
<table border=1>
<tr><td>错误类型：</td>
<td>
<%
Dim bakCodepage
bakCodepage = Session.Codepage
Session.Codepage = 936
Response.Write Server.HTMLEncode(objASPError.Category)
If objASPError.ASPCode > "" Then Response.Write Server.HTMLEncode(", " & objASPError.ASPCode)
Response.Write Server.HTMLEncode(" (0x" & Hex(objASPError.Number) & ")" )
%>
</td></tr><tr><td>错误描述:</td><td>
<%
If objASPError.ASPDescription > "" Then Response.Write Server.HTMLEncode(objASPError.ASPDescription)
%>
</td></tr><tr><td>错误定位:</td><td>
<%
blnErrorWritten = False
If objASPError.Source > "" Then
strServername = LCase(Request.ServerVariables("SERVER_NAME"))
strServerIP = Request.ServerVariables("LOCAL_ADDR")
strRemoteIP = Request.ServerVariables("REMOTE_ADDR")
If (strServername = "localhost" Or strServerIP = strRemoteIP) And objASPError.File <> "?" Then
Response.Write Server.HTMLEncode(objASPError.File)
If objASPError.Line > 0 Then Response.Write ", 第 " & objASPError.Line & " 行"
If objASPError.Column > 0 Then Response.Write ", 第 " & objASPError.Column & " 列"
Response.Write Server.HTMLEncode(objASPError.Source) & "<br>"
If objASPError.Column > 0 Then Response.Write String((objASPError.Column - 1), "-") & "^<br>"
blnErrorWritten = True
End If
End If
If Not blnErrorWritten And objASPError.File <> "?" Then
Response.Write "<b>"
Response.Write Server.HTMLEncode(objASPError.File)
If objASPError.Line > 0 Then Response.Write Server.HTMLEncode(", 第 " & objASPError.Line & " 行")
If objASPError.Column > 0 Then Response.Write ", 第 " & objASPError.Column & " 列"
Response.Write "</b><br>"
End If
%>
</td></tr>
<tr><td>浏览器类型：</td><td>
<%= Request.ServerVariables("HTTP_USER_AGENT") %>
</td></tr>
<tr><td>时间：</td><td>
<%
datNow = Now()
Response.Write Server.HTMLEncode(FormatDateTime(datNow, 1) & ", " & FormatDateTime(datNow, 3))
Session.Codepage = bakCodepage
%>
</td></tr>
</table>
</body>
</html>
25.使用正则表达式的典范-显示超链接
<Html>
<Head>
<Title>
显示超链接
</Title>
</Head>
<Body>
<%
s_message="<a href=hello.asp>hello</a>"
Response.Write "这是转换前的输出:<br>"
Response.Write s_message & "<br>"
Response.Write "这是用to_html函数转换后的输出:<br>"
Response.Write to_html(s_message) & "<br>"
Response.Write "这是用Server.HTMLencode函数转换后的输出:<br>"
Response.Write Server.HTMLEncode(s_message)
%>
<%
Function to_html(s_string)
to_html = Replace(s_string, """", """)
to_html = Replace(to_html, "<", "<")
to_html = Replace(to_html, ">", ">")
to_html = Replace(to_html, vbcrlf, "<br>")
to_html = Replace(to_html, "/<", "<")
to_html = Replace(to_html, "/>", ">")
to_html = edit_hrefs(to_html)
End Function
%>
<script language="javascript1.2" runat=server>
function edit_hrefs(s_html){
// 一个使用正则表达式的典范
// 转换文本中所有的超链接和电子邮件格式
s_str = new String(s_html);
s_str = s_str.replace(/\bhttp\:\/\/www(\.[\w+\.\:\/\_]+)/gi,
"http\:\/\/¬¤¸$1");
s_str = s_str.replace(/\b(http\:\/\/\w+\.[\w+\.\:\/\_]+)/gi,
"<a href=\"$1\">$1<\/a>");
s_str = s_str.replace(/\b(www\.[\w+\.\:\/\_]+)/gi,
"<a href=\"http://$1\">$1</a>");
s_str = s_str.replace(/\bhttp\:\/\/¬¤¸(\.[\w+\.\:\/\_]+)/gi,
"<a href=\"http\:\/\/www$1\">http\:\/\/www$1</a>");
s_str = s_str.replace(/\b(\w+@[\w+\.?]*)/gi,
"<a href=\"mailto\:$1\">$1</a>");
return s_str;
}
</script>
</Body>
</Html>