<%@ LANGUAGE="VBSCRIPT" %> <% Const AdminPassword = "pass1234" '********************************************************** '********************************************************** '********************************************************** '********************************************************** ' DONT EDIT BELOW UNLESS YOU KNOW WHAT YOU ARE DOING '********************************************************** '********************************************************** Const ApplicationMsg = "ChatRoomMsg" Function lastMessageID() Dim saryMessages 'Get the array If IsArray(Application(ApplicationMsg)) Then saryMessages = Application(ApplicationMsg) Else ReDim saryMessages(6, 0) Application.Lock ' OK (rbd) Application(ApplicationMsg) = saryMessages Application.UnLock End If lastMessageID = saryMessages(5, UBound(saryMessages, 2)) End Function Function PostMessage(strUsername, strMessage, intType) Application.Lock ' OK (rbd) Dim saryMessages Dim saryTempArray Dim intArrayPass 'Get the Array If IsArray(Application(ApplicationMsg)) Then saryMessages = Application(ApplicationMsg) Else ReDim saryMessages(5, 0) Application(ApplicationMsg) = saryMessages End If Dim strColor Dim strFormat Dim intLastMessageID 'Double up slahes so it pashes through the javascript and displays strMessage = Replace(strMessage, "\", "\\") 'Remove HTML if any strMessage = removeAllTags(strMessage) 'If a link, format it strMessage = CheckForLink(strMessage) 'format the message strMessage = FormatMessage(strMessage) If strMessage <> "" Then 'Array Legend '0 = Author '1 = Message '2 = Date '3 = Type '4 = User ID, 0 = All '5 = Message ID Dim intTempSize intTempSize = UBound(saryMessages, 2) If intTempSize = 0 Then intLastMessageID = 0 Else intLastMessageID = Clng(saryMessages(5, intTempSize)) End If intTempSize = intTempSize + 1 If intTempSize = 1 Then ReDim saryMessages(5, intTempSize) ' Avoid initial array bounds exception Else ReDim Preserve saryMessages(5, intTempSize) End If saryMessages(0, intTempSize) = strUsername saryMessages(1, intTempSize) = strMessage saryMessages(2, intTempSize) = CDbl(Now()) saryMessages(3, intTempSize) = intType saryMessages(4, intTempSize) = 0 saryMessages(5, intTempSize) = (intLastMessageID + 1) Application(ApplicationMsg) = saryMessages '****************************************** '*** Trim array if over 40 messages *** '****************************************** If UBound(saryMessages, 2) => 20 Then 'put array in a temp array so we can update it ReDim saryTempArray(5, 0) 'cut the array in half For intArrayPass = 10 TO UBound(saryMessages, 2) ReDim Preserve saryTempArray(5, UBound(saryTempArray, 2) + 1) saryTempArray(0, UBound(saryTempArray, 2)) = saryMessages(0, intArrayPass) saryTempArray(1, UBound(saryTempArray, 2)) = saryMessages(1, intArrayPass) saryTempArray(2, UBound(saryTempArray, 2)) = saryMessages(2, intArrayPass) saryTempArray(3, UBound(saryTempArray, 2)) = saryMessages(3, intArrayPass) saryTempArray(4, UBound(saryTempArray, 2)) = saryMessages(4, intArrayPass) saryTempArray(5, UBound(saryTempArray, 2)) = saryMessages(5, intArrayPass) Next 'Transfer array to update saryMessages = saryTempArray Application(ApplicationMsg) = saryMessages End If End If Application.UnLock End Function Function FormatMessage(strMessage) 'Smilies strMessage = Replace(strMessage, ":huh?", "") strMessage = Replace(strMessage, ":s", "") strMessage = Replace(strMessage, ":P", "") strMessage = Replace(strMessage, "}:)", "") strMessage = Replace(strMessage, ":D", "") strMessage = Replace(strMessage, "}:|", "") strMessage = Replace(strMessage, ":)", "") strMessage = Replace(strMessage, ":oops", "") strMessage = Replace(strMessage, ";)", "") strMessage = Replace(strMessage, ":pff", "") strMessage = Replace(strMessage, ":\\", "") strMessage = Replace(strMessage, ":0", "") strMessage = Replace(strMessage, "[B]", "", 1, -1, 1) strMessage = Replace(strMessage, "[/B]", "", 1, -1, 1) strMessage = Replace(strMessage, "[I]", "", 1, -1, 1) strMessage = Replace(strMessage, "[/I]", "", 1, -1, 1) strMessage = Replace(strMessage, "[U]", "", 1, -1, 1) strMessage = Replace(strMessage, "[/U]", "", 1, -1, 1) 'Loop through the message till all font colour codes are turned into fonts colours Do While InStr(1, strMessage, "[color=", 1) > 0 AND InStr(1, strMessage, "[/color]", 1) > 0 Dim lngStartPos Dim lngEndPos Dim strMessageLink Dim strTempMessage 'Find the start position in the message of the [COLOR= code lngStartPos = InStr(1, strMessage, "[color=", 1) 'Find the position in the message for the [/COLOR] closing code lngEndPos = InStr(lngStartPos, strMessage, "[/color]", 1) + 8 'Make sure the end position is not in error If lngEndPos < lngStartPos Then lngEndPos = lngStartPos + 9 'Read in the code to be converted into a font colour from the message strMessageLink = Trim(Mid(strMessage, lngStartPos, (lngEndPos - lngStartPos))) 'Place the message colour into the tempoary message variable strTempMessage = strMessageLink 'Format the link into an font colour HTML tag strTempMessage = Replace(strTempMessage, "[color=", "", 1, -1, 1) strTempMessage = Replace(strTempMessage, "]", ">", 1, -1, 1) Else strTempMessage = strTempMessage & ">" End If 'Place the new fromatted colour HTML tag into the message string body strMessage = Replace(strMessage, strMessageLink, strTempMessage, 1, -1, 1) Loop FormatMessage = strMessage End Function '********************************************* '*** Check and Format Links ***** '********************************************* Function CheckForLink(strMessage) Dim regEx Set regEx = New RegExp regEx.IgnoreCase = True regEx.Global = True 'regEx.Pattern = "((http|ftp)://\S+)" 'http:// 'strMessage = regEx.Replace(strMessage, "$1") 'regEx.Pattern = "([^/])(www\.\S+)" 'www.xxx.xxx 'strMessage = regEx.Replace(strMessage, "$1$2") 'regEx.Pattern = "(\S+@\S+\.\S+)" ' match email addresses 'strMessage = regEx.Replace(strMessage, "$1") ' Make replacement. CheckForLink=strMessage End Function '********************************************* '*** Strip all tags ***** '********************************************* 'Remove all tags for text only display (mainly for subject lines) Private Function removeAllTags(ByVal strInputEntry) 'Remove all HTML scripting tags etc. for plain text output strInputEntry = Replace(strInputEntry, "&", "&", 1, -1, 1) strInputEntry = Replace(strInputEntry, "<", "<", 1, -1, 1) strInputEntry = Replace(strInputEntry, ">", ">", 1, -1, 1) strInputEntry = Replace(strInputEntry, "'", "’", 1, -1, 1) strInputEntry = Replace(strInputEntry, """", """, 1, -1, 1) 'Return removeAllTags = strInputEntry End Function Function CleanMessage(strMessage) strMessage = Replace(strMessage, "[B]", "", 1, -1, 1) strMessage = Replace(strMessage, "[/B]", "", 1, -1, 1) strMessage = Replace(strMessage, "[I]", "", 1, -1, 1) strMessage = Replace(strMessage, "[/I]", "", 1, -1, 1) strMessage = Replace(strMessage, "[U]", "", 1, -1, 1) strMessage = Replace(strMessage, "[/U]", "", 1, -1, 1) Dim lngMessagePosition Dim intHTMLTagLength Dim strHTMLMessage Dim strTempMessageText strTempMessageText = strMessage For lngMessagePosition = 1 to CLng(Len(strMessage)) 'If this is the end of the message then save some process time and jump out the loop If Mid(strMessage, lngMessagePosition, 1) = "" Then Exit For 'If an BBCode tag is found then jump to the end so we can strip it If Mid(strMessage, lngMessagePosition, 6) = "[color" OR Mid(strMessage, lngMessagePosition, 7) = "[/color" Then 'Get the length of the BBCode tag intHTMLTagLength = (InStr(lngMessagePosition, strMessage, "]", 1) - lngMessagePosition) 'If the end of the BBCode string is in error then set it to the number of characters being passed If intHTMLTagLength < 0 Then intHTMLTagLength = CLng(Len(strTempMessageText)) 'Place the BBCode tag back into the temporary message store strHTMLMessage = Mid(strMessage, lngMessagePosition, intHTMLTagLength + 1) 'Strip the BBCode strTempMessageText = Replace(strTempMessageText, strHTMLMessage, " ", 1, -1, 0) End If Next CleanMessage = strTempMessageText End Function %> <% Const ApplicationUsers = "ChatUsers" Dim saryActiveUsers Dim strUsername Dim blnIsArray Dim strAdminCommand 'Get the username strUsername = Session("Username") Function RemoveUnActive() 'Iterate through the array to remove old entires For intArrayPass = 1 To UBound(saryActiveUsers, 2) 'Check the last checked date. If user wasnt updated 20 seconds ago then they must be gone If CDate(saryActiveUsers(5, intArrayPass)) < CDate(CDbl(DateAdd("s", -20, Now()))) Then 'Post message that the user has left Call PostMessage("", saryActiveUsers(1, intArrayPass) & " has left the room.", 1) 'Swap this array postion with the last in the array saryActiveUsers(0, intArrayPass) = saryActiveUsers(0, UBound(saryActiveUsers, 2)) saryActiveUsers(1, intArrayPass) = saryActiveUsers(1, UBound(saryActiveUsers, 2)) saryActiveUsers(2, intArrayPass) = saryActiveUsers(2, UBound(saryActiveUsers, 2)) saryActiveUsers(3, intArrayPass) = saryActiveUsers(3, UBound(saryActiveUsers, 2)) saryActiveUsers(4, intArrayPass) = saryActiveUsers(4, UBound(saryActiveUsers, 2)) saryActiveUsers(5, intArrayPass) = saryActiveUsers(5, UBound(saryActiveUsers, 2)) saryActiveUsers(6, intArrayPass) = saryActiveUsers(6, UBound(saryActiveUsers, 2)) 'Remove the last array position as it is no-longer needed ReDim Preserve saryActiveUsers(6, UBound(saryActiveUsers, 2) - 1) 'Exit for loop to prevent errors Exit For End If Next End Function Function getIP() getIP = Request.ServerVariables("REMOTE_ADDR") End Function Function Reset() Dim saryMessages Dim saryActiveUsers ReDim saryMessages(5, 0) ReDim saryActiveUsers(6, 0) Application.Lock ' OK (rbd) Application(ApplicationUsers) = saryActiveUsers Application(ApplicationMsg) = saryMessages Application.UnLock End Function Function LogOut() Dim intArrayPass '' Don't abandon ACP observing session! ''Session.Abandon saryActiveUsers(5, intArrayPos) = CDbl(DateAdd("s", -30, Now())) Call RemoveUnActive() '****************************************** '*** Update application level array *** '****************************************** Application.Lock 'Lock the application ' OK (rbd) Application(ApplicationUsers) = saryActiveUsers 'Update the applicaiton Application.UnLock 'Unlock the application End Function Function CheckUsername(strUsername) CheckUsername = False Dim intArrayPass Dim saryActiveUsers 'Get the array If IsArray(Application(ApplicationUsers)) Then saryActiveUsers = Application(ApplicationUsers) Else ReDim saryActiveUsers(6, 0) End If For intArrayPass = 1 TO UBound(saryActiveUsers, 2) If saryActiveUsers(1, intArrayPass) = strUsername AND saryActiveUsers(3, intArrayPass) <> getIP() Then CheckUsername = True Exit For End If Next Application.UnLock End Function %> <% Application.Lock ' ***QUESTIONABLE*** (rbd) Dim saryMessages Dim saryTempArray Dim intArrayPass Dim blnAdmin Dim blnFormatText strUsername = Session("Username") blnAdmin = CBool(Session("Admin")) blnFormatText = CBool(Session("FormatText")) If strUsername = "" Then Response.End ' Should never happen 'Get the array If IsArray(Application(ApplicationMsg)) Then saryMessages = Application(ApplicationMsg) Else ReDim saryMessages(5, 0) Application(ApplicationMsg) = saryMessages End If Dim strMessage Dim strColor Dim strFormat Dim intLastMessageID Dim intType Dim strCommand Dim blnPrivateMessage Dim saryUserMsgTo blnPrivateMessage = False intType = 0 saryUserMsgTo = 0 strMessage = Request.Form("message") strColor = Request.Form("color") strFormat = Request.Form("format") If Mid(strMessage, 1, 1) = "/" Then If Mid(strMessage, 1, 10) = "/password " Then strCommand = Trim(Mid(CleanMessage(strMessage), 10, Len(CleanMessage(strMessage)))) If strCommand = AdminPassword Then Session("Admin") = True strMessage = "Logged in as admin." Else strMessage = "Failed to login. Password given: " & strCommand End If saryUserMsgTo = Array(strUsername) intType = 1 ElseIf Mid(strMessage, 1, 7) = "/logout" Then Session("Admin") = False If blnAdmin Then strMessage = "Logged out." Else strMessage = "You where never logged in." End If saryUserMsgTo = Array(strUsername) intType = 1 ElseIf Mid(strMessage, 1, 7) = "/alert " Then strCommand = Trim(Mid(strMessage, 7, Len(strMessage))) If blnAdmin Then strMessage = "alert('" & strCommand & "');" saryUserMsgTo = 0 intType = 2 Else strMessage = "You do not have permission to use this command." saryUserMsgTo = Array(strUsername) intType = 1 End If ElseIf Mid(strMessage, 1, 8) = "/kickall" Then If blnAdmin Then strMessage = "alert('You have been kicked!');parent.location=""default.asp"";" saryUserMsgTo = 0 intType = 2 Else strMessage = "You do not have permission to use this command." saryUserMsgTo = Array(strUsername) intType = 1 End If ElseIf Mid(strMessage, 1, 6) = "/kick " Then strCommand = Trim(Mid(strMessage, 6, Len(strMessage))) If blnAdmin Then If KickUser(strCommand) Then strMessage = strCommand & " has been kicked." Else strMessage = strCommand & " username not found." End If saryUserMsgTo = Array(strUsername) intType = 1 Else strMessage = "You do not have permission to use this command." saryUserMsgTo = Array(strUsername) intType = 1 End If ElseIf Mid(strMessage, 1, 7) = "/format" Then If blnFormatText Then Session("FormatText") = False strMessage = "Text formating turned off." Else Session("FormatText") = True strMessage = "Text formating turned on." End If saryUserMsgTo = Array(strUsername) intType = 1 ElseIf Mid(strMessage, 1, 9) = "/commands" Then strMessage = "
" If User.IsAdministrator Then strMessage = strMessage & _ "" & _ "" & _ "" & _ "" & _ "" End If strMessage = strMessage & _ "" & _ "" & _ "" & _ "" & _ "
Admin Commands:
Login:/password [Password]
Logout:/logout
Kick:/kick [Username]
Alert:/alert [Message]

User Commands:
Private Message:/[Username] [Message]
Text Formating on/off:/format

Smilies:
" & _ "" & _ "" & _ "" & _ "" & _ "" & _ "" & _ "" & _ "" & _ "" & _ "" & _ "" & _ "" & _ "
:huh?:s:P}:)
:D}:|:):oops
;):pff:/:0

