ctr.asp

趣味性聊天源码

<% @EnableSessionState=True %>
<% Option Explicit %>
<% Response.Expires=0 %>
<% Response.Buffer=True %>
<% Response.Cachecontrol="Public" %>
<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>
Sub SubSessInit():
	Dim arrTmp():
		Set Session("strSes") = Nothing: ReDim arrTmp(12):
		arrTmp(0) = "": arrTmp(1) = "1": arrTmp(2) = Now(): arrTmp(6) = Now(): arrTmp(8) = Now(): 
		arrTmp(9) = "Rom": arrTmp(10) = "ton": arrTmp(11) = Now(): arrTmp(12) = "on":
		strSes = arrTmp: Session("strSes") = strSes: Session.Timeout = 15:
End Sub:
Sub SubAppInit(): 
	Dim arrTmp(), intNr1:
	Application.Lock:
		Set Application("strMsg" & Pwd(2)) = Nothing: Set Application("strUsr" & Pwd(2)) = Nothing:
		Set Application("strUpd" & Pwd(2)) = Nothing: Set Application("strApp" & Pwd(2)) = Nothing:
		ReDim arrTmp(180, 2): arrTmp(0, 0) = "": Application("strMsg" & Pwd(2)) = arrTmp:
		ReDim arrTmp(60, 2): arrTmp(0, 0) = "": Application("strUsr" & Pwd(2)) = arrTmp:
		ReDim arrTmp(1): arrTmp(0) = "0": Application("strApp" & Pwd(2)) = arrTmp:
		ReDim colTmp(5): colTmp(0) = "#191970": colTmp(1) = "#00008B": 
		colTmp(2) = "#5C4033": colTmp(3) = "#8B0000": colTmp(4) = "#2F4F2F":
		colTmp(5) = "#871F78":
		ReDim arrTmp(5, 10):	
			For intNr1 = 0 To 5:
				arrTmp(intNr1, 1) = intNr1 & ". Space":
				arrTmp(intNr1, 0) = Now(): arrTmp(intNr1, 2) = Now():
				arrTmp(intNr1, 3) = "0": arrTmp(intNr1, 4) = "0":
				arrTmp(intNr1, 8) = Now(): arrTmp(intNr1, 10) = "opn":
				arrTmp(intNr1, 9) = colTmp(intNr1):
			Next:
		Application("strUpd" & Pwd(2)) = arrTmp:
	Application.Unlock:
End Sub:
Sub SubAppRec():
	Dim arrTmp():
    	ReDim arrTmp(180, 2): arrTmp(0, 0) = "": strMsg = arrTmp:
		ReDim arrTmp(60, 2): arrTmp(0, 0) = "": strUsr = arrTmp:
		ReDim arrTmp(5, 10): arrTmp(0, 0) = "":	strUpd = arrTmp:
		ReDim arrTmp(11): arrTmp(0) = "": strSes = arrTmp:
		ReDim arrTmp(1): arrTmp(0) = "": strApp = arrTmp:
End Sub:
Sub SubUsrTimeout():
	Dim intNr3, intNr4, intDif:
		Application.Lock:
			strUsr = Application("strUsr" & Pwd(2)):
				For intNr3 = 59 To 0 Step - 1:
					If IsDate(strUsr(intNr3, 1)) Then		
						intDif = DateDiff("n", strUsr(intNr3, 1), Now()):
						If intDif > 5 Then	
							For intNr4 = intNr3 To 59:
								'If Len(strUsr(intNr4, 0)) = 0 Then Exit For: End If:
								strUsr(intNr4, 0) = strUsr(intNr4 + 1, 0):
								strUsr(intNr4, 1) = strUsr(intNr4 + 1, 1):
								strUsr(intNr4, 2) = strUsr(intNr4 + 1, 2):
							Next:
						End If:
					End If:
				Next:
			Application("strUsr" & Pwd(2)) = strUsr:
		Application.Unlock:
