<% '**************************************************************************************** '** Copyright Notice '** '** Web Wiz Guide - Web Wiz Forums '** '** Copyright 2001-2004 Bruce Corkhill All Rights Reserved. '** '** This program is free software; you can modify (at your own risk) any part of it '** under the terms of the License that accompanies this software and use it both '** privately and commercially. '** '** All copyright notices must remain in tacked in the scripts and the '** outputted HTML. '** '** You may use parts of this program in your own private work, but you may NOT '** redistribute, repackage, or sell the whole or any part of this program even '** if it is modified or reverse engineered in whole or in part without express '** permission from the author. '** '** You may not pass the whole or any part of this application off as your own work. '** '** All links to Web Wiz Guide and powered by logo's must remain unchanged and in place '** and must remain visible when the pages are viewed unless permission is first granted '** by the copyright holder. '** '** This program is distributed in the hope that it will be useful, '** but WITHOUT ANY WARRANTY; without even the implied warranty of '** MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE OR ANY OTHER '** WARRANTIES WHETHER EXPRESSED OR IMPLIED. '** '** You should have received a copy of the License along with this program; '** if not, write to:- Web Wiz Guide, PO Box 4982, Bournemouth, BH8 8XP, United Kingdom. '** '** '** No official support is available for this program but you may post support questions at: - '** http://www.webwizguide.info/forum '** '** Support questions are NOT answered by e-mail ever! '** '** For correspondence or non support questions contact: - '** info@webwizguide.info '** '** or at: - '** '** Web Wiz Guide, PO Box 4982, Bournemouth, BH8 8XP, United Kingdom '** '**************************************************************************************** '****************************************** '*** Create Usercode ***** '****************************************** Private Function userCode(ByVal strUsername) 'Randomise the system timer Randomize Timer 'Calculate a code for the user strUserCode = strUsername & hexValue(10) 'Make the usercode SQL safe strUserCode = formatSQLInput(strUserCode) 'Replace double quote with single in this intance strUserCode = Replace(strUserCode, "''", "'", 1, -1, 1) 'Return the function userCode = strUserCode End Function '****************************************** '*** Random Hex Generator **** '****************************************** Private Function hexValue(ByVal intHexLength) Dim intLoopCounter Dim strHexValue 'Randomise the system timer Randomize Timer() 'Generate a hex value For intLoopCounter = 1 to intHexLength 'Genreate a radom decimal value form 0 to 15 intHexLength = CInt(Rnd * 1000) Mod 16 'Turn the number into a hex value Select Case intHexLength Case 1 strHexValue = "1" Case 2 strHexValue = "2" Case 3 strHexValue = "3" Case 4 strHexValue = "4" Case 5 strHexValue = "5" Case 6 strHexValue = "6" Case 7 strHexValue = "7" Case 8 strHexValue = "8" Case 9 strHexValue = "9" Case 10 strHexValue = "A" Case 11 strHexValue = "B" Case 12 strHexValue = "C" Case 13 strHexValue = "D" Case 14 strHexValue = "E" Case 15 strHexValue = "F" Case Else strHexValue = "Z" End Select 'Place the hex value into the return string hexValue = hexValue & strHexValue Next End Function '******************************************** '*** Rich Text Compatible Browser type ***** '******************************************** Private Function RTEenabled() Dim strUserAgent 'Holds info on the users browser 'Get the users HTTP user agent (web browser) strUserAgent = Request.ServerVariables("HTTP_USER_AGENT") '************************************* '***** Windows Internet Explorer ***** '************************************* 'See if the user agent is IE on Winows and not Opera trying to look like IE If InStr(1, strUserAgent, "MSIE", 1) > 0 AND InStr(1, strUserAgent, "Win", 1) > 0 AND InStr(1, strUserAgent, "Opera", 1) = 0 Then 'Now we know this is Windows IE we need to see if the version number is 5 If Trim(Mid(strUserAgent, CInt(inStr(1, strUserAgent, "MSIE", 1)+5), 1)) = "5" Then RTEenabled = "winIE5" 'Now we know this is Windows IE we need to see if the version number is above 5 ElseIf CInt(Trim(Mid(strUserAgent, CInt(inStr(1, strUserAgent, "MSIE", 1)+5), 1))) => 6 Then RTEenabled = "winIE" 'Else the IE version is below 5 so return na Else RTEenabled = "false" End If '**************************** '***** Mozilla Firebird ***** '**************************** 'See if this is a version of Mozilla Firebird that supports Rich Text Editing under it's Midas API ElseIf inStr(1, strUserAgent, "Firebird", 1) Then 'Now we know this is Mozilla Firebird we need to see if the version 0.6.1 or above; relase date is above 2003/07/28 If CLng(Trim(Mid(strUserAgent, CInt(inStr(1, strUserAgent, "Gecko/", 1)+6), 8))) => 20030728 Then RTEenabled = "Gecko" 'Else the Mozilla Firebird version is below 1.5 so return false Else RTEenabled = "false" End If '************************************** '***** Mozilla Seamonkey/Netscape ***** '************************************** 'See if this is a version of Mozilla/Netscape that supports Rich Text Editing under it's Midas API ElseIf inStr(1, strUserAgent, "Gecko", 1) > 0 AND inStr(1, strUserAgent, "Firebird", 1) = 0 AND isNumeric(Trim(Mid(strUserAgent, CInt(inStr(1, strUserAgent, "Gecko/", 1)+6), 8))) Then 'Now we know this is Mozilla/Netscape we need to see if the version number is above 1.3 or above; relase date is above 2003/03/12 If CLng(Trim(Mid(strUserAgent, CInt(inStr(1, strUserAgent, "Gecko/", 1)+6), 8))) => 20030312 Then RTEenabled = "Gecko" 'Else the Mozilla version is below 1.3 or below 7.1 of Netscape so return false Else RTEenabled = "false" End If '*********************************** '***** Non RTE Enabled Browser ***** '*********************************** 'Else this is a browser that does not support Rich Text Editing Else 'RTEenabled - false RTEenabled = "false" End If End Function '****************************************** '*** Get Web Browser Details ***** '****************************************** Private Function BrowserType() Dim strUserAgent 'Holds info on the users browser and os Dim strBrowserUserType 'Holds the users browser type 'Get the users HTTP user agent (web browser) strUserAgent = Request.ServerVariables("HTTP_USER_AGENT") 'Get the uesrs web browser 'Opera If InStr(1, strUserAgent, "Opera 1", 1) > 0 Then strBrowserUserType = "Opera 1" ElseIf InStr(1, strUserAgent, "Opera 2", 1) > 0 Then strBrowserUserType = "Opera 2" ElseIf InStr(1, strUserAgent, "Opera 3", 1) > 0 Then strBrowserUserType = "Opera 3" ElseIf InStr(1, strUserAgent, "Opera 4", 1) > 0 Then strBrowserUserType = "Opera 4" ElseIf InStr(1, strUserAgent, "Opera 5", 1) > 0 Then strBrowserUserType = "Opera 5" ElseIf InStr(1, strUserAgent, "Opera 6", 1) > 0 Then strBrowserUserType = "Opera 6" ElseIf InStr(1, strUserAgent, "Opera 7", 1) > 0 Then strBrowserUserType = "Opera 7" ElseIf InStr(1, strUserAgent, "Opera 8", 1) > 0 Then strBrowserUserType = "Opera 8" ElseIf InStr(1, strUserAgent, "Opera", 1) > 0 Then strBrowserUserType = "Opera" 'AOL ElseIf inStr(1, strUserAgent, "AOL 3", 1) > 0 Then strBrowserUserType = "AOL 3" ElseIf inStr(1, strUserAgent, "AOL 4", 1) > 0 Then strBrowserUserType = "AOL 4" ElseIf inStr(1, strUserAgent, "AOL 5", 1) > 0 Then strBrowserUserType = "AOL 5" ElseIf inStr(1, strUserAgent, "AOL 6", 1) > 0 Then strBrowserUserType = "AOL 6" ElseIf inStr(1, strUserAgent, "AOL 7", 1) > 0 Then strBrowserUserType = "AOL 7" ElseIf inStr(1, strUserAgent, "AOL 8", 1) > 0 Then strBrowserUserType = "AOL 8" ElseIf inStr(1, strUserAgent, "AOL 9", 1) > 0 Then strBrowserUserType = "AOL 9" ElseIf inStr(1, strUserAgent, "AOL", 1) > 0 Then strBrowserUserType = "AOL" 'Konqueror ElseIf inStr(1, strUserAgent, "Konqueror", 1) > 0 Then strBrowserUserType = "Konqueror" 'EudoraWeb ElseIf inStr(1, strUserAgent, "EudoraWeb", 1) > 0 Then strBrowserUserType = "EudoraWeb" 'Dreamcast ElseIf inStr(1, strUserAgent, "Dreamcast", 1) > 0 Then strBrowserUserType = "Dreamcast" 'Safari ElseIf inStr(1, strUserAgent, "Safari", 1) > 0 Then strBrowserUserType = "Safari" 'Lynx ElseIf inStr(1, strUserAgent, "Lynx", 1) > 0 Then strBrowserUserType = "Lynx" 'ICE ElseIf inStr(1, strUserAgent, "ICE", 1) > 0 Then strBrowserUserType = "ICE" 'iCab ElseIf inStr(1, strUserAgent, "iCab", 1) > 0 Then strBrowserUserType = "iCab" 'HotJava ElseIf inStr(1, strUserAgent, "Sun", 1) > 0 AND inStr(1, strUserAgent, "Mozilla/3", 1) > 0 Then strBrowserUserType = "HotJava" 'Galeon ElseIf inStr(1, strUserAgent, "Galeon", 1) > 0 Then strBrowserUserType = "Galeon" 'Epiphany ElseIf inStr(1, strUserAgent, "Epiphany", 1) > 0 Then strBrowserUserType = "Epiphany" 'DocZilla ElseIf inStr(1, strUserAgent, "DocZilla", 1) > 0 Then strBrowserUserType = "DocZilla" 'Camino ElseIf inStr(1, strUserAgent, "Chimera", 1) > 0 OR inStr(1, strUserAgent, "Camino", 1) > 0 Then strBrowserUserType = "Camino" 'Dillo ElseIf inStr(1, strUserAgent, "Dillo", 1) > 0 Then strBrowserUserType = "Dillo" 'amaya ElseIf inStr(1, strUserAgent, "amaya", 1) > 0 Then strBrowserUserType = "Amaya" 'NetCaptor ElseIf inStr(1, strUserAgent, "NetCaptor", 1) > 0 Then strBrowserUserType = "NetCaptor" 'LookSmart search engine robot ElseIf inStr(1, strUserAgent, "ZyBorg", 1) > 0 Then strBrowserUserType = "LookSmart" 'Googlebot search engine robot ElseIf inStr(1, strUserAgent, "Googlebot", 1) > 0 Then strBrowserUserType = "Googlebot" 'MSN search engine robot ElseIf inStr(1, strUserAgent, "msnbot", 1) > 0 Then strBrowserUserType = "MSN" 'inktomi search engine robot ElseIf inStr(1, strUserAgent, "slurp", 1) > 0 Then strBrowserUserType = "Inktomi" 'AltaVista search engine robot ElseIf inStr(1, strUserAgent, "Scooter", 1) > 0 Then strBrowserUserType = "AltaVista" 'DMOZ search engine robot ElseIf inStr(1, strUserAgent, "Robozilla", 1) > 0 Then strBrowserUserType = "DMOZ" 'Ask Jeeves search engine robot ElseIf inStr(1, strUserAgent, "Ask Jeeves", 1) > 0 OR inStr(1, strUserAgent, "Ask+Jeeves", 1) > 0 Then strBrowserUserType = "Ask Jeeves" 'Lycos search engine robot ElseIf inStr(1, strUserAgent, "lycos", 1) > 0 Then strBrowserUserType = "Lycos" 'Excite search engine robot ElseIf inStr(1, strUserAgent, "ArchitextSpider", 1) > 0 Then strBrowserUserType = "Excite" 'Northernlight search engine robot ElseIf inStr(1, strUserAgent, "Gulliver", 1) > 0 Then strBrowserUserType = "Northernlight" 'AllTheWeb search engine robot ElseIf inStr(1, strUserAgent, "crawler@fast", 1) > 0 Then strBrowserUserType = "AllTheWeb" 'Turnitin search engine robot ElseIf inStr(1, strUserAgent, "TurnitinBot", 1) > 0 Then strBrowserUserType = "Turnitin" 'InternetSeer search engine robot ElseIf inStr(1, strUserAgent, "internetseer", 1) > 0 Then strBrowserUserType = "InternetSeer" 'NameProtect Inc. search engine robot ElseIf inStr(1, strUserAgent, "nameprotect", 1) > 0 Then strBrowserUserType = "NameProtect" 'PhpDig search engine robot ElseIf inStr(1, strUserAgent, "PhpDig", 1) > 0 Then strBrowserUserType = "PhpDig" 'Rambler search engine robot ElseIf inStr(1, strUserAgent, "StackRambler", 1) > 0 Then strBrowserUserType = "Rambler" 'UbiCrawler search engine robot ElseIf inStr(1, strUserAgent, "UbiCrawler", 1) > 0 Then strBrowserUserType = "UbiCrawler" 'entireweb search engine robot ElseIf inStr(1, strUserAgent, "Speedy+Spider", 1) > 0 Then strBrowserUserType = "entireweb" 'Alexa.com search engine robot ElseIf inStr(1, strUserAgent, "ia_archiver", 1) > 0 Then strBrowserUserType = "Alexa" 'Arianna/Libero search engine robot ElseIf inStr(1, strUserAgent, "arianna.libero.it", 1) > 0 Then strBrowserUserType = "Arianna/Libero" 'Internet Explorer ElseIf inStr(1, strUserAgent, "MSIE 7", 1) > 0 Then strBrowserUserType = "Microsoft IE 7" ElseIf inStr(1, strUserAgent, "MSIE 6", 1) > 0 Then strBrowserUserType = "Microsoft IE 6" ElseIf inStr(1, strUserAgent, "MSIE 5", 1) > 0 Then strBrowserUserType = "Microsoft IE 5" ElseIf inStr(1, strUserAgent, "MSIE 4", 1) > 0 Then strBrowserUserType = "Microsoft IE 4" ElseIf inStr(1, strUserAgent, "MSIE 3", 1) > 0 Then strBrowserUserType = "Microsoft IE 3" ElseIf inStr(1, strUserAgent, "MSIE 2", 1) > 0 Then strBrowserUserType = "Microsoft IE 2" ElseIf inStr(1, strUserAgent, "MSIE 1", 1) > 0 Then strBrowserUserType = "Microsoft IE 1" 'Pocket Internet Explorer ElseIf inStr(1, strUserAgent, "MSPIE 1", 1) > 0 Then strBrowserUserType = "Pocket IE 1" ElseIf inStr(1, strUserAgent, "MSPIE 1", 1) > 0 Then strBrowserUserType = "Pocket IE 2" 'Mozilla Firebird ElseIf inStr(1, strUserAgent, "Gecko", 1) > 0 AND inStr(1, strUserAgent, "Firebird", 1) > 0 Then strBrowserUserType = "Mozilla Firebird" 'Mozilla ElseIf inStr(1, strUserAgent, "Gecko", 1) > 0 AND inStr(1, strUserAgent, "rv:2", 1) > 0 AND inStr(1, strUserAgent, "Netscape", 1) = 0 Then strBrowserUserType = "Mozilla 2" ElseIf inStr(1, strUserAgent, "Gecko", 1) > 0 AND inStr(1, strUserAgent, "rv:1", 1) > 0 AND inStr(1, strUserAgent, "Netscape", 1) = 0 Then strBrowserUserType = "Mozilla 1" ElseIf inStr(1, strUserAgent, "Gecko", 1) > 0 AND inStr(1, strUserAgent, "rv:0", 1) > 0 AND inStr(1, strUserAgent, "Netscape", 1) = 0 Then strBrowserUserType = "Mozilla" 'Netscape ElseIf inStr(1, strUserAgent, "Netscape/8", 1) > 0 Then strBrowserUserType = "Netscape 8" ElseIf inStr(1, strUserAgent, "Netscape/7", 1) > 0 Then strBrowserUserType = "Netscape 7" ElseIf inStr(1, strUserAgent, "Netscape6", 1) > 0 Then strBrowserUserType = "Netscape 6" ElseIf inStr(1, strUserAgent, "Mozilla/4", 1) > 0 Then strBrowserUserType = "Netscape 4" ElseIf inStr(1, strUserAgent, "Mozilla/3", 1) > 0 Then strBrowserUserType = "Netscape 3" ElseIf inStr(1, strUserAgent, "Mozilla/2", 1) > 0 Then strBrowserUserType = "Netscape 2" ElseIf inStr(1, strUserAgent, "Mozilla/1", 1) > 0 Then strBrowserUserType = "Netscape 1" 'Else unknown or robot Else strBrowserUserType = "Unknown" End If 'Return function BrowserType = strBrowserUserType End Function '****************************************** '*** Get OS Type ***** '****************************************** Private Function OSType () Dim strUserAgent 'Holds info on the users browser and os Dim strOS 'Holds the users OS 'Get the users HTTP user agent (web browser) strUserAgent = Request.ServerVariables("HTTP_USER_AGENT") 'Get users OS 'Windows If inStr(1, strUserAgent, "Windows 2003", 1) > 0 Or inStr(1, strUserAgent, "NT 5.2", 1) > 0 Then strOS = "Windows 2003" ElseIf inStr(1, strUserAgent, "Windows XP", 1) > 0 Or inStr(1, strUserAgent, "NT 5.1", 1) > 0 Then strOS = "Windows XP" ElseIf inStr(1, strUserAgent, "Windows 2000", 1) > 0 Or inStr(1, strUserAgent, "NT 5", 1) > 0 Then strOS = "Windows 2000" ElseIf inStr(1, strUserAgent, "Windows NT", 1) > 0 Or inStr(1, strUserAgent, "WinNT", 1) > 0 Then strOS = "Windows NT 4" ElseIf inStr(1, strUserAgent, "Windows 95", 1) > 0 Or inStr(1, strUserAgent, "Win95", 1) > 0 Then strOS = "Windows 95" ElseIf inStr(1, strUserAgent, "Windows ME", 1) > 0 Or inStr(1, strUserAgent, "Win 9x 4.90", 1) > 0 Then strOS = "Windows ME" ElseIf inStr(1, strUserAgent, "Windows 98", 1) > 0 Or inStr(1, strUserAgent, "Win98", 1) > 0 Then strOS = "Windows 98" ElseIf Instr(1, strUserAgent, "Windows 3.1", 1) > 0 or Instr(1, strUserAgent, "Win16", 1) > 0 Then strOS = "Windows 3.x" ElseIf Instr(1, strUserAgent, "Windows CE", 1) > 0 Then strOS = "Windows CE" 'PalmOS ElseIf inStr(1, strUserAgent, "PalmOS", 1) > 0 Then strOS = "Palm OS" 'PalmPilot ElseIf inStr(1, strUserAgent, "Elaine", 1) > 0 Then strOS = "PalmPilot" 'Nokia ElseIf inStr(1, strUserAgent, "Nokia", 1) > 0 Then strOS = "Nokia" 'Linux ElseIf inStr(1, strUserAgent, "Linux", 1) > 0 Then strOS = "Linux" 'Amiga ElseIf inStr(1, strUserAgent, "Amiga", 1) > 0 Then strOS = "Amiga" 'Solaris ElseIf inStr(1, strUserAgent, "Solaris", 1) > 0 Then strOS = "Solaris" 'SunOS ElseIf inStr(1, strUserAgent, "SunOS", 1) > 0 Then strOS = "Sun OS" 'BSD ElseIf inStr(1, strUserAgent, "BSD", 1) > 0 or inStr(1, strUserAgent, "FreeBSD", 1) > 0 Then strOS = "Free BSD" 'Unix ElseIf inStr(1, strUserAgent, "Unix", 1) > 0 OR inStr(1, strUserAgent, "X11", 1) > 0 Then strOS = "Unix" 'AOL webTV ElseIf inStr(1, strUserAgent, "AOLTV", 1) > 0 OR inStr(1, strUserAgent, "AOL_TV", 1) > 0 Then strOS = "AOL TV" ElseIf inStr(1, strUserAgent, "WebTV", 1) > 0 Then strOS = "Web TV" 'Machintosh ElseIf inStr(1, strUserAgent, "Mac OS X", 1) > 0 Then strOS = "Mac OS X" ElseIf inStr(1, strUserAgent, "Mac_PowerPC", 1) > 0 or Instr(1, strUserAgent, "PPC", 1) > 0 Then strOS = "Mac PowerPC" ElseIf (inStr(1, strUserAgent, "6800", 1) > 0 OR inStr(1, strUserAgent, "68k", 1) > 0) AND inStr(1, strUserAgent, "Mac", 1) > 0 Then strOS = "Mac 68k" ElseIf inStr(1, strUserAgent, "Mac", 1) > 0 or inStr(1, strUserAgent, "apple", 1) > 0 Then strOS = "Macintosh" 'OS/2 ElseIf inStr(1, strUserAgent, "OS/2", 1) > 0 Then strOS = "OS/2" 'Search Robot ElseIf inStr(1, strUserAgent, "Googlebot", 1) > 0 OR inStr(1, strUserAgent, "ZyBorg", 1) > 0 OR inStr(1, strUserAgent, "slurp", 1) > 0 OR inStr(1, strUserAgent, "Scooter", 1) > 0 OR inStr(1, strUserAgent, "Robozilla", 1) > 0 OR inStr(1, strUserAgent, "Ask Jeeves", 1) > 0 OR inStr(1, strUserAgent, "Ask+Jeeves", 1) > 0 OR inStr(1, strUserAgent, "lycos", 1) > 0 OR inStr(1, strUserAgent, "ArchitextSpider", 1) > 0 OR inStr(1, strUserAgent, "Gulliver", 1) > 0 OR inStr(1, strUserAgent, "crawler@fast", 1) > 0 Then strOS = "Search Robot" 'Search Robot ElseIf inStr(1, strUserAgent, "TurnitinBot", 1) > 0 OR inStr(1, strUserAgent, "internetseer", 1) > 0 OR inStr(1, strUserAgent, "nameprotect", 1) > 0 OR inStr(1, strUserAgent, "PhpDig", 1) > 0 OR inStr(1, strUserAgent, "StackRambler", 1) > 0 OR inStr(1, strUserAgent, "UbiCrawler", 1) > 0 OR inStr(1, strUserAgent, "Speedy+Spider", 1) > 0 OR inStr(1, strUserAgent, "ia_archiver", 1) > 0 OR inStr(1, strUserAgent, "msnbot", 1) > 0 OR inStr(1, strUserAgent, "arianna.libero.it", 1) > 0 Then strOS = "Search Robot" Else strOS = "Unknown" End If 'Return function OSType = strOS End Function '****************************************** '*** DB Topic/Post Count Update ***** '****************************************** Private Function updateTopicPostCount(ByVal intForumID) Dim rsCount 'Database recordset holding the number of topics and posts Dim lngNumberOfTopics 'Holds the number of topics Dim lngNumberOfPosts 'Holds the number of posts 'Intilaise variables lngNumberOfTopics = 0 lngNumberOfPosts = 0 'Intialise the ADO recordset object Set rsCount = Server.CreateObject("ADODB.Recordset") 'Get the number of Topics 'Initalise the strSQL variable with an SQL statement to query the database to count the number of topics in the forums If strDatabaseType = "SQLServer" Then strSQL = "EXECUTE " & strDbProc & "ForumTopicCount @intForumID = " & intForumID Else strSQL = "SELECT Count(" & strDbTable & "Topic.Forum_ID) AS Topic_Count " strSQL = strSQL & "From " & strDbTable & "Topic " strSQL = strSQL & "WHERE " & strDbTable & "Topic.Forum_ID = " & intForumID & " " End If 'Query the database rsCount.Open strSQL, adoCon 'Read in the number of Topics If NOT rsCount.EOF Then lngNumberOfTopics = CLng(rsCount("Topic_Count")) 'Close the rs rsCount.Close 'Get the number of Posts 'Initalise the strSQL variable with an SQL statement to query the database to count the number of threads in the forums If strDatabaseType = "SQLServer" Then strSQL = "EXECUTE " & strDbProc & "ForumThreadCount @intForumID = " & intForumID Else strSQL = "SELECT Count(" & strDbTable & "Thread.Thread_ID) AS Thread_Count " strSQL = strSQL & "FROM " & strDbTable & "Topic INNER JOIN " & strDbTable & "Thread ON " & strDbTable & "Topic.Topic_ID = " & strDbTable & "Thread.Topic_ID " strSQL = strSQL & "GROUP BY " & strDbTable & "Topic.Forum_ID " strSQL = strSQL & "HAVING (((" & strDbTable & "Topic.Forum_ID)=" & intForumID & "));" End If 'Query the database rsCount.Open strSQL, adoCon 'Get the thread count If NOT rsCount.EOF Then lngNumberOfPosts = CLng(rsCount("Thread_Count")) 'Reset server variables rsCount.Close Set rsCount = Nothing 'Initalise the SQL string with an SQL update command to update the number of topics and posts in the forum strSQL = "UPDATE " & strDbTable & "Forum SET " strSQL = strSQL & "" & strDbTable & "Forum.No_of_topics = " & lngNumberOfTopics & ", " & strDbTable & "Forum.No_of_posts = " & lngNumberOfPosts strSQL = strSQL & " WHERE " & strDbTable & "Forum.Forum_ID= " & intForumID & ";" 'Write the updated number of posts to the database adoCon.Execute(strSQL) End Function '****************************************** '*** Forum Permisisons ***** '****************************************** Public Function forumPermisisons(ByVal intForumID, ByVal intGroupID, ByVal intRead, ByVal intPost, ByVal intReply, ByVal intEdit, ByVal intDelete, ByVal intPriority, ByVal intPollCreate, ByVal intVote, ByVal intAttachments, ByVal intImageUpload) 'Declare variables Dim rsPermissions 'Holds the permissions recordset 'Initilise variables blnRead = False blnPost = False blnReply = False blnEdit = False blnDelete = False blnPriority = False blnPollCreate = False blnVote = False blnAttachments = False blnImageUpload = False blnModerator = False 'Intialise the ADO recordset object Set rsPermissions = Server.CreateObject("ADODB.Recordset") 'Get the users group permissions from the db if there are any 'Initalise the strSQL variable with an SQL statement to query the database to count the number of topics in the forums If strDatabaseType = "SQLServer" Then strSQL = "EXECUTE " & strDbProc & "ForumPermissions @intForumID = " & intForumID & ", @intGroupID = " & intGroupID & ", @intAuthorID = " & lngLoggedInUserID Else strSQL = "SELECT " & strDbTable & "Permissions.* " strSQL = strSQL & "FROM " & strDbTable & "Permissions " strSQL = strSQL & "WHERE (" & strDbTable & "Permissions.Group_ID = " & intGroupID & " OR " & strDbTable & "Permissions.Author_ID = " & lngLoggedInUserID & ") AND " & strDbTable & "Permissions.Forum_ID = " & intForumID & " " strSQL = strSQL & "ORDER BY " & strDbTable & "Permissions.Author_ID DESC;" End If 'Query the database rsPermissions.Open strSQL, adoCon 'Read in the permissions for the group the member is part of if there are any If NOT rsPermissions.EOF Then blnRead = CBool(rsPermissions("Read")) blnPost = CBool(rsPermissions("Post")) blnReply = CBool(rsPermissions("Reply_posts")) blnEdit = CBool(rsPermissions("Edit_posts")) blnDelete = CBool(rsPermissions("Delete_posts")) blnPriority = CBool(rsPermissions("Priority_posts")) blnPollCreate = CBool(rsPermissions("Poll_create")) blnVote = CBool(rsPermissions("Vote")) blnAttachments = CBool(rsPermissions("Attachments")) blnImageUpload = CBool(rsPermissions("Image_upload")) blnModerator = CBool(rsPermissions("Moderate")) 'Else there are no forum permissions for this group so use the generic forum permissions Else 'If ALL(1) OR (REG(2) AND NOT GID2(Guest Group)) OR (Admin(5) AND GID1(Admin Group)) Then set to true If intRead = 1 OR (intRead = 2 AND intGroupID <> 2) OR (blnAdmin) Then blnRead = True If intPost = 1 OR (intPost = 2 AND intGroupID <> 2) OR (blnAdmin) Then blnPost = True If intReply = 1 OR (intReply = 2 AND intGroupID <> 2) OR (blnAdmin) Then blnReply = True If intEdit = 1 OR (intEdit = 2 AND intGroupID <> 2) OR (blnAdmin) Then blnEdit = True If intDelete = 1 OR (intDelete = 2 AND intGroupID <> 2) OR (blnAdmin) Then blnDelete = True If intPriority = 1 OR (intPriority = 2 AND intGroupID <> 2) OR (blnAdmin) Then blnPriority = True If (intPollCreate = 1 OR (intPollCreate = 2 AND intGroupID <> 2) OR (blnAdmin)) AND intPollCreate <> 0 Then blnPollCreate = True If (intVote = 1 OR (intVote = 2 AND intGroupID <> 2) OR (blnAdmin)) AND intVote <> 0 Then blnVote = True If (intAttachments = 1 OR (intAttachments = 2 AND intGroupID <> 2) OR (blnAdmin)) AND intAttachments <> 0 Then blnAttachments = True If (intImageUpload = 1 OR (intImageUpload = 2 AND intGroupID <> 2) OR (blnAdmin)) AND intImageUpload <> 0 Then blnImageUpload = True End If 'Clean up rsPermissions.Close Set rsPermissions = Nothing End Function '****************************************** '*** Is Moderator ***** '****************************************** 'Although the above function can work out if the user is a moderator sometimes we only need to know if the user is a moderator or not Private Function isModerator(ByVal intForumID, ByVal intGroupID) 'Declare variables Dim rsPermissions 'Holds the permissions recordset Dim blnModerator 'Set to true if the user is a moderator 'Initilise vairiables blnModerator = False 'Intialise the ADO recordset object Set rsPermissions = Server.CreateObject("ADODB.Recordset") 'Get the users group permissions from the db if there are any 'Initalise the strSQL variable with an SQL statement to query the database to count the number of topics in the forums If strDatabaseType = "SQLServer" Then strSQL = "EXECUTE " & strDbProc & "ForumPermissions @intForumID = " & intForumID & ", @intGroupID = " & intGroupID & ", @intAuthorID = " & lngLoggedInUserID Else strSQL = "SELECT " & strDbTable & "Permissions.* " strSQL = strSQL & "FROM " & strDbTable & "Permissions " strSQL = strSQL & "WHERE (" & strDbTable & "Permissions.Group_ID = " & intGroupID & " OR " & strDbTable & "Permissions.Author_ID = " & lngLoggedInUserID & ") AND " & strDbTable & "Permissions.Forum_ID = " & intForumID & " " strSQL = strSQL & "ORDER BY " & strDbTable & "Permissions.Author_ID DESC;" End If 'Query the database rsPermissions.Open strSQL, adoCon 'If there is a result returned by the db set it to the blnModerator variable If NOT rsPermissions.EOF Then blnModerator = CBool(rsPermissions("Moderate")) 'Clean up rsPermissions.Close Set rsPermissions = Nothing 'Return the function isModerator = blnModerator End Function '****************************************** '*** Disallowed Member Names ***** '****************************************** Private Function disallowedMemberNames(ByVal strUserName) strUsername = Replace(strUsername, "salt", "", 1, -1, 1) strUsername = Replace(strUsername, "password", "", 1, -1, 1) strUsername = Replace(strUsername, "author", "", 1, -1, 1) strUsername = Replace(strUsername, "code", "", 1, -1, 1) strUsername = Replace(strUsername, "username", "", 1, -1, 1) strUsername = Replace(strUsername, "N0act", "", 1, -1, 1) 'Return Function disallowedMemberNames = strUsername End Function '****************************************** '**** Banned IP's ***** '****************************************** Private Function bannedIP() 'Declare variables Dim rsIPAddr Dim strCheckIPAddress Dim strUserIPAddress Dim blnIPMatched 'Intilise variable blnIPMatched = False 'Get the users IP strUserIPAddress = getIP() 'Intialise the ADO recordset object Set rsIPAddr = Server.CreateObject("ADODB.Recordset") 'Get any banned IP address from the database 'Initalise the strSQL variable with an SQL statement to query the database to count the number of topics in the forums If strDatabaseType = "SQLServer" Then strSQL = "EXECUTE " & strDbProc & "BannedIPs" Else strSQL = "SELECT " & strDbTable & "BanList.IP FROM " & strDbTable & "BanList WHERE " & strDbTable & "BanList.IP Is Not Null;" End If 'Query the database rsIPAddr.Open strSQL, adoCon 'Loop through the IP address and check 'em out Do while NOT rsIPAddr.EOF 'Get the IP address to check from the recordset strCheckIPAddress = rsIPAddr("IP") 'See if we need to check the IP range or just one IP address 'If the last character is a * then this is a wildcard range to be checked If Right(strCheckIPAddress, 1) = "*" Then 'Remove the wildcard charcter form the IP strCheckIPAddress = Replace(strCheckIPAddress, "*", "", 1, -1, 1) 'Trim the users IP to the same length as the IP range to check strUserIPAddress = Mid(strUserIPAddress, 1, Len(strCheckIPAddress)) 'See if whats left of the IP matches If strCheckIPAddress = strUserIPAddress Then blnIPMatched = True 'Else check the IP address metches Else 'Else check to see if the IP address match If strCheckIPAddress = strUserIPAddress Then blnIPMatched = True End If 'Move to the next record rsIPAddr.MoveNext Loop 'Clean up rsIPAddr.Close Set rsIPAddr = Nothing 'Return the function bannedIP = blnIPMatched End Function '****************************************** '*** Check the session ID *** '****************************************** Private Function checkSessionID(lngAspSessionID) 'Check to see if the session ID's match if they don't send the user away If lngAspSessionID <> Session.SessionID Then 'clean up before redirecting Set rsCommon = Nothing adoCon.Close Set adoCon = Nothing 'redirect to insufficient permissions page Response.Redirect("insufficient_permission.asp?FID=" & intForumID & "&M=sID") End If End Function '****************************************** '*** Get users IP address *** '****************************************** Private Function getIP() Dim strIPAddr 'If they are not going through a proxy get the IP address If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" OR InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then strIPAddr = Request.ServerVariables("REMOTE_ADDR") 'If they are going through multiple proxy servers only get the fisrt IP address in the list (,) ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1) 'If they are going through multiple proxy servers only get the fisrt IP address in the list (;) ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1) 'Get the browsers IP address not the proxy servers IP Else strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR") End If 'Remove all tags in IP string strIPAddr = removeAllTags(strIPAddr) 'Place the IP address back into the returning function getIP = Trim(Mid(strIPAddr, 1, 30)) End Function '****************************************** '*** Sort Active Users List *** '****************************************** 'Sub procedure to sort the array using a Bubble Sort to place highest matches first Private Sub SortActiveUsersList(ByRef saryActiveUsers) 'Dimension variables Dim intArrayGap 'Holds the part of the array being sorted Dim intIndexPosition 'Holds the Array index position being sorted Dim intPassNumber 'Holds the pass number for the sort Dim saryTempStringStore(7) 'Array to temparily store the position being sorted 'Loop round to sort each result found For intPassNumber = 1 To UBound(saryActiveUsers, 2) 'Shortens the number of passes For intIndexPosition = 1 To (UBound(saryActiveUsers, 2) - intPassNumber) 'If the Result being sorted is a less time than the next result in the array then swap them If saryActiveUsers(4,intIndexPosition) < saryActiveUsers(4,(intIndexPosition+1)) Then 'Place the Result being sorted in a temporary array variable saryTempStringStore(0) = saryActiveUsers(0,intIndexPosition) saryTempStringStore(1) = saryActiveUsers(1,intIndexPosition) saryTempStringStore(2) = saryActiveUsers(2,intIndexPosition) saryTempStringStore(3) = saryActiveUsers(3,intIndexPosition) saryTempStringStore(4) = saryActiveUsers(4,intIndexPosition) saryTempStringStore(5) = saryActiveUsers(5,intIndexPosition) saryTempStringStore(6) = saryActiveUsers(6,intIndexPosition) saryTempStringStore(7) = saryActiveUsers(7,intIndexPosition) '*** Do the array position swap *** 'Move the next Result with a higher match rate into the present array location saryActiveUsers(0,intIndexPosition) = saryActiveUsers(0,(intIndexPosition+1)) saryActiveUsers(1,intIndexPosition) = saryActiveUsers(1,(intIndexPosition+1)) saryActiveUsers(2,intIndexPosition) = saryActiveUsers(2,(intIndexPosition+1)) saryActiveUsers(3,intIndexPosition) = saryActiveUsers(3,(intIndexPosition+1)) saryActiveUsers(4,intIndexPosition) = saryActiveUsers(4,(intIndexPosition+1)) saryActiveUsers(5,intIndexPosition) = saryActiveUsers(5,(intIndexPosition+1)) saryActiveUsers(6,intIndexPosition) = saryActiveUsers(6,(intIndexPosition+1)) saryActiveUsers(7,intIndexPosition) = saryActiveUsers(7,(intIndexPosition+1)) 'Move the Result from the teporary holding variable into the next array position saryActiveUsers(0,(intIndexPosition+1)) = saryTempStringStore(0) saryActiveUsers(1,(intIndexPosition+1)) = saryTempStringStore(1) saryActiveUsers(2,(intIndexPosition+1)) = saryTempStringStore(2) saryActiveUsers(3,(intIndexPosition+1)) = saryTempStringStore(3) saryActiveUsers(4,(intIndexPosition+1)) = saryTempStringStore(4) saryActiveUsers(5,(intIndexPosition+1)) = saryTempStringStore(5) saryActiveUsers(6,(intIndexPosition+1)) = saryTempStringStore(6) saryActiveUsers(7,(intIndexPosition+1)) = saryTempStringStore(7) End If Next Next End Sub %>