| menu |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
| |
| |
ASP ChatNow - ChatRoom Enter |
|
| |
|
<%
Dim strBanFile
Dim saryBanList
strBanFile = Server.MapPath("ban.txt")
Function CheckIfBanned(strIP)
Dim intArrayLoop
If IsArray(Application("BanList")) = False Then
saryBanList = GetBanList()
Else
saryBanList = Application("BanList")
End If
CheckIfBanned = False
For intArrayLoop = 0 TO UBound(saryBanList)
If strIP = saryBanList(intArrayLoop) Then
CheckIfBanned = True
Exit For
End if
Next
End Function
Function BanUser(strIP)
Dim fso
Dim stream
Dim strBanList
Set fso = Server.CreateObject("Scripting.FileSystemObject")
Set stream = Nothing
'Save the text file
Set stream = fso.OpenTextFile(strBanFile, 2)
stream.WriteLine(strIP)
stream.Close
Set stream = Nothing
Set fso = Nothing
'Update the ban list
Call GetBanList()
End Function
Function UnBanUser(strIP)
Dim fso
Dim stream
Dim strBanList
Set fso = Server.CreateObject("Scripting.FileSystemObject")
'Open the file to see if ip is in it
Set stream = fso.OpenTextFile(strBanFile, 1, True)
strBanList = stream.ReadAll()
'If IP not found return false
If Instr(strBanList, strIP) = 0 Then
UnBanUser = False
'If IP found then remove it
Else
UnBanUser = True
strBanList = Replace(strBanList, strIP & vbCrLf, "")
End If
stream.Close
Set stream = Nothing
'Save the text file
Set stream = fso.OpenTextFile(strBanFile, 2)
stream.Write(strBanList)
stream.Close
Set stream = Nothing
Set fso = Nothing
'Update the ban list
Call GetBanList()
End Function
Function GetBanList()
Dim fso
Dim stream
Dim strBanList
strBanList = ""
Set fso = Server.CreateObject("Scripting.FileSystemObject")
'Open the file to see if ip is in it
Set stream = fso.OpenTextFile(strBanFile, 1, True)
If NOT stream.AtEndOfStream Then strBanList = stream.ReadAll()
stream.Close
Set stream = Nothing
Set fso = Nothing
If strBanList = "" Then
saryBanList = Array(0)
Else
saryBanList = Split(strBanList, vbCrLf)
End If
Application.Lock
Application("BanList") = saryBanList
Application.Unlock
GetBanList = saryBanList
End Function
%>
%
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
Application(ApplicationMsg) = saryMessages
Application.UnLock
End If
lastMessageID = saryMessages(5, UBound(saryMessages, 2))
End Function
Function PostMessage(strUsername, strMessage, intType)
Application.Lock
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
ReDim Preserve saryMessages(5, intTempSize)
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
|
|
|
|
|
|
|
|
|
|
|
|
|