End Sub:
Sub SubSessCnt():
	Dim strSId:
	strSId = Trim(CStr(Session.SessionID)):
	If strSes(7) <> strSId Then
		strSes(7) = strSId:
		Application.Lock:
            strApp = Application("strApp" & Pwd(2)):
				If Not IsNumeric(strApp(0)) Or strApp(0) > "99998" Then strApp(0) = "0": End If:
				strApp(0) = CStr(CLng(strApp(0)) + 1): strApp(1) = Now():
			Application("strApp" & Pwd(2)) = strApp:
		Application.Unlock:
    End If:
End Sub:
Sub SubMsgSet():
	Dim intNr1, intNr2, intCnt:
		intCnt = 0:
		Application.Lock:			
			strMsg = Application("strMsg" & Pwd(2)):
				For intNr1 = 179 To 0 Step -1:
					If strMsg(intNr1, 2) = strSes(1) Then intCnt = intCnt + 1: End If:
					If intCnt > 29 Then
						For intNr2 = intNr1 To 179:
							If Len(strMsg(intNr2, 1)) = 0 Then Exit For: End If:
							strMsg(intNr2, 0) = strMsg(intNr2 + 1, 0):
							strMsg(intNr2, 1) = strMsg(intNr2 + 1, 1):
							strMsg(intNr2, 2) = strMsg(intNr2 + 1, 2):
						Next:
						intCnt = 29:
					End If:
				Next:
				For intNr1 = 0 To 179 Step 1:
					If Len(strMsg(intNr1, 1)) = 0 Then Exit For: End If:
				Next:
        		strMsg(intNr1, 0) = strSes(0):
				strMsg(intNr1, 1) = strSes(3):
				strMsg(intNr1, 2) = strSes(1):
			Application("strMsg" & Pwd(2)) = strMsg:
		Application.Unlock:
End Sub:
Sub SubUsrOut(strUsP):
	Dim intNr1, intNr2, intNr3:
		Application.Lock:
			strUsr = Application("strUsr" & Pwd(2)):
				For intNr1 =  59 To 0 Step -1:
					If strUsr(intNr1, 0) = strUsP Then
						For intNr2 = intNr1 To 59 Step 1:
							'If Len(strUsr(intNr2, 0)) = 0 Then Exit For: End If:
							strUsr(intNr2, 0) = strUsr(intNr2 + 1, 0):
							strUsr(intNr2, 1) = strUsr(intNr2 + 1, 1):
							strUsr(intNr2, 2) = strUsr(intNr2 + 1, 2):					
						Next:
						Exit For:
					End If:
				Next:	
			Application("strUsr" & Pwd(2)) = strUsr:
		Application.Unlock:
End Sub:
Function FktLoginRom(intTyp1, strRom2):
	Dim intNr1, intNr2:
		intNr2 = 0:
		Application.Lock:
			strUpd = Application("strUpd" & Pwd(2)):
			If strUpd(CInt(strRom2), 10) = "opn" Or intTyp1 = 1 Then
				strUsr = Application("strUsr" & Pwd(2)):
				For intNr1 = 0 To 59 Step 1:
					'If Len(strUsr(intNr1, 0)) = 0 Then Exit For: End If:
					Select Case intTyp1:
						Case 0: If strUsr(intNr1, 2) = strRom2 Then intNr2 = intNr2 + 1: End If:
						Case 1: If strUsr(intNr1, 0) = strSes(0) Then intNr2 = intNr2 + 1: End If:
						Case 2: If Len(strUsr(intNr1, 0)) > 0 Then intNr2 = intNr2 + 1: End If:
					End Select:
				Next:
			Else:
				intNr2 = 10:
			End If:
		Application.Unlock:
		FktLoginRom = intNr2:
