<% '################################################################################# '## Snitz Forums 2000 v3.4.06 '################################################################################# '## Copyright (C) 2000-06 Michael Anderson, Pierre Gorissen, '## Huw Reddick and Richard Kinser '## '## This program is free software; you can redistribute it and/or '## modify it under the terms of the GNU General Public License '## as published by the Free Software Foundation; either version 2 '## of the License, or (at your option) any later version. '## '## All copyright notices regarding Snitz Forums 2000 '## must remain intact in the scripts and in the outputted HTML '## The "powered by" text/logo with a link back to '## http://forum.snitz.com in the footer of the pages MUST '## remain visible when the pages are viewed on the internet or intranet. '## '## This program is distributed in the hope that it will be useful, '## but WITHOUT ANY WARRANTY; without even the implied warranty of '## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the '## GNU General Public License for more details. '## '## You should have received a copy of the GNU General Public License '## along with this program; if not, write to the Free Software '## Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. '## '## Support can be obtained from our support forums at: '## http://forum.snitz.com '## '## Correspondence and Marketing Questions can be sent to: '## manderson@snitz.com '## '################################################################################# %> <% '############################################## '## Post Formatting ## '############################################## function chkQuoteOk(fString) chkQuoteOk = not(InStr(1, fString, "'", 0) > 0) end function function ChkURLs(ByVal strToFormat, ByVal sPrefix, ByVal iType) Dim strArray Dim Counter ChkURLs = strToFormat if InStr(1, strToFormat, sPrefix) > 0 Then strArray = Split(strToFormat, sPrefix, -1) ChkURLs = strArray(0) for Counter = 1 To UBound(strArray) if ((strArray(Counter-1) = "" Or Len(strArray(Counter-1)) < 5) And strArray(Counter)<> "") then ChkURLs = ChkURLs & edit_hrefs(sPrefix & strArray(Counter), iType) elseif ((UCase(Right(strArray(Counter-1), 6)) <> "HREF=""") and _ (UCase(Right(strArray(Counter-1), 5)) <> "[IMG]") and _ (UCase(Right(strArray(Counter-1), 5)) <> "[URL]") and _ (UCase(Right(strArray(Counter-1), 6)) <> "[URL=""") and _ (UCase(Right(strArray(Counter-1), 6)) <> "FTP://") and _ (UCase(Right(strArray(Counter-1), 8)) <> "FILE:///") and _ (UCase(Right(strArray(Counter-1), 7)) <> "HTTP://") and _ (UCase(Right(strArray(Counter-1), 8)) <> "HTTPS://") and _ (UCase(Right(strArray(Counter-1), 5)) <> "SRC=""") and _ (UCase(Right(strArray(Counter-1), 1)) <> "-") and _ (UCase(Right(strArray(Counter-1), 1)) <> "=") and _ (strArray(Counter) <> "")) then ChkURLs = ChkURLs & edit_hrefs(sPrefix & strArray(Counter), iType) else ChkURLs = ChkURLs & sPrefix & strArray(Counter) end if next end if end function function ChkMail(ByVal strToFormat) Dim strArray Dim Counter if InStr(1, strToFormat, " ") > 0 Then strArray = Split(Replace(strToFormat, "
", "
", 1, -1, vbTextCompare), " ", -1) 'ChkMail = strArray(0) for Counter = 0 to UBound(strArray) If (InStr(strArray(Counter), "@") > 0) and _ not(InStr(UCase(strArray(Counter)), "MAILTO:") > 0) and _ not(InStr(UCase(strArray(Counter)), "FTP:") > 0) and _ not(InStr(UCase(strArray(Counter)), "[URL") > 0) then ChkMail = ChkMail & " " & edit_hrefs(strArray(counter), 4) else ChkMail = ChkMail & " " & strArray(counter) end if next ChkMail = Replace(ChkMail, "
", "
", 1, -1, vbTextCompare) else if (InStr(strToFormat, "@") > 0) and _ not(InStr(UCase(strToFormat), "MAILTO:") > 0) and _ not(InStr(UCase(strToFormat), "FTP:") > 0) and _ not(InStr(UCase(strToFormat), "[URL") > 0) then ChkMail = ChkMail & " " & edit_hrefs(strToFormat, 4) else ChkMail = strToFormat end if end if end function function FormatStr(fString) on Error resume next fString = Replace(fString, CHR(13), "") 'fString = Replace(fString, CHR(10) & CHR(10), "

") fString = Replace(fString, CHR(10), "
") if strBadWordFilter = 1 or strBadWordFilter = "1" then fString = ChkBadWords(fString) end if if strAllowForumCode = "1" then fString = ReplaceURLs(fString) fString = ReplaceCodeTags(fString) if strIMGInPosts = "1" then fString = ReplaceImageTags(fString) end if end if fString = ChkURLs(fString, "http://", 1) fString = ChkURLs(fString, "https://", 2) fString = ChkURLs(fString, "www.", 3) fString = ChkMail(fString) fString = ChkURLs(fString, "ftp://", 5) fString = ChkURLs(fString, "file:///", 6) if strIcons = "1" then fString = smile(fString) end if if strAllowForumCode = "1" then fString = extratags(fString) end if FormatStr = fString on Error goto 0 end function function doCode(fString, fOTag, fCTag, fROTag, fRCTag) fOTagPos = Instr(1, fString, fOTag, 1) fCTagPos = Instr(1, fString, fCTag, 1) while (fCTagPos > 0 and fOTagPos > 0) fString = replace(fString, fOTag, fROTag, 1, 1, 1) fString = replace(fString, fCTag, fRCTag, 1, 1, 1) fOTagPos = Instr(1, fString, fOTag, 1) fCTagPos = Instr(1, fString, fCTag, 1) wend doCode = fString end function function Smile(fString) fString = replace(fString, "[:(!]", getCurrentIcon(strIconSmileAngry,"","align=""middle""")) fString = replace(fString, "[B)]", getCurrentIcon(strIconSmileBlackeye,"","align=""middle""")) fString = replace(fString, "[xx(]", getCurrentIcon(strIconSmileDead,"","align=""middle""")) fString = replace(fString, "[XX(]", getCurrentIcon(strIconSmileDead,"","align=""middle""")) fString = replace(fString, "[:I]", getCurrentIcon(strIconSmileBlush,"","align=""middle""")) fString = replace(fString, "[:(]", getCurrentIcon(strIconSmileSad,"","align=""middle""")) fString = replace(fString, "[:o]", getCurrentIcon(strIconSmileShock,"","align=""middle""")) fString = replace(fString, "[:O]", getCurrentIcon(strIconSmileShock,"","align=""middle""")) fString = replace(fString, "[:0]", getCurrentIcon(strIconSmileShock,"","align=""middle""")) fString = replace(fString, "[|)]", getCurrentIcon(strIconSmileSleepy,"","align=""middle""")) fString = replace(fString, "[:)]", getCurrentIcon(strIconSmile,"","align=""middle""")) fString = replace(fString, "[:D]", getCurrentIcon(strIconSmileBig,"","align=""middle""")) fString = replace(fString, "[}:)]", getCurrentIcon(strIconSmileEvil,"","align=""middle""")) fString = replace(fString, "[:o)]", getCurrentIcon(strIconSmileClown,"","align=""middle""")) fString = replace(fString, "[:O)]", getCurrentIcon(strIconSmileClown,"","align=""middle""")) fString = replace(fString, "[:0)]", getCurrentIcon(strIconSmileClown,"","align=""middle""")) fString = replace(fString, "[8)]", getCurrentIcon(strIconSmileShy,"","align=""middle""")) fString = replace(fString, "[8D]", getCurrentIcon(strIconSmileCool,"","align=""middle""")) fString = replace(fString, "[:P]", getCurrentIcon(strIconSmileTongue,"","align=""middle""")) fString = replace(fString, "[:p]", getCurrentIcon(strIconSmileTongue,"","align=""middle""")) fString = replace(fString, "[;)]", getCurrentIcon(strIconSmileWink,"","align=""middle""")) fString = replace(fString, "[8]", getCurrentIcon(strIconSmile8ball,"","align=""middle""")) fString = replace(fString, "[?]", getCurrentIcon(strIconSmileQuestion,"","align=""middle""")) fString = replace(fString, "[^]", getCurrentIcon(strIconSmileApprove,"","align=""middle""")) fString = replace(fString, "[V]", getCurrentIcon(strIconSmileDisapprove,"","align=""middle""")) fString = replace(fString, "[v]", getCurrentIcon(strIconSmileDisapprove,"","align=""middle""")) fString = replace(fString, "[:X]", getCurrentIcon(strIconSmileKisses,"","align=""middle""")) fString = replace(fString, "[:x]", getCurrentIcon(strIconSmileKisses,"","align=""middle""")) Smile = fString end function function extratags(fString) fString = doCode(fString, "[spoiler]", "[/spoiler]", "", "") extratags = fString end function function chkBadWords(fString) if trim(Application(strCookieURL & "STRBADWORDWORDS")) = "" or trim(Application(strCookieURL & "STRBADWORDREPLACE")) = "" then txtBadWordWords = "" txtBadWordReplace = "" '## Forum_SQL - Get Badwords from DB strSqlb = "SELECT B_BADWORD, B_REPLACE " strSqlb = strSqlb & " FROM " & strFilterTablePrefix & "BADWORDS " if strDBType = "mysql" then strSqlb = strSqlb & "ORDER BY LENGTH(B_BADWORD) DESC " else strSqlb = strSqlb & "ORDER BY LEN(B_BADWORD) DESC " end if set rsBadWord = Server.CreateObject("ADODB.Recordset") rsBadWord.open strSqlb, my_Conn, adOpenForwardOnly, adLockReadOnly, adCmdText if rsBadWord.EOF then recBadWordCount = "" else allBadWordData = rsBadWord.GetRows(adGetRowsRest) recBadWordCount = UBound(allBadWordData,2) end if rsBadWord.close set rsBadWord = nothing if recBadWordCount <> "" then bBADWORD = 0 bREPLACE = 1 for iBadword = 0 to recBadWordCount BadWordWord = allBadWordData(bBADWORD,iBadWord) BadWordReplace = allBadWordData(bREPLACE,iBadWord) if txtBadWordWords = "" then txtBadWordWords = BadWordWord txtBadWordReplace = BadWordReplace else txtBadWordWords = txtBadWordWords & "," & BadWordWord txtBadWordReplace = txtBadWordReplace & "," & BadWordReplace end if next end if Application.Lock Application(strCookieURL & "STRBADWORDWORDS") = txtBadWordWords Application(strCookieURL & "STRBADWORDREPLACE") = txtBadWordReplace Application.UnLock end if txtBadWordWords = Application(strCookieURL & "STRBADWORDWORDS") txtBadWordReplace = Application(strCookieURL & "STRBADWORDREPLACE") if fString = "" or IsNull(fString) then fString = " " bwords = split(txtBadWordWords, ",") breplace = split(txtBadWordReplace, ",") for i = 0 to ubound(bwords) fString = Replace(fString, bwords(i), breplace(i), 1, -1, 1) next chkBadWords = fString end function function HTMLEncode(pString) fString = trim(pString) if fString = "" or IsNull(fString) then fString = " " else fString = replace(fString, ">", ">") fString = replace(fString, "<", "<") end if HTMLEncode = fString end function function HTMLDecode(pString) fString = trim(pString) if fString = "" then fString = " " else fString = replace(fString, ">", ">") fString = replace(fString, "<", "<") end if HTMLDecode = fString end function function chkString(pString,fField_Type) '## Types - name, password, title, message, url, urlpath, email, number, list fString = trim(pString) if fString = "" or isNull(fString) then fString = " " else ' chkBadWords(fString) end if Select Case lcase(fField_Type) Case "refer" fString = Replace(fString, "&#", "#") fString = Replace(fString, """", """) fString = HTMLEncode(fString) ChkString = fString exit function Case "archive" fString = Replace(fString, "'", "''") if strDBType = "mysql" then fString = Replace(fString, "\", "\\") end if chkString = fString exit function Case "displayimage" fString = Replace(fString, " ", "") fString = Replace(fString, """", "") fString = Replace(fString, "<", "") fString = Replace(fString, ">", "") chkString = fString exit function Case "pagetitle" if strBadWordFilter = "1" then fString = chkBadWords(fString) end if fString = Replace(fString,"\","\\") fString = Replace(fString,"'","\'") fString = HTMLDecode(fString) chkString = fString exit function Case "title" if strAllowHTML <> "1" then fString = HTMLEncode(fString) end if if strBadWordFilter = "1" then fString = chkBadWords(fString) end if chkString = fString exit function Case "password" fString = trim(fString) chkString = fString Case "decode" fString = HTMLDecode(fString) chkString = fString exit function Case "urlpath" fString = Server.URLEncode(fString) chkString = fString exit function Case "sqlstring" fString = Replace(fString, "'", "''") if strDBType = "mysql" then fString = Replace(fString, "\", "\\") end if fString = HTMLEncode(fString) chkString = fString exit function Case "jsurlpath" fString = Replace(fString, "'", "\'") fString = Server.URLEncode(fString) chkString = fString exit function Case "edit" if strAllowHTML <> "1" then fString = HTMLEncode(fString) end if fString = Replace(fString, """", """) ChkString = fString exit function Case "admindisplay" if strAllowHTML <> "1" then fString = HTMLEncode(fString) end if chkString = fString exit function Case "display" if strAllowHTML <> "1" then fString = HTMLEncode(fString) end if if strBadWordFilter = "1" then fString = ChkBadWords(fString) end if fString = replace(fString,"+","+") fString = replace(fString, """", """) chkString = fString exit function Case "search" if strAllowHTML <> "1" then fString = HTMLEncode(fString) end if if strBadWordFilter = "1" then fString = ChkBadWords(fString) end if fString = Replace(fString, """", """) chkString = fString exit function Case "message" if strBadWordFilter = "1" then fString = ChkBadWords(fString) end if fString = Replace(fString,"&#","#") if strDBType = "mysql" then fString = Replace(fString, "\", "\\") end if if strAllowHTML <> "1" then fString = HTMLEncode(fString) end if Case "preview" if strBadWordFilter = "1" then fString = ChkBadWords(fString) end if if strAllowHTML <> "1" then fString = HTMLEncode(fString) end if Case "hidden" fString = HTMLEncode(fString) End Select if fField_Type <> "signature" and fField_Type <> "title" then fString = doCode(fString, "[quote]", "[/quote]", "
quote:
", "
") end if if strAllowForumCode = "1" and fField_Type <> "signature" then fString = doCode(fString, "[b]", "[/b]", "", "") fString = doCode(fString, "[s]", "[/s]", "", "") fString = doCode(fString, "[strike]", "[/strike]", "", "") fString = doCode(fString, "[u]", "[/u]", "", "") fString = doCode(fString, "[i]", "[/i]", "", "") if fField_Type <> "title" then fString = doCode(fString, "[font=Andale Mono]", "[/font=Andale Mono]", "", "") fString = doCode(fString, "[font=Arial]", "[/font=Arial]", "", "") fString = doCode(fString, "[font=Arial Black]", "[/font=Arial Black]", "", "") fString = doCode(fString, "[font=Book Antiqua]", "[/font=Book Antiqua]", "", "") fString = doCode(fString, "[font=Century Gothic]", "[/font=Century Gothic]", "", "") fString = doCode(fString, "[font=Courier New]", "[/font=Courier New]", "", "") fString = doCode(fString, "[font=Comic Sans MS]", "[/font=Comic Sans MS]", "", "") fString = doCode(fString, "[font=Georgia]", "[/font=Georgia]", "", "") fString = doCode(fString, "[font=Impact]", "[/font=Impact]", "", "") fString = doCode(fString, "[font=Tahoma]", "[/font=Tahoma]", "", "") fString = doCode(fString, "[font=Times New Roman]", "[/font=Times New Roman]", "", "") fString = doCode(fString, "[font=Trebuchet MS]", "[/font=Trebuchet MS]", "", "") fString = doCode(fString, "[font=Script MT Bold]", "[/font=Script MT Bold]", "", "") fString = doCode(fString, "[font=Stencil]", "[/font=Stencil]", "", "") fString = doCode(fString, "[font=Verdana]", "[/font=Verdana]", "", "") fString = doCode(fString, "[font=Lucida Console]", "[/font=Lucida Console]", "", "") fString = doCode(fString, "[red]", "[/red]", "", "") fString = doCode(fString, "[green]", "[/green]", "", "") fString = doCode(fString, "[blue]", "[/blue]", "", "") fString = doCode(fString, "[white]", "[/white]", "", "") fString = doCode(fString, "[purple]", "[/purple]", "", "") fString = doCode(fString, "[yellow]", "[/yellow]", "", "") fString = doCode(fString, "[violet]", "[/violet]", "", "") fString = doCode(fString, "[brown]", "[/brown]", "", "") fString = doCode(fString, "[black]", "[/black]", "", "") fString = doCode(fString, "[pink]", "[/pink]", "", "") fString = doCode(fString, "[orange]", "[/orange]", "", "") fString = doCode(fString, "[gold]", "[/gold]", "", "") fString = doCode(fString, "[beige]", "[/beige]", "", "") fString = doCode(fString, "[teal]", "[/teal]", "", "") fString = doCode(fString, "[navy]", "[/navy]", "", "") fString = doCode(fString, "[maroon]", "[/maroon]", "", "") fString = doCode(fString, "[limegreen]", "[/limegreen]", "", "") fString = doCode(fString, "[h1]", "[/h1]", "

", "

") fString = doCode(fString, "[h2]", "[/h2]", "

", "

") fString = doCode(fString, "[h3]", "[/h3]", "

", "

") fString = doCode(fString, "[h4]", "[/h4]", "

", "

") fString = doCode(fString, "[h5]", "[/h5]", "
", "
") fString = doCode(fString, "[h6]", "[/h6]", "
", "
") fString = doCode(fString, "[size=1]", "[/size=1]", "", "") fString = doCode(fString, "[size=2]", "[/size=2]", "", "") fString = doCode(fString, "[size=3]", "[/size=3]", "", "") fString = doCode(fString, "[size=4]", "[/size=4]", "", "") fString = doCode(fString, "[size=5]", "[/size=5]", "", "") fString = doCode(fString, "[size=6]", "[/size=6]", "", "") fString = doCode(fString, "[list]", "[/list]", "") fString = doCode(fString, "[list=1]", "[/list=1]", "
    ", "
") fString = doCode(fString, "[list=a]", "[/list=a]", "
    ", "
") fString = doCode(fString, "[*]", "[/*]", "
  • ", "
  • ") fString = doCode(fString, "[left]", "[/left]", "
    ", "
    ") fString = doCode(fString, "[center]", "[/center]", "
    ", "
    ") fString = doCode(fString, "[centre]", "[/centre]", "
    ", "
    ") fString = doCode(fString, "[right]", "[/right]", "
    ", "
    ") 'fString = doCode(fString, "[code]", "[/code]", "
    ", "
    ") fString = replace(fString, "[br]", "
    ", 1, -1, 1) fString = replace(fString, "[hr]", "
    ", 1, -1, 1) end if end if if fField_Type <> "hidden" and _ fField_Type <> "preview" then fString = Replace(fString, "'", "''") end if if fField_Type = "message" and strDBType = "mysql" then fString = Replace(fString, """", "\""") end if chkString = fString end function '############################################## '## Date Formatting ## '############################################## function doublenum(fNum) if fNum > 9 then doublenum = fNum else doublenum = "0" & fNum end if end function function chkDateFormat(strDateTime) chkDateFormat = isdate("" & Mid(strDateTime, 5,2) & "/" & Mid(strDateTime, 7,2) & "/" & Mid(strDateTime, 1,4) & " " & Mid(strDateTime, 9,2) & ":" & Mid(strDateTime, 11,2) & ":" & Mid(strDateTime, 13,2) & "") end function function StrToDate(strDateTime) if ChkDateFormat(strDateTime) then 'Testing for server format if strComp(Month("04/05/2002"),"4") = 0 then StrToDate = cdate("" & Mid(strDateTime, 5,2) & "/" & Mid(strDateTime, 7,2) & "/" & Mid(strDateTime, 1,4) & " " & Mid(strDateTime, 9,2) & ":" & Mid(strDateTime, 11,2) & ":" & Mid(strDateTime, 13,2) & "") else StrToDate = cdate("" & Mid(strDateTime, 7,2) & "/" & Mid(strDateTime, 5,2) & "/" & Mid(strDateTime, 1,4) & " " & Mid(strDateTime, 9,2) & ":" & Mid(strDateTime, 11,2) & ":" & Mid(strDateTime, 13,2) & "") end if else if strComp(Month("04/05/2002"),"4") = 0 then tmpDate = DatePart("m",strForumTimeAdjust) & "/" & DatePart("d",strForumTimeAdjust) & "/" & DatePart("yyyy",strForumTimeAdjust) & " " & DatePart("h",strForumTimeAdjust) & ":" & DatePart("n",strForumTimeAdjust) & ":" & DatePart("s",strForumTimeAdjust) else tmpDate = DatePart("d",strForumTimeAdjust) & "/" & DatePart("m",strForumTimeAdjust) & "/" & DatePart("yyyy",strForumTimeAdjust) & " " & DatePart("h",strForumTimeAdjust) & ":" & DatePart("n",strForumTimeAdjust) & ":" & DatePart("s",strForumTimeAdjust) end if StrToDate = tmpDate end if end function function oldStrToDate(strDateTime) if ChkDateFormat(strDateTime) then StrToDate = cdate("" & Mid(strDateTime, 5,2) & "/" & Mid(strDateTime, 7,2) & "/" & Mid(strDateTime, 1,4) & " " & Mid(strDateTime, 9,2) & ":" & Mid(strDateTime, 11,2) & ":" & Mid(strDateTime, 13,2) & "") else tmpDate = DatePart("m",strForumTimeAdjust) & "/" & DatePart("d",strForumTimeAdjust) & "/" & DatePart("yyyy",strForumTimeAdjust) & " " & DatePart("h",strForumTimeAdjust) & ":" & DatePart("n",strForumTimeAdjust) & ":" & DatePart("s",strForumTimeAdjust) StrToDate = "" & tmpDate end if end function function DateToStr(dtDateTime) if not isDate(dtDateTime) then dtDateTime = strToDate(dtDateTime) end if DateToStr = year(dtDateTime) & doublenum(Month(dtdateTime)) & doublenum(Day(dtdateTime)) & doublenum(Hour(dtdateTime)) & doublenum(Minute(dtdateTime)) & doublenum(Second(dtdateTime)) & "" end function function ReadLastHereDate(UserName) dim rs_date dim strSql if trim(UserName) = "" then ReadLastHereDate = DateToStr(DateAdd("d", -10, strForumTimeAdjust)) exit function end if '## Forum_SQL strSql = "SELECT M_LASTHEREDATE " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE " & strDBNTSQLName & " = '" & ChkString(UserName, "SQLString") & "' " Set rs_date = Server.CreateObject("ADODB.Recordset") rs_date.open strSql, my_Conn if (rs_date.BOF and rs_date.EOF) then ReadLastHereDate = DateToStr(DateAdd("d",-10,strForumTimeAdjust)) else if rs_date("M_LASTHEREDATE") = "" or IsNull(rs_date("M_LASTHEREDATE")) then ReadLastHereDate = DateToStr(DateAdd("d",-10,strForumTimeAdjust)) else ReadLastHereDate = rs_date("M_LASTHEREDATE") end if end if rs_date.close set rs_date = nothing UpdateLastHereDate DateToStr(strForumTimeAdjust),UserName end function function UpdateLastHereDate(fTime,UserName) UserIPAddress = Request.ServerVariables("HTTP_X_FORWARDED_FOR") If UserIPAddress = "" Then UserIPAddress = Request.ServerVariables("REMOTE_ADDR") End If '## Forum_SQL - Do DB Update strSql = "UPDATE " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " SET M_LASTHEREDATE = '" & fTime & "'" strSql = strSql & ", M_LAST_IP = '" & UserIPAddress & "'" strSql = strSql & " WHERE " & strDBNTSQLName & " = '" & ChkString(UserName, "SQLString") & "' " my_conn.Execute (strSql),,adCmdText + adExecuteNoRecords end function function chkDate(fDate,separator,fTime) if fDate = "" or isNull(fDate) then if fTime then chkTime(fDate) end if exit function end if select case strDateType case "dmy" chkDate = Mid(fDate,7,2) & "/" & _ Mid(fDate,5,2) & "/" & _ Mid(fDate,1,4) case "mdy" chkDate = Mid(fDate,5,2) & "/" & _ Mid(fDate,7,2) & "/" & _ Mid(fDate,1,4) case "ymd" chkDate = Mid(fDate,1,4) & "/" & _ Mid(fDate,5,2) & "/" & _ Mid(fDate,7,2) case "ydm" chkDate =Mid(fDate,1,4) & "/" & _ Mid(fDate,7,2) & "/" & _ Mid(fDate,5,2) case "dmmy" chkDate = Mid(fDate,7,2) & " " & _ Monthname(Mid(fDate,5,2),1) & " " & _ Mid(fDate,1,4) case "mmdy" chkDate = Monthname(Mid(fDate,5,2),1) & " " & _ Mid(fDate,7,2) & " " & _ Mid(fDate,1,4) case "ymmd" chkDate = Mid(fDate,1,4) & " " & _ Monthname(Mid(fDate,5,2),1) & " " & _ Mid(fDate,7,2) case "ydmm" chkDate = Mid(fDate,1,4) & " " & _ Mid(fDate,7,2) & " " & _ Monthname(Mid(fDate,5,2),1) case "dmmmy" chkDate = Mid(fDate,7,2) & " " & _ Monthname(Mid(fDate,5,2),0) & " " & _ Mid(fDate,1,4) case "mmmdy" chkDate = Monthname(Mid(fDate,5,2),0) & " " & _ Mid(fDate,7,2) & " " & _ Mid(fDate,1,4) case "ymmmd" chkDate = Mid(fDate,1,4) & " " & _ Monthname(Mid(fDate,5,2),0) & " " & _ Mid(fDate,7,2) case "ydmmm" chkDate = Mid(fDate,1,4) & " " & _ Mid(fDate,7,2) & " " & _ Monthname(Mid(fDate,5,2),0) case else chkDate = Mid(fDate,5,2) & "/" & _ Mid(fDate,7,2) & "/" & _ Mid(fDate,1,4) end select if fTime then chkDate = chkDate & separator & chkTime(fDate) end if end function function chkTime(fTime) if fTime = "" or isNull(fTime) then exit function end if if strTimeType = 12 then if cLng(Mid(fTime, 9,2)) > 12 then chkTime = ChkTime & " " & _ (cLng(Mid(fTime, 9,2)) -12) & ":" & _ Mid(fTime, 11,2) & ":" & _ Mid(fTime, 13,2) & " " & "PM" elseif cLng(Mid(fTime, 9,2)) = 12 then chkTime = ChkTime & " " & _ cLng(Mid(fTime, 9,2)) & ":" & _ Mid(fTime, 11,2) & ":" & _ Mid(fTime, 13,2) & " " & "PM" elseif cLng(Mid(fTime, 9,2)) = 0 then chkTime = ChkTime & " " & _ (cLng(Mid(fTime, 9,2)) +12) & ":" & _ Mid(fTime, 11,2) & ":" & _ Mid(fTime, 13,2) & " " & "AM" else chkTime = ChkTime & " " & _ Mid(fTime, 9,2) & ":" & _ Mid(fTime, 11,2) & ":" & _ Mid(fTime, 13,2) & " " & "AM" end if else ChkTime = ChkTime & " " & _ Mid(fTime, 9,2) & ":" & _ Mid(fTime, 11,2) & ":" & _ Mid(fTime, 13,2) end if end function function widenum(fNum) if fNum > 9 then widenum = "" else widenum = " " end if end function '############################################## '## Multi-Moderators ## '############################################## function chkForumModerator(fForum_ID, fMember_Name) '## Forum_SQL strSql = "SELECT mo.FORUM_ID " strSql = strSql & " FROM " & strTablePrefix & "MODERATOR mo, " & strMemberTablePrefix & "MEMBERS me " strSql = strSql & " WHERE mo.FORUM_ID = " & fForum_ID & " " strSql = strSql & " AND mo.MEMBER_ID = me.MEMBER_ID " strSql = strSql & " AND me." & strDBNTSQLName & " = '" & chkString(fMember_Name,"SQLString") & "'" set rsChk = Server.CreateObject("ADODB.Recordset") rsChk.open strSql, my_Conn if rsChk.bof or rsChk.eof then chkForumModerator = "0" else chkForumModerator = "1" end if rsChk.close set rsChk = nothing end function '############################################## '## NT Authentication ## '############################################## sub NTUser() dim strSql dim rs_chk if Session(strCookieURL & "username")="" then '## Forum_SQL strSql ="SELECT MEMBER_ID, M_LEVEL, M_PASSWORD, M_USERNAME, M_NAME " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE M_USERNAME = '" & ChkString(Session(strCookieURL & "userid"), "SQLString") & "'" strSql = strSql & " AND M_STATUS = " & 1 Set rs_chk = Server.CreateObject("ADODB.Recordset") rs_chk.open strSql, my_Conn if rs_chk.BOF or rs_chk.EOF then strLoginStatus = 0 else Session(strCookieURL & "username") = rs_chk("M_NAME") if strSetCookieToForum = 1 then Response.Cookies(strUniqueID & "User").Path = strCookieURL end if Response.Cookies(strUniqueID & "User")("Name") = rs_chk("M_NAME") Response.Cookies(strUniqueID & "User")("Pword") = rs_chk("M_PASSWORD") 'Response.Cookies(strUniqueID & "User")("Cookies") = "" Response.Cookies(strUniqueID & "User").Expires = dateAdd("d", intCookieDuration, strForumTimeAdjust) Session(strCookieURL & "last_here_date") = ReadLastHereDate(Request.Form("Name")) if strAuthType = "nt" then Session(strCookieURL & "last_here_date") = ReadLastHereDate(Session(strCookieURL & "userID")) end if strLoginStatus = 1 mLev = cLng(chkUser(Session(strCookieURL & "userID"), Request.Cookies(strUniqueID & "User")("Pword"),-1)) if mLev = 4 then Session(strCookieURL & "Approval") = "15916941253" end if end if rs_chk.close set rs_chk = nothing end if end sub function chkAccountReg() dim strSql dim rs_chk '## Forum_SQL strSql ="SELECT M_LEVEL, M_USERNAME " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE M_USERNAME = '" & ChkString(Session(strCookieURL & "userid"), "SQLString") & "'" strSql = strSql & " AND M_STATUS = " & 1 Set rs_chk = Server.CreateObject("ADODB.Recordset") rs_chk.open strSql, my_Conn if rs_chk.BOF or rs_chk.EOF then chkAccountReg = "0" else chkAccountReg = "1" end if rs_chk.close set rs_chk = nothing end function sub NTAuthenticate() dim strUser, strNTUser, checkNT strNTUser = Request.ServerVariables("AUTH_USER") strNTUser = replace(strNTUser, "\", "/") if Session(strCookieURL & "userid") = "" then strUser = Mid(strNTUser,(instr(1,strNTUser,"/")+1),len(strNTUser)) Session(strCookieURL & "userid") = strUser end if if strNTGroups="1" then strNTGroupsSTR = Session(strCookieURL & "strNTGroupsSTR") if Session(strCookieURL & "strNTGroupsSTR") = "" then Set strNTUserInfo = GetObject("WinNT://"+strNTUser) For Each strNTUserInfoGroup in strNTUserInfo.Groups strNTGroupsSTR=strNTGroupsSTR+", "+strNTUserInfoGroup.name NEXT Session(strCookieURL & "strNTGroupsSTR") = strNTGroupsSTR end if end if if strAutoLogon="1" then strNTUserFullName = Session(strCookieURL & "strNTUserFullName") if Session(strCookieURL & "strNTUserFullName") = "" then Set strNTUserInfo = GetObject("WinNT://"+strNTUser) strNTUserFullName=strNTUserInfo.FullName Session(strCookieURL & "strNTUserFullName") = strNTUserFullName end if end if end sub '############################################## '## Cookie functions and Subs ## '############################################## sub doCookies(fSavePassWord) if strSetCookieToForum = 1 then Response.Cookies(strUniqueID & "User").Path = strCookieURL else Response.Cookies(strUniqueID & "User").Path = "/" end if Response.Cookies(strUniqueID & "User")("Name") = strDBNTUserName Response.Cookies(strUniqueID & "User")("Pword") = strEncodedPassword 'Response.Cookies(strUniqueID & "User")("Cookies") = Request.Form("Cookies") if fSavePassWord = "true" then Response.Cookies(strUniqueID & "User").Expires = dateAdd("d", intCookieDuration, strForumTimeAdjust) end if Session(strCookieURL & "last_here_date") = ReadLastHereDate(strDBNTFUserName) end sub sub ClearCookies() if strSetCookieToForum = 1 then Response.Cookies(strUniqueID & "User").Path = strCookieURL else Response.Cookies(strUniqueID & "User").Path = "/" end if Response.Cookies(strUniqueID & "User") = "" Session(strCookieURL & "Approval") = "" Session.Abandon 'Response.Cookies(strUniqueID & "User").Expires = dateadd("d", -2, strForumTimeAdjust) end sub '############################################## '## Private Forums ## '############################################## function chkUser(fName, fPassword, fAuthor) dim rsCheck dim strSql '## Forum_SQL strSql = "SELECT MEMBER_ID, M_LEVEL, M_NAME, M_PASSWORD " strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS " strSql = strSql & " WHERE " & strDBNTSQLName & " = '" & ChkString(fName, "SQLString") & "' " if strAuthType="db" then strSql = strSql & " AND M_PASSWORD = '" & ChkString(fPassword, "SQLString") &"'" End If strSql = strSql & " AND M_STATUS = " & 1 Set rsCheck = my_Conn.Execute(strSql) if rsCheck.BOF or rsCheck.EOF or not(ChkQuoteOk(fName)) or not(ChkQuoteOk(fPassword)) then MemberID = -1 chkUser = 0 '## Invalid Password if strDBNTUserName <> "" and chkCookie = 1 then Call ClearCookies() strDBNTUserName = "" end if else MemberID = rsCheck("MEMBER_ID") strDBNTUserName = rsCheck("M_NAME") if (rsCheck("MEMBER_ID") & "" = fAuthor & "") and (cLng(rsCheck("M_LEVEL")) <> 3) then chkUser = 1 '## Author else select case cLng(rsCheck("M_LEVEL")) case 1 chkUser = 2 '## Normal User case 2 chkUser = 3 '## Moderator case 3 chkUser = 4 '## Admin case else chkUser = cLng(rsCheck("M_LEVEL")) end select end if end if rsCheck.close set rsCheck = nothing end function Function ReplaceURLs(ByVal strToFormat) Dim oTag, c1Tag, oTag2, c2Tag Dim roTag, rc1Tag, rc2Tag Dim oTagPos, c1TagPos, oTagPos2, c1TagPos2 Dim Counter Dim strArray, strArray2 Dim strFirstPart, strSecondPart oTag = "[url=""" c1Tag = """]" oTag2 = "[url]" c2Tag = "[/url]" roTag = "" rc2Tag = "" oTagPos = InStr(1, strToFormat, oTag, 1) 'Position of opening tag c1TagPos = InStr(1, strToFormat, c1Tag, 1) 'Position of closing tag 'if opening tag and closing tag is found... If (oTagpos > 0) And (c1TagPos > 0) Then 'Split string at the opening tag strArray = Split(strToFormat, oTag, -1, 1) 'Loop through array For Counter = 0 To UBound(strArray) 'if the closing tag is found in the string then... If (InStr(1, strArray(Counter), c1Tag, 1) > 0) Then 'split string at the closing tag... strArray2 = Split(strArray(Counter), c1Tag, -1, 1) strArray2(0) = replace(strArray2(0), """", " ") ' ## filter out " 'strArray2(0) = replace(strArray2(0), "&", " ", 1, -1, 1) ' ## filter out & 'strArray2(0) = replace(strArray2(0), "#", " ", 1, -1, 1) ' ## filter out # strArray2(0) = replace(strArray2(0), ";", " ", 1, -1, 1) ' ## filter out ; strArray2(0) = replace(strArray2(0), "+", " ", 1, -1, 1) ' ## filter out + strArray2(0) = replace(strArray2(0), "(", " ", 1, -1, 1) ' ## filter out ( strArray2(0) = replace(strArray2(0), ")", " ", 1, -1, 1) ' ## filter out ) 'strArray2(0) = replace(strArray2(0), "[", " ", 1, -1, 1) ' ## filter out [ 'strArray2(0) = replace(strArray2(0), "]", " ", 1, -1, 1) ' ## filter out ] 'strArray2(0) = replace(strArray2(0), "=", " ", 1, -1, 1) ' ## filter out = strArray2(0) = replace(strArray2(0), "*", " ", 1, -1, 1) ' ## filter out * strArray2(0) = replace(strArray2(0), "'", " ", 1, -1, 1) ' ## filter out ' strArray2(0) = replace(strArray2(0), ">", " ", 1, -1, 1) ' ## filter out > strArray2(0) = replace(strArray2(0), "<", " ", 1, -1, 1) ' ## filter out < strArray2(0) = replace(strArray2(0), vbTab, " ", 1, -1, 1) ' ## filter out Tabs strArray2(0) = replace(strArray2(0), "view-source", " ", 1, -1, 1) ' ## filter out view-source strArray2(0) = replace(strArray2(0), "javascript", " ", 1, -1, 1) ' ## filter out javascript strArray2(0) = replace(strArray2(0), "jscript", " ", 1, -1, 1) ' ## filter out jscript strArray2(0) = replace(strArray2(0), "vbscript", " ", 1, -1, 1) ' ## filter out vbscript 'if the closing url tag is found in the string and '[URL] is not found in the string then... If InStr(1, strArray2(1), c2Tag, 1) And _ Not InStr(1, UCase(strArray2(1)), "[URL]", 1) Then strFirstPart = Left(strArray2(1), InStr(1, strArray2(1), c2Tag, 1)-1) strSecondPart = Right(strArray2(1), (Len(strArray2(1)) - Instr(1, strArray2(1), c2Tag,1) - len(c2Tag)+1)) If strFirstPart <> "" Then If UCase(Left(strFirstPart, 5)) = "[IMG]" Then ReplaceURLs = ReplaceURLs & "" & strFirstPart & "" & strSecondPart ElseIf UCase(Left(strArray2(0), 7)) = "HTTP://" Then 'ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 1) & strSecondPart ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart ElseIf UCase(Left(strArray2(0), 8)) = "HTTPS://" Then 'ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 2) & strSecondPart ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart ElseIf UCase(Left(strArray2(0), 4)) = "WWW." Then 'ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 3) & strSecondPart ReplaceURLs = ReplaceURLs & roTag & "http://" & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart ElseIf UCase(Left(strArray2(0), 7)) = "MAILTO:" Then 'ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 4) & strSecondPart ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart ElseIf UCase(Left(strArray2(0), 6)) = "FTP://" Then 'ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 5) & strSecondPart ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart ElseIf InStr(strArray2(0), "@") > 0 Then 'ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 4) & strSecondPart ReplaceURLs = ReplaceURLs & roTag & "mailto:" & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart ElseIf UCase(Left(strArray2(0), 6)) = "FILE:///" Then ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart Else ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart End If Else If UCase(Left(strArray2(0), 7)) = "HTTP://" Then ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 1) & strSecondPart 'ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart ElseIf UCase(Left(strArray2(0), 8)) = "HTTPS://" Then ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 2) & strSecondPart 'ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart ElseIf UCase(Left(strArray2(0), 4)) = "WWW." Then ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 3) & strSecondPart 'ReplaceURLs = ReplaceURLs & roTag & "http://" & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart ElseIf UCase(Left(strArray2(0), 7)) = "MAILTO:" Then ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 4) & strSecondPart 'ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart ElseIf UCase(Left(strArray2(0), 6)) = "FTP://" Then ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 5) & strSecondPart 'ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart ElseIf InStr(strArray2(0), "@") > 0 Then ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 4) & strSecondPart 'ReplaceURLs = ReplaceURLs & roTag & "mailto:" & strArray2(0) & rc1Tag & strFirstPart & rc2Tag & strSecondPart ElseIf UCase(Left(strArray2(0), 6)) = "FILE:///" Then ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strArray2(0) & rc2Tag & strSecondPart Else ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strArray2(0) & rc2Tag & strSecondPart End If End If Else ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strArray2(0) & rc2Tag & strArray2(1) End If Else ReplaceURLs = ReplaceURLs & strArray(Counter) End If Next Else ReplaceURLs = strToFormat End If oTagPos2 = InStr(1, ReplaceURLs, oTag2, 1) c1TagPos2 = InStr(1, ReplaceURLs, c2Tag, 1) 'if opening tag and closing tag is found then... If (oTagpos2 > 0) And (c1TagPos2 > 0) Then 'split string at opening tag strArray = Split(ReplaceURLs, oTag2, -1, 1) ReplaceURLs = "" For Counter = 0 To Ubound(strArray) 'if closing url tag is found in string then... If InStr(1, strArray(Counter), c2Tag, 1) > 0 Then 'split string at closing url tag strArray2 = Split(strArray(Counter), c2Tag, -1, 1) strArray2(0) = replace(strArray2(0), """", " ") ' ## filter out " 'strArray2(0) = replace(strArray2(0), "&", " ", 1, -1, 1) ' ## filter out & 'strArray2(0) = replace(strArray2(0), "#", " ", 1, -1, 1) ' ## filter out # strArray2(0) = replace(strArray2(0), ";", " ", 1, -1, 1) ' ## filter out ; strArray2(0) = replace(strArray2(0), "+", " ", 1, -1, 1) ' ## filter out + strArray2(0) = replace(strArray2(0), "(", " ", 1, -1, 1) ' ## filter out ( strArray2(0) = replace(strArray2(0), ")", " ", 1, -1, 1) ' ## filter out ) 'strArray2(0) = replace(strArray2(0), "[", " ", 1, -1, 1) ' ## filter out [ 'strArray2(0) = replace(strArray2(0), "]", " ", 1, -1, 1) ' ## filter out ] 'strArray2(0) = replace(strArray2(0), "=", " ", 1, -1, 1) ' ## filter out = strArray2(0) = replace(strArray2(0), "*", " ", 1, -1, 1) ' ## filter out * strArray2(0) = replace(strArray2(0), "'", " ", 1, -1, 1) ' ## filter out ' strArray2(0) = replace(strArray2(0), ">", " ", 1, -1, 1) ' ## filter out > strArray2(0) = replace(strArray2(0), "<", " ", 1, -1, 1) ' ## filter out < strArray2(0) = replace(strArray2(0), vbTab, " ", 1, -1, 1) ' ## filter out Tabs strArray2(0) = replace(strArray2(0), "view-source", " ", 1, -1, 1) ' ## filter out view-source strArray2(0) = replace(strArray2(0), "javascript", " ", 1, -1, 1) ' ## filter out javascript strArray2(0) = replace(strArray2(0), "jscript", " ", 1, -1, 1) ' ## filter out jscript strArray2(0) = replace(strArray2(0), "vbscript", " ", 1, -1, 1) ' ## filter out vbscript If UCase(Left(strArray2(0), 7)) = "HTTP://" Then ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 1) & strArray2(1) ElseIf UCase(Left(strArray2(0), 8)) = "HTTPS://" Then ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 2) & strArray2(1) ElseIf UCase(Left(strArray2(0), 4)) = "WWW." Then ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 3) & strArray2(1) ElseIf UCase(Left(strArray2(0), 7)) = "MAILTO:" Then 'ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 4) & strArray2(1) ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strArray2(0) & rc2Tag & strArray2(1) ElseIf UCase(Left(strArray2(0), 6)) = "FTP://" Then ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 5) & strArray2(1) ElseIf InStr(strArray2(0), "@") > 0 Then ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 4) & strArray2(1) ElseIf UCase(Left(strArray2(0), 6)) = "FILE:///" Then ReplaceURLs = ReplaceURLs & edit_hrefs(strArray2(0), 7) & strArray2(1) Else ReplaceURLs = ReplaceURLs & roTag & strArray2(0) & rc1Tag & strArray2(0) & rc2Tag & strArray2(1) End If Else ReplaceURLs = ReplaceURLs & strArray(Counter) End If Next End If End Function function isAllowedMember(fForum_ID,fMemberID) if fMemberID <> MemberID then isAllowedMember = OldisAllowedMember(fForum_ID,fMemberID) exit function end if if Session(strCookieURL & "AllowedForums" & MemberID) = "" or IsNull(Session(strCookieURL & "AllowedForums" & MemberID)) then strSql = "SELECT FORUM_ID FROM " & strTablePrefix & "ALLOWED_MEMBERS " strSql = strSql & " WHERE MEMBER_ID = " & cLng(fMemberID) Set rsAllowedMember = Server.CreateObject("ADODB.Recordset") rsAllowedMember.open strSql, my_Conn, adOpenForwardOnly, adLockReadOnly, adCmdText if (rsAllowedMember.EOF or rsAllowedMember.BOF) then isAllowedMember2 = "-1" Session(strCookieURL & "AllowedForums" & MemberID) = isAllowedMember2 Session(strCookieURL & "AllowedForums" & MemberID) = isAllowedMember2 else arrAllowedForums = rsAllowedMember.GetRows(adGetRowsRest) For AllowCount = 0 to ubound(arrAllowedForums,2) ' Total Numer of Rows if AllowCount = 0 then isAllowedMember2 = arrAllowedForums(0,AllowCount) else isAllowedMember2 = isAllowedMember2 & "," & arrAllowedForums(0,AllowCount) end if next Session(strCookieURL & "AllowedForums" & MemberID) = isAllowedMember2 Session(strCookieURL & "AllowedForums" & MemberID) = isAllowedMember2 end if rsAllowedMember.close set rsAllowedMember = nothing end if if Session(strCookieURL & "AllowedForums" & MemberID) = "-1" then isAllowedMember = 0 elseif InStr("," & Session(strCookieURL & "AllowedForums" & MemberID) & ",","," & fForum_ID & ",") then isAllowedMember = 1 else isAllowedMember = 0 end if end function function OldisAllowedMember(fForum_ID,fMemberID) OldisAllowedMember = 0 strSql = "SELECT MEMBER_ID, FORUM_ID FROM " & strTablePrefix & "ALLOWED_MEMBERS " strSql = strSql & " WHERE FORUM_ID = " & cLng(fForum_ID) strSql = strSql & " AND MEMBER_ID = " & cLng(fMemberID) Set rsAllowedMember = Server.CreateObject("ADODB.Recordset") rsAllowedMember.open strSql, my_Conn if (rsAllowedMember.EOF or rsAllowedMember.BOF) then OldisAllowedMember = 0 rsAllowedMember.close set rsAllowedMember = nothing exit function else OldisAllowedMember = 1 rsAllowedMember.close set rsAllowedMember = nothing end if end function Function ReplaceImageTags(fString) Dim oTag, cTag Dim roTag, rcTag Dim oTagPos, cTagPos Dim nTagPos Dim counter1, counter2, counter3 Dim strUrlText Dim Tagcount Dim strTempString, strResultString TagCount = 6 Dim ImgTags(6,2,2) Dim strArray, strArray2 ImgTags(1,1,1) = "[img]" ImgTags(1,2,1) = "[/img]" ImgTags(1,1,2) = "" ImgTags(2,1,1) = "[image]" ImgTags(2,2,1) = "[/image]" ImgTags(2,1,2) = ImgTags(1,1,2) ImgTags(2,2,2) = ImgTags(1,2,2) ImgTags(3,1,1) = "[img=right]" ImgTags(3,2,1) = "[/img=right]" ImgTags(3,1,2) = "" ImgTags(4,1,1) = "[image=right]" ImgTags(4,2,1) = "[/image=right]" ImgTags(4,1,2) = ImgTags(3,1,2) ImgTags(4,2,2) = ImgTags(3,2,2) ImgTags(5,1,1) = "[img=left]" ImgTags(5,2,1) = "[/img=left]" ImgTags(5,1,2) = "" ImgTags(6,1,1) = "[image=left]" ImgTags(6,2,1) = "[/image=left]" ImgTags(6,1,2) = ImgTags(5,1,2) ImgTags(6,2,2) = ImgTags(5,2,2) strResultString = "" strTempString = fString for counter1 = 1 to TagCount oTag = ImgTags(counter1,1,1) roTag = ImgTags(counter1,1,2) cTag = ImgTags(counter1,2,1) rcTag = ImgTags(counter1,2,2) oTagPos = InStr(1, strTempString, oTag, 1) cTagPos = InStr(1, strTempString, cTag, 1) if (oTagPos > 0) and (cTagPos > oTagPos) then strArray = Split(strTempString, oTag, -1, 1) for counter2 = 0 to Ubound(strArray) if (Instr(1, strArray(counter2), cTag, 1) > 0) then strArray2 = split(strArray(counter2), cTag, -1, 1) strUrlText = trim(strArray2(0)) strUrlText = replace(strUrlText, """", " ") ' ## filter out " '## Added to exclude Javascript and other potentially hazardous characters strUrlText = replace(strUrlText, "&", " ", 1, -1, 1) ' ## filter out & strUrlText = replace(strUrlText, "#", " ", 1, -1, 1) ' ## filter out # strUrlText = replace(strUrlText, ";", " ", 1, -1, 1) ' ## filter out ; strUrlText = replace(strUrlText, "+", " ", 1, -1, 1) ' ## filter out + strUrlText = replace(strUrlText, "(", " ", 1, -1, 1) ' ## filter out ( strUrlText = replace(strUrlText, ")", " ", 1, -1, 1) ' ## filter out ) strUrlText = replace(strUrlText, "[", " ", 1, -1, 1) ' ## filter out [ strUrlText = replace(strUrlText, "]", " ", 1, -1, 1) ' ## filter out ] strUrlText = replace(strUrlText, "=", " ", 1, -1, 1) ' ## filter out = strUrlText = replace(strUrlText, "*", " ", 1, -1, 1) ' ## filter out * strUrlText = replace(strUrlText, "'", " ", 1, -1, 1) ' ## filter out ' strUrlText = replace(strUrlText, vbTab, " ", 1, -1, 1) ' ## filter out Tabs strUrlText = replace(strUrlText, "view-source", " ", 1, -1, 1) ' ## filter out view-source strUrlText = replace(strUrlText, "javascript", " ", 1, -1, 1) ' ## filter out javascript strUrlText = replace(strUrlText, "jscript", " ", 1, -1, 1) ' ## filter out jscript strUrlText = replace(strUrlText, "vbscript", " ", 1, -1, 1) ' ## filter out vbscript strUrlText = replace(strUrlText, "mailto", " ", 1, -1, 1) ' ## filter out mailto '## End Added strUrlText = replace(strUrlText, "<", " ") ' ## filter out < strUrlText = replace(strUrlText, ">", " ") ' ## filter out > strResultString = strResultString & roTag & strUrlText & rcTag & strArray2(1) for counter3 = 2 to UBound(strArray2) strResultString = strResultString & strArray2(counter3) next else strResultString = strResultString & strArray(counter2) end if next strTempString = strResultString strResultString = "" end if next ReplaceImageTags = strTempString end function Function ReplaceCodeTags(fString) Dim oTag, cTag Dim roTag, rcTag Dim oTagPos, cTagPos Dim nTagPos Dim counter1, counter2 Dim strCodeText Dim Tagcount Dim strTempString, strResultString TagCount = 1 Dim CodeTags(1,2,2) Dim strArray, strArray2 CodeTags(1,1,1) = "[code]" CodeTags(1,2,1) = "[/code]" CodeTags(1,1,2) = "
    "
     	CodeTags(1,2,2) = "
    " strResultString = "" strTempString = fString for counter1 = 1 to TagCount oTag = CodeTags(counter1,1,1) roTag = CodeTags(counter1,1,2) cTag = CodeTags(counter1,2,1) rcTag = CodeTags(counter1,2,2) oTagPos = InStr(1, strTempString, oTag, 1) cTagPos = InStr(1, strTempString, cTag, 1) if (oTagpos > 0) and (cTagPos > 0) then strArray = Split(strTempString, oTag, -1, 1) for counter2 = 0 to Ubound(strArray) if (Instr(1, strArray(counter2), cTag) > 0) then strArray2 = split(strArray(counter2), cTag, -1, 1) strCodeText = trim(strArray2(0)) strCodeText = replace(strCodeText, "
    ", vbNewLine) strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1) else strResultString = strResultString & strArray(counter2) end if next strTempString = strResultString strResultString = "" end if next ReplaceCodeTags = strTempString end function '############################################## '## Page Title ## '############################################## Function GetNewTitle(strTempScriptName) Dim StrTempScript Dim strNewTitle arrTempScript = Split(strTempScriptName, "/") strTempScript = arrTempScript(Ubound(arrTempScript)) strTempScript = lcase(strTempScript) Select Case strTempScript Case "topic.asp" strTempTopic = cLng(request.querystring("TOPIC_ID")) if strTempTopic <> 0 then strsql = "SELECT FORUM_ID, T_SUBJECT FROM " & strActivePrefix & "TOPICS WHERE TOPIC_ID=" & strTempTopic set ttopics = my_conn.execute(strsql) if ttopics.bof or ttopics.eof then GetNewTitle = strForumTitle set ttopics = nothing else if mLev = 4 then ForumChkSkipAllowed = 1 elseif mLev = 3 then if chkForumModerator(ttopics("FORUM_ID"), ChkString(strDBNTUserName, "decode")) = "1" then ForumChkSkipAllowed = 1 else ForumChkSkipAllowed = 0 end if else ForumChkSkipAllowed = 0 end if intShowTopicTitle = 1 if strPrivateForums = "1" and ForumChkSkipAllowed = 0 then if not(chkForumAccess(ttopics("FORUM_ID"),MemberID,false)) then intShowTopicTitle = 0 end if end if if intShowTopicTitle = 1 then strTempTopicTitle = " - " & chkString(ttopics("T_SUBJECT"),"display") set ttopics = nothing strNewTitle = strForumTitle & strTempTopicTitle end if else GetNewTitle = strForumTitle end if Case "forum.asp" strTempForum = cLng(request.querystring("FORUM_ID")) if strTempForum <> 0 then strsql = "SELECT F_SUBJECT FROM " & strTablePrefix & "FORUM WHERE FORUM_ID=" & strTempForum set tforums = my_conn.execute(strsql) if tforums.bof or tforums.eof then strNewTitle = strForumTitle set tforums = nothing else strTempForumTitle = chkString(tforums("F_SUBJECT"),"display") set tforums = nothing strNewTitle = strForumTitle & " - " & strTempForumTitle end if else strNewTitle = strForumTitle end if Case "members.asp" strNewTitle = strForumTitle & " - Members" Case "active.asp" strNewTitle = strForumTitle & " - Active Topics" Case "faq.asp" strNewTitle = strForumTitle & " - Frequently Asked Questions" Case "search.asp" strNewTitle = strForumTitle & " - Search" Case "pop_profile.asp" if request.querystring("mode") = "display" then strNewTitle = strForumTitle & " - View Profile" elseif request.querystring("mode") = "edit" then strNewTitle = strForumTitle & " - Edit Profile" else strNewTitle = strForumTitle & " - Profile" end if Case "register.asp" strNewTitle = strForumTitle & " - User Agreement and Registration" Case "down.asp" strNewTitle = strForumTitle & " is currently closed." Case "default.asp" strNewTitle = strForumTitle Case else strNewTitle = strForumTitle End Select GetNewTitle = strNewTitle End Function '## Function to limit the amount of records to retrieve from the database Function TopSQL(strSQL, lngRecords) if ucase(left(strSQL,7)) = "SELECT " then select case strDBType case "sqlserver" TopSQL = "SET ROWCOUNT " & lngRecords & vbNewLine & strSQL & vbNewLine & "SET ROWCOUNT 0" case "access" TopSQL = "SELECT TOP " & lngRecords & mid(strSQL,7) case "mysql" if instr(strSQL,";") > 0 then strSQL1 = Mid(strSQL, 1, Instr(strSQL, ";")-1) strSQL2 = Mid(strSQL, InstrRev(strSQL, ";")) TopSQL = strSQL1 & " LIMIT " & lngRecords & strSQL2 else TopSQL = strSQL & " LIMIT " & lngRecords end if end select else TopSQL = strSQL end if End Function Function sGetColspan(lIN, lOUT) if (strShowModerators = "1") then lOut = lOut + 1 if (mlev = "4" or mlev = "3") and (strShowModerators = "1") then lOut = lOut + 1 if (mlev = "4" or mlev = "3") and (strShowModerators <> "1") then lOut = lOut + 2 if lOut > lIn then sGetColspan = lIN else sGetColspan = lOUT end if End Function function dWStatus(strMsg) dWStatus = " onMouseOver=""(window.status='" & Replace(strMsg, "'", "\'") & "'); return true"" onMouseOut=""(window.status=''); return true""" end function function profileLink(fName, fID) if instr(fName,"img src=") > 0 then strExtraStuff = "" else strExtraStuff = " title=""View " & fName & "'s Profile""" & dWStatus("View " & fName & "'s Profile") end if if strUseExtendedProfile then strReturn = "" else strReturn = "" end if profileLink = strReturn & fName & "" end function function chkSelect(actualValue, thisValue) if isNumeric(actualValue) then actualValue = cLng(actualValue) if actualValue = thisValue then chkSelect = " selected" else chkSelect = "" end if end function function chkExist(actualValue) if trim(actualValue) <> "" then chkExist = actualValue else chkExist = "" end if end function function chkExistElse(actualValue, elseValue) if trim(actualValue) <> "" then chkExistElse = actualValue else chkExistElse = elseValue end if end function function chkRadio(actualValue, thisValue, boltf) if isNumeric(actualValue) then actualValue = cLng(actualValue) if actualValue = thisValue EQV boltf then chkRadio = " checked" else chkRadio = "" end if end function function chkCheckbox(actualValue, thisValue, boltf) if isNumeric(actualValue) then actualValue = cLng(actualValue) if actualValue = thisValue EQV boltf then chkCheckbox = " checked" else chkCheckbox = "" end if end function function InArray(strArray,strValue) if strArray <> "" and strArray <> "0" then if (instr("," & strArray & "," ,"," & strValue & ",") > 0) then InArray = True exit function end if end if InArray = False end function function oldInArray(strArray,strValue) if IsArray(strArray) then Dim Ix for Ix = 0 To UBound(strArray) if cLng(strArray(Ix)) = cLng(strValue) then oldInArray = True exit function end if next end if oldInArray = False end function Sub WriteFooter() %> <% end sub Sub WriteFooterShort() %> <% end sub %>