" saryUserMsgTo = Array(strUsername) intType = 1 ElseIf Mid(strMessage, 1, 7) = "/color " Then strCommand = Replace(strMessage, "/color ", "") Response.Redirect("message.asp?Color=" & strCommand & "&Format=" & strFormat) Else 'Dim saryActiveUsers 'Dim blnPrivateMessage blnPrivateMessage = False 'Get the array If IsArray(Application(ApplicationUsers)) Then saryActiveUsers = Application(ApplicationUsers) For intArrayPass = 1 TO UBound(saryActiveUsers, 2) If Instr(strMessage, "/" & saryActiveUsers(1, intArrayPass) & " ") <> 0 Then strMessage = Replace(strMessage, "/" & saryActiveUsers(1, intArrayPass) & " ", "") saryUserMsgTo = Array(saryActiveUsers(1, intArrayPass), strUsername) intType = 3 blnPrivateMessage = True Exit For End If Next End If If blnPrivateMessage = False Then strMessage = "You typed a unknown command. Type /commands for help." saryUserMsgTo = Array(strUsername) intType = 1 End If End If Else If strColor <> "" Then strMessage = "[color=" & strColor & "]" & strMessage & "[/color]" If strFormat <> "" Then strMessage = "[" & strFormat & "]" & strMessage & "[/" & strFormat & "]" End If strMessage = Trim(strMessage) If strMessage <> "" Then 'Array Legend '0 = Author '1 = Message '2 = Date '3 = Type '4 = User ID, 0 = All '5 = Message ID Dim intTempSize intTempSize = UBound(saryMessages, 2) If intTempSize = 0 Then intLastMessageID = 0 Else intLastMessageID = Clng(saryMessages(5, intTempSize)) End If intTempSize = intTempSize + 1 Response.Write(vbCrLf & intTempSize) If intTempSize = 1 Then ReDim saryMessages(5, intTempSize) ' Avoid initial array bounds exception Else ReDim Preserve saryMessages(5, intTempSize) End If saryMessages(0, intTempSize) = strUsername saryMessages(1, intTempSize) = strMessage saryMessages(2, intTempSize) = CDbl(Now()) saryMessages(3, intTempSize) = intType saryMessages(4, intTempSize) = saryUserMsgTo saryMessages(5, intTempSize) = (intLastMessageID + 1) Application(ApplicationMsg) = saryMessages '****************************************** '*** Trim array if over 40 messages *** '****************************************** If UBound(saryMessages, 2) => 20 Then 'put array in a temp array so we can update it ReDim saryTempArray(5, 0) 'cut the array in half For intArrayPass = 10 TO UBound(saryMessages, 2) ReDim Preserve saryTempArray(5, UBound(saryTempArray, 2) + 1) saryTempArray(0, UBound(saryTempArray, 2)) = saryMessages(0, intArrayPass) saryTempArray(1, UBound(saryTempArray, 2)) = saryMessages(1, intArrayPass) saryTempArray(2, UBound(saryTempArray, 2)) = saryMessages(2, intArrayPass) saryTempArray(3, UBound(saryTempArray, 2)) = saryMessages(3, intArrayPass) saryTempArray(4, UBound(saryTempArray, 2)) = saryMessages(4, intArrayPass) saryTempArray(5, UBound(saryTempArray, 2)) = saryMessages(5, intArrayPass) Next 'Transfer array to update saryMessages = saryTempArray Application(ApplicationMsg) = saryMessages End If End If Application.UnLock Response.Redirect("message.asp?Color=" & strColor & "&Format=" & strFormat) Function KickUser(strUsername) KickUser = False Dim intArrayPass Dim saryActiveUsers Application.Lock ' OK (rbd) 'Get the array If IsArray(Application(ApplicationUsers)) Then saryActiveUsers = Application(ApplicationUsers) Else ReDim saryActiveUsers(6, 0) End If For intArrayPass = 1 TO UBound(saryActiveUsers, 2) If saryActiveUsers(1, intArrayPass) = strUsername AND saryActiveUsers(3, intArrayPass) <> getIP() Then saryActiveUsers(6, intArrayPass) = "kick" KickUser = True Application(ApplicationUsers) = saryActiveUsers Exit For End If Next Application.UnLock End Function %>