End Function:
Sub SubSetUpd(intDat1, intDat2, intCnt1):
	Dim strDat1, intDay, varDat, strDay:
	strDat1 = Now(): strSes(8) = strDat1:
	Application.Lock:
		strUpd = Application("strUpd" & Pwd(2)):
			If intDat1 > 0 Then			
				If intDat1 = 1 Or intDat1 = 3 Then	
					strUpd(CInt(strSes(1)), 0) = strDat1: strSes(2) = strDat1:
					If intCnt1 = 1 Then strUpd(CInt(strSes(1)), 3) = CStr(CLng(strUpd(CInt(strSes(1)), 3)) + 1): End If:
				End If:
				If intDat1 = 2 Or intDat1 = 3 Then
					strUpd(CInt(strSes(1)), 2) = strDat1: strSes(6) = strDat1:
					If intCnt1 = 1 Then strUpd(CInt(strSes(1)), 4) = CStr(CLng(strUpd(CInt(strSes(1)), 4)) + 1): End If:
				End If:
			End If:
			If intDat2 = 1 Then
				intDay = WeekDay(Now()):
				Select Case intDay:
					Case 1:	strDay = "Sunday": Case 2: strDay = "Monday": Case 3: strDay = "Tuesday":
					Case 4:	strDay = "Wednesday": Case 5: strDay = "Thursday": 
					Case 6: strDay = "Friday": Case 7: strDay = "Saturday":
				End Select:
				strUpd(CInt(strSes(1)),7) = strDay:
				varDat = Date():
				strUpd(CInt(strSes(1)),5) = Right("0" & Day(varDat), 2) & "." & Right("0" & Month(varDat), 2) & "." & Right(Year(varDat), 2):
				varDat = Time():
				strUpd(CInt(strSes(1)),6) = Right("0" & Hour(varDat), 2) & ":" & Right("0" & Minute(varDat), 2) & ":" & Right("0" & Second(varDat), 2):
			End If:
		Application("strUpd" & Pwd(2)) = strUpd:
	Application.Unlock:
End Sub:
Sub SubUpdChgDat():
	Dim strDat1, intInf6, intInf8, intMsg2, intCmd11:
		strDat1 = Now(): intCmd11 = 0: strUpd = Application("strUpd" & Pwd(2)):		
		intInf8 = DateDiff("s", strSes(8), strDat1):
		intInf6 = DateDiff("s", strSes(6), strUpd(CInt(strSes(1)), 2)):
		intMsg2 = DateDiff("s", strSes(2), strUpd(CInt(strSes(1)), 0)):
		intCmd11 = DateDiff("s", strSes(11), strUpd(CInt(strSes(1)), 8)):
		If intInf8 > 90 Or intInf6 > 1 Or intMsg2 > 1 Or intCmd11 > 1 Then
			If (intInf8 > 90) Or (intInf6 > 1 And intMsg2 > 1) Then
				strSes(6) = strUpd(CInt(strSes(1)), 2): strSes(2) = strUpd(CInt(strSes(1)), 0):
				strSes(9) = "Txt": If intInf6 > 1 And intMsg2 > 1 Then strSes(10) = "ton": End If:
			ElseIf intInf6 > 1 Or intMsg2 > 1 Then			
				If intInf6 > 1 Then strSes(6) = strUpd(CInt(strSes(1)), 2): strSes(9) = "Inf": strSes(10) = "rom": End If:
				If intMsg2 > 1 Then strSes(2) = strUpd(CInt(strSes(1)), 0): strSes(9) = "Msg": strSes(10) = "ins": End If:
			End If:
            If intCmd11 > 1 Then strSes(11) = strUpd(CInt(strSes(1)), 8): strSes(9) = strSes(9) & "Lck": strSes(10) = strUpd(CInt(strSes(1)), 10): End If:
			If Len(strSes(9)) > 3 Then	
				If strSes(9) = "TxtLck" Then strSes(9) = "Del": End If:
				If strSes(9) = "InfLck" Then strSes(9) = "Out": End If:
				If strSes(9) = "MsgLck" Then strSes(9) = "Upl": End If:
				strSes(10) = "ton":				
			End If:
			If intInf8 > 90  Or intInf6 > 1 Then Call SubLckTout(strSes(1)): Call SubUsrTimeout: End If:
			strSes(8) = strDat1:  
		End If:
End Sub:
Function FktRplStr(strIn,strSrc1,strRpl1,intCMod):
	Dim strTxt1, intPnt1:
	If IsNull(strIn) Then
    	FktRplStr = Null:
  	Else:
    	strTxt1 = strIn:
    	intPnt1 = InStr(1, strTxt1, strSrc1, intCMod):
    	Do While intPnt1 > 0:
      		strTxt1 = Left(strTxt1, intPnt1 - 1) & strRpl1 & Mid(strTxt1, intPnt1 + Len(strSrc1)):
      		intPnt1 = InStr(intPnt1 + Len(strRpl1), strTxt1, strSrc1, intCMod):
    	Loop:
    	FktRplStr = strTxt1:
  	End If:
End Function:
Sub SubEnt():
	Dim intNr1, intNr2, intNr3, bolFkt1:
		If Not FktSessOpen() Then
			strSes(0) = FktRplStr(Trim(Request.Querystring("fldUsr")),"<",">",0):			
			If Len(strSes(0)) > 0 And InStr(strSes(0), "!>") = 0 Then
				If Right(LCase(strSes(0)), Len(Pwd(0))) = Pwd(0) Then
					strSes(0) = Trim(Left(strSes(0), Len(strSes(0)) - Len(Pwd(0)))): 
					strSes(4) = "God": If Len(strSes(0)) = 0 Then Call SubRes(1): End If:				
				End If:
				If Right(LCase(strSes(0)), Len(Pwd(1))) = Pwd(1) Then
					strSes(0) = Trim(Left(strSes(0), Len(strSes(0)) - Len(Pwd(1)))): strSes(4) = "Zero":
				End If:				
				If Len(strSes(0)) < 11 And Len(strSes(0)) > 0 Then
					If strSes(0) = "User" And strSes(4) = "God" Then Call SubFilUsr: End If:
					Call SubUsrTimeout:										
					If FktLoginRom(1, strSes(1)) = 0 Then
                        bolFkt1 = False:
						If Len(strSes(4)) > 2 Then intNr3 = 0 Else intNr3 = 1: End If:
						For intNr2 = intNr3 To 5:
							Call SubLckTout(CStr(intNr2)):
							intNr1 = FktLoginRom(0, CStr(intNr2)): 
							If intNr1 < 10 Then bolFkt1 = True: Exit For: End If:
						Next:
						If bolFkt1 Then
							strSes(1) = CStr(intNr2): strSes(10) = "ent":
							strSes(5) = "!> now in Space " & strSes(1) & " " & strSes(0):
							intNr1 = FktLoginRom(2, strSes(1)):
							Application.Lock:
								strUsr = Application("strUsr" & Pwd(2)):							
									strUsr(intNr1, 0) = strSes(0):
									strUsr(intNr1, 1) = Now():
									strUsr(intNr1, 2) = strSes(1):
								Application("strUsr" & Pwd(2)) = strUsr:
							Application.Unlock:
							Call SubSetUpd(2, 1, 1):							
						Else:
							strSes(1) = "1": strSes(0) = "": strSes(4) = "": 
							strSes(10) = "hlp": strSes(5) = "!> to a later":
						End If:
					Else:
						strSes(0) = "": strSes(4) = "":	strSes(5) = "!> Name taken": strSes(10) = "hlp":								
					End If:			
				Else:
					strSes(0) = "": strSes(4) = "": strSes(5) = "!> to 10 Char.": strSes(10) = "hlp":
				End If:
			Else:
				strSes(0) = "": strSes(5) = "!> your Name ?": strSes(10) = "hlp": 
			End If:
		Else: