<%
'#################################################################################
'## Ver.3.4.07 multi-language Skin3D Portal V2
'#################################################################################
'## Copyright (C) 2001-09 Gaëtan Dupont All Rights Reserved
'##
'## By using this program, you are agreeing to the terms of the
'## GNU General Public License.
'##
'## 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 ImageForums2001 must remain intact
'## in the scripts and in the outputted HTML.
'## The "Image Forums 2001" text with a link back to
'## http://www.forums2001.ca in the footer of the pages MUST
'## remain visible when the pages are viewed on the internet or intranet.
'##
'## Support can be obtained from support forums at:
'## http://www.forums2001.ca
'##
'## Email: image_forum_2001@hotmail.com
'##
'#################################################################################
'## This Page Contains source code of Snitz Forums 2000
'#################################################################################
'## Snitz Forums 2000 v3.4.07
'#################################################################################
'## Copyright (C) 2000-09 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
'##
'#################################################################################
%>
<%
Randomize
'####################################
'## Mod Skin ##
'####################################
sub WriteStyleCss(intStylesCss,getStyles)
strSql = "SELECT C_VALUE "
strSql = strSql & "FROM " & strTablePrefix & "CONFIG_MODS "
strSql = strSql & "WHERE C_VARIABLE = 'strStylesCss'"
Set rs = my_conn.execute (strSql)
if rs.EOF then
intStylesCss = 0
else
intStylesCss = cLng(rs("C_VALUE"))
end if
rs.Close
Set rs = nothing
select case intStylesCss
case "0"
call StyleCss()
case "1"
strSql = "SELECT M_THEME "
strSql = strSql & "FROM " & strMemberTablePrefix & "MEMBERS "
strSql = strSql & "WHERE MEMBER_ID = " & MemberID
Set rsTheme = my_Conn.Execute(strSql)
if rsTheme.EOF then
getStyles = 0
else
getStyles = cLng(rsTheme("M_THEME"))
end if
rsTheme.Close
Set rsTheme = nothing
select case getStyles
case "1"
call StyleCss()
case "2"
if strStylesCss = "1" and getStyles = "2" then
%><!--#INCLUDE FILE="inc_members_config.asp" --><%
end if
call SnitzValue()
case else
call StyleCss()
end select
'case else
'call StyleCss()
end select
end sub
sub StyleCss()
AltForumCellColor = "class=""strPopUpTableColor"""
AltForumCellColor1 = "class=""strForumCellColor"""
AltForumCellColor2 = "class=""strAltForumCellColor"""
AltForumCellColor3 = "class=""strAltForumCellColor1"""
AltForumCellColor4 = "class=""strAltForumCellColor2"""
Border = "border=""0"""
CategoryCellColor = "class=""strCategoryCellColor"""
CategoryCellColor1 = "class=""strCategoryCellColor1"""
CategoryCellColor2 = "class=""strCategoryCellColor2"""
CategoryFontColor = "color="""""
Cellspacing = "cellspacing=""0"""
DefaultFontColor = ""
ForumCellColor = "class=""strForumCellColor"""
ForumCellColor1 = "class=""strForumCellColor1"""
ForumCellColor2 = "class=""strForumCellColor2"""
ForumCellColor3 = "class=""strForumCellColor3"""
ForumCellColor4 = "class=""strForumCellColor4"""
ForumCellColor5 = "class=""strForumCellColor5"""
ForumCellColor6 = "class=""strForumCellColor6"""
ForumCellColor7 = "class=""strForumCellColor7"""
ForumCellColor8 = "class=""strForumCellColor8"""
ForumCellColor9 = "class=""strForumCellColor9"""
ForumCellColor10 = "class=""strForumCellColor10"""
ForumCellColor11 = "class=""strForumCellColor11"""
ForumCellColor12 = "class=""strForumCellColor12"""
ForumCellColor13 = "class=""strForumCellColor13"""
ForumCellColor14 = "class=""strPopUpTableColor2"""
ForumColorShadow = "class=""strForumCellColor6"""
ForumColorShadow1 = "class=""strForumCellColor6"""
ForumFirstCellColor = "class=""strForumCellColor"""
ForumFirstCellColor2 = "class=""strForumCellColor10"""
ForumFirstCellColor3 = ""
ForumFontColor =""
HeadCellColor = "class=""strHeadCellColor"""
HeadCellColor2 = "class=""strHeadCellColor2"""
HeadCellColor3 = "class=""strHeadCellColor3"""
HeadCellColor4 = "class=""strHeadCellColor4"""
HeadCellColor5 = "class=""strHeadCellColor5"""
HeadFontColor = ""
PageBGColor = ""
PageBGColor1 = "class=""strPageBGColor"""
PageBGColor2 = "class=""strForumCellColor12"""
PopUpBorderColor = ""
PopUpTableColor = "class=""strPopUpTableColor"""
PopUpTableColor1 = "class=""strPopUpTableColor1"""
PopUpTableColor2 = "class=""strPopUpTableColor2"""
PopUpTableColor3 = "class=""strPopUpTableColor3"""
TableBorderColor = ""
TableBorderColor1 = "class=""strForumCellColor3"""
end sub
sub SnitzValue()
AltForumCellColor = "bgcolor=""" & strAltForumCellColor & """"
AltForumCellColor1 = "bgcolor=""" & strAltForumCellColor & """"
AltForumCellColor2 = "bgcolor=""" & strAltForumCellColor & """"
AltForumCellColor3 = "bgcolor=""" & strAltForumCellColor & """"
AltForumCellColor4 = "bgcolor=""" & strAltForumCellColor & """"
if strCategoryCellBGImageURL = "" then
CategoryCellColor = "bgcolor=""" & strCategoryCellColor & """"
CategoryCellColor1 = ""
CategoryCellColor2 = "bgcolor=""" & strCategoryCellColor & """"
elseif Instr(strCategoryCellBGImageURL,"/") > 0 or Instr(strCategoryCellBGImageURL,"\") > 0 then
CategoryCellColor = "bgcolor=""" & strCategoryCellColor & """ background=""" & strCategoryCellBGImageURL & """"
CategoryCellColor1 = ""
CategoryCellColor2 = "bgcolor=""" & strCategoryCellColor & """ background=""" & strCategoryCellBGImageURL & """"
else
CategoryCellColor = "bgcolor=""" & strCategoryCellColor & """ background=""" & strImageUrl & strCategoryCellBGImageURL & """"
CategoryCellColor1 = ""
CategoryCellColor2 = "bgcolor=""" & strCategoryCellColor & """ background=""" & strImageUrl & strCategoryCellBGImageURL & """"
end if
CategoryFontColor = "color=""" & strCategoryFontColor & """"
Border = "border=""1"""
Cellspacing = "cellspacing=""1"""
DefaultFontColor = "color=""" & strDefaultFontColor & """"
ForumCellColor = "bgcolor=""" & strForumCellColor & """"
ForumCellColor1 = "bgcolor=""" & strForumCellColor & """"
ForumCellColor2 = "bgcolor=""" & strForumCellColor & """"
ForumCellColor3 = "bgcolor=""" & strForumCellColor & """"
ForumCellColor4 = "bgcolor=""" & strForumCellColor & """"
ForumCellColor5 = ""
ForumCellColor6 = "bgcolor=""" & strForumCellColor & """"
ForumCellColor7 = "bgcolor=""" & strForumCellColor & """"
ForumCellColor8 = "bgcolor=""" & strForumCellColor & """"
ForumCellColor9 = "bgcolor=""" & strForumCellColor & """"
ForumCellColor10 = "bgcolor=""" & strForumCellColor & """"
ForumCellColor11 = "bgcolor=""" & strForumCellColor & """"
ForumCellColor12 = "bgcolor=""" & strForumCellColor & """"
ForumCellColor13 = "bgcolor=""" & strForumCellColor & """"
ForumCellColor14 = "bgcolor=""" & strForumCellColor & """"
ForumColorShadow = ""
ForumColorShadow1 = "bgColor=""" & strPopUpTableColor & """"
ForumFirstCellColor = "bgcolor=""" & strForumFirstCellColor & """"
ForumFirstCellColor2 = "bgcolor=""" & strForumFirstCellColor & """"
ForumFirstCellColor3 = "color=""" & strForumFirstCellColor & """"
ForumFontColor ="color=""" & strForumFontColor & """"
if strHeadCellBGImageURL = "" then
HeadCellColor = "bgcolor=""" & strHeadCellColor & """"
HeadCellColor2 = "bgcolor=""" & strHeadCellColor & """"
HeadCellColor3 = "bgcolor=""" & strHeadCellColor & """"
HeadCellColor4 = "bgcolor=""" & strHeadCellColor & """"
elseif Instr(strHeadCellBGImageURL,"/") > 0 or Instr(strHeadCellBGImageURL,"\") > 0 then
HeadCellColor = "bgcolor=""" & strHeadCellColor & """ background=""" & strHeadCellBGImageURL & """"
HeadCellColor2 = "bgcolor=""" & strHeadCellColor & """ background=""" & strHeadCellBGImageURL & """"
HeadCellColor3 = "bgcolor=""" & strHeadCellColor & """ background=""" & strHeadCellBGImageURL & """"
HeadCellColor4 = "bgcolor=""" & strHeadCellColor & """ background=""" & strHeadCellBGImageURL & """"
else
HeadCellColor = "bgcolor=""" & strHeadCellColor & """ background=""" & strImageUrl & strHeadCellBGImageURL & """"
HeadCellColor2 = "bgcolor=""" & strHeadCellColor & """ background=""" & strImageUrl & strHeadCellBGImageURL & """"
HeadCellColor3 = "bgcolor=""" & strHeadCellColor & """ background=""" & strImageUrl & strHeadCellBGImageURL & """"
HeadCellColor4 = "bgcolor=""" & strHeadCellColor & """ background=""" & strImageUrl & strHeadCellBGImageURL & """"
end if
HeadCellColor5 = ""
HeadFontColor = "color=""" & strHeadFontColor & """"
PageBGColor = "bgColor=""" & strPageBGColor & """"
PageBGColor1 = "bgColor=""" & strPageBGColor & """"
PageBGColor2 = "bgColor=""" & strPageBGColor & """"
PopUpBorderColor = "bgcolor=""" & strPopUpBorderColor & """"
PopUpTableColor = "bgColor=""" & strPopUpTableColor & """"
PopUpTableColor1 = "bgColor=""" & strPopUpTableColor & """"
PopUpTableColor2 = "bgColor=""" & strPopUpTableColor & """"
PopUpTableColor3 = ""
TableBorderColor = "bgcolor=""" & strTableBorderColor & """"
TableBorderColor1 = "bgcolor=""" & strTableBorderColor & """"
end sub
function GetAge(dtBirthdate)
Dim dtToday
Dim iAge
dtToday = date()
iAge = Year(dtToday) - Year(dtBirthdate)
if (Month(dtToday) * 100 + Day(dtToday)) < (Month(dtBirthdate) * 100 + Day(dtBirthdate)) then iAge = iAge -1
GetAge = iAge
end function
function GuestIP(Topic_ID,rMode,rValue)
' rMode: 0 - get ip, 1 - by topic_id, 2 - by reply_id, 3 - by topic_replies
Dim rsGuestIP, gIP
if rMode = "0" and Topic_ID = "0" then
'gIP = Request.ServerVariables("REMOTE_ADDR")
gIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
if gIP = "" or Left(gIP , 7) = "unknown" then
gIP = Request.ServerVariables("REMOTE_ADDR")
elseif InStr(gIP, ",") > 0 then
gIP = Left(gIP, InStr(gIP, ",")-1)
elseif InStr(gIP, ";") > 0 then
gIP = Left(gIP, InStr(gIP, ";")-1)
end if
if InStr(gIP, ":") > 0 then
gIP= Left(gIP, InStr(gIP, ":")-1)
end if
' if (Request.ServerVariables("HTTP_CLIENT_IP") <> "") and (lcase(Request.ServerVariables("HTTP_CLIENT_IP")) <> "unknown") then
' gIP = Request.ServerVariables("HTTP_CLIENT_IP")
' else
' if (Request.ServerVariables("HTTP_X_FORWARDED_FOR") <> "") and (lcase(Request.ServerVariables("HTTP_X_FORWARDED_FOR")) <> "unknown") then
' gIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
' else
' if (Request.ServerVariables("REMOTE_ADDR") <> "") and (lcase(Request.ServerVariables("REMOTE_ADDR")) <> "unknown") then
' gIP = Request.ServerVariables("REMOTE_ADDR")
' else
' gIP = "999.999.999.999"
' end if
' end if
' end if
else
if (rMode = "1" and Topic_ID <> "0") or (rMode = "3" and rValue = 0) then
strSql = "SELECT T_IP "
strSql = strSql & "FROM " & strTablePrefix & "TOPICS "
strSql = strSql & "WHERE TOPIC_ID = " & Topic_ID
Set rsGuestIP = my_Conn.Execute(strSql)
gIP = rsGuestIP("T_IP")
elseif rMode = "2" and rValue <> "0" then
strSql = "SELECT R_IP "
strSql = strSql & "FROM " & strTablePrefix & "REPLY "
strSql = strSql & "WHERE REPLY_ID = " & rValue
Set rsGuestIP = my_Conn.Execute(strSql)
gIP = rsGuestIP("R_IP")
elseif rMode = "3" and rValue > 0 then
strSql = "SELECT R_IP "
strSql = strSql & "FROM " & strTablePrefix & "REPLY "
strSql = strSql & "WHERE TOPIC_ID = " & Topic_ID & " "
strSql = strSql & "ORDER BY R_DATE DESC"
Set rsGuestIP = my_Conn.Execute(TopSQL(strSql,1))
gIP = rsGuestIP("R_IP")
else
GuestIP = "????"
exit function
end if
Set rsGuestIP = nothing
end if
IPnumber = split(gIP, ".")
GuestIP = ""
for i = 0 to ubound(IPnumber)
GuestIP = GuestIP & Right(IPnumber(i), 1)
next
end function
'##############################################
'## Poll Mod ##
'##############################################
function GetVote(pTopic_ID)
Dim tmpVoted
if strWhoVotes = "members" or (strWhoVotes <> "members" and mLev > 0) then
'## Forum SQL - See if user has voted in this poll
strSql = "SELECT TOPIC_ID "
strSql = strSql & "FROM " & strTablePrefix & "POLL_VOTES "
strSql = strSql & "WHERE MEMBER_ID = " & MemberID
Set rsPoll2 = Server.CreateObject("ADODB.Recordset")
rsPoll2.open strSql, my_Conn, adOpenForwardOnly, adLockReadOnly, adCmdText
if rsPoll2.EOF or rsPoll2.BOF then
tmpVoted = false
else
do until rsPoll2.EOF or rsPoll2.BOF
if cLng(pTopic_ID) = cLng(rsPoll2("TOPIC_ID")) then
tmpVoted = true
exit do
else
tmpVoted = false
end if
rsPoll2.MoveNext
loop
end if
rsPoll2.close
Set rsPoll2 = nothing
end if
if strWhoVotes = "members" then '### Members Only Mode
GetVote = tmpVoted
else '### Everyone Can Vote Mode
if mLev > 0 then
'### User is logged in when voting
if not(tmpVoted) then
'Get the topic id's of the polls the user has already voted in from the cookie
cpoll = Request.Cookies(strCookieURL & "poll")("" & pTopic_ID & "")
if instr(cpoll, pTopic_ID) > 0 then
'Topic ID of poll is found in users cookie
GetVote = true
else
GetVote = false
end if
else
GetVote = true
end if
else
'### User is logged out when voting
'Get the topic id's of the polls the user has already voted in from the cookie
cpoll = Request.Cookies(strCookieURL & "poll")("" & pTopic_ID & "")
if instr(cpoll, pTopic_ID) > 0 then
'Topic ID of poll is found in users cookie
GetVote = true
else
GetVote = false
end if
end if
end if
end function
Sub UpdateVote(pGuest_Vote, pMember_ID, pTopic_ID, pForum_ID, pCat_ID)
if strWhoVotes = "members" then '### Members Only Mode
'## Insert vote into POLL_VOTES table
strSql = "INSERT INTO " & strTablePrefix & "POLL_VOTES (GUEST_VOTE, MEMBER_ID, TOPIC_ID, FORUM_ID, CAT_ID)" & _
"VALUES (" & pGuest_Vote & ", " & pMember_ID & ", " & pTopic_ID & ", " & pForum_ID & ", " & pCat_ID & ")"
my_Conn.Execute (strSql),,adCmdText + adExecuteNoRecords
elseif strVResults = "0" then '### Everyone Can Vote Mode
if mlev > 0 then
'## Insert vote into POLL_VOTES table
strSql = "INSERT INTO " & strTablePrefix & "POLL_VOTES (GUEST_VOTE, MEMBER_ID, TOPIC_ID, FORUM_ID, CAT_ID)" & _
"VALUES (" & pGuest_Vote & ", " & pMember_ID & ", " & pTopic_ID & ", " & pForum_ID & ", " & pCat_ID & ")"
my_Conn.Execute (strSql),,adCmdText + adExecuteNoRecords
Response.Cookies(strCookieURL & "poll")("" & pTopic_ID & "") = ("" & pTopic_ID & "")
Response.Cookies(strCookieURL & "poll").Expires = Date + 365
else
Response.Cookies(strCookieURL & "poll")("" & pTopic_ID & "") = ("" & pTopic_ID & "")
Response.Cookies(strCookieURL & "poll").Expires = Date + 365
end if
end if
End Sub
'##############################################
'## Active Users ##
'##############################################
Sub ActiveUserTracker()
'Ls3k- Declaire and assign variables.
Dim strUserIP, strUserIP2, strScriptName, strQueryString, strUserAgent, strCurrentTime, strTimedOut
' strUserIP = Request.ServerVariables("REMOTE_ADDR")
strUserIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
if strUserIP = "" or Left(strUserIP, 7) = "unknown" then
strUserIP = Request.ServerVariables("REMOTE_ADDR")
elseif InStr(strUserIP, ",") > 0 then
strUserIP = Left(strUserIP, InStr(strUserIP, ",")-1)
elseif InStr(strUserIP, ";") > 0 then
strUserIP= Left(strUserIP, InStr(strUserIP, ";")-1)
end if
if InStr(strUserIP, ":") > 0 then
strUserIP = Left(strUserIP, InStr(strUserIP, ":")-1)
end if
strScriptName = Mid(Request.ServerVariables("SCRIPT_NAME"), InstrRev(Request.ServerVariables("SCRIPT_NAME"), "/")+1)
strQueryString = Request.ServerVariables("QUERY_STRING")
strUserAgent = Request.ServerVariables("HTTP_USER_AGENT")
strCurrentTime = DateToStr(strForumTimeAdjust)
'Ls3k- First Order of business, is this person new?
if MemberID="-1" then 'If this is a Guest, check by IP
strSql = "SELECT AU_LASTACTIVETIME "
strSql = strSql & "FROM " & strTablePrefix & "ACTIVE_USERS "
strSql = strSql & "WHERE AU_IP = '" & chkString(strUserIP, "sqlstring") & "' "
strSql = strSql & "AND MEMBER_ID = -1"
else 'If this is a Member, check by Member_ID
strSql = "SELECT AU_LASTACTIVETIME "
strSql = strSql & "FROM " & strTablePrefix & "ACTIVE_USERS "
strSql = strSql & "WHERE MEMBER_ID = " & MemberID
end if
Set rs = my_conn.execute (strSql)
if rs.EOF or rs.BOF then
strNewUser = 1
else
strNewUser = 0
strAUTimedOut = DateToStr(DateAdd("n",-strAUTimeout,strForumTimeAdjust))
if rs("AU_LASTACTIVETIME") < strAUTimedOut then 'Check to see if user has timed out since last active.
strSql = "DELETE FROM " & strTablePrefix & "ACTIVE_USERS "
strSql = strSql & "WHERE (MEMBER_ID = " & MemberID & " "
strSql = strSql & "AND MEMBER_ID <> -1) "
strSql = strSql & "OR (AU_IP = '" & chkString(strUserIP, "sqlstring") & "' "
strSql = strSql & "AND MEMBER_ID = -1)"
my_conn.Execute (strSql),,adCmdText + adExecuteNoRecords
strNewUser = 1
end if
end if
rs.close
Set rs = Nothing
'Ls3k- Second order of business, lets update those already-active users
if strNewUser = 0 then 'If already-active
strSql = "UPDATE " & strTablePrefix & "ACTIVE_USERS "
strSql = strSql & "SET AU_LASTACTIVETIME='" & chkString(strCurrentTime, "sqlstring") & "'"
strSql = strSql & ", AU_LASTPAGE='" & chkString(strScriptName, "sqlstring") & "'"
strSql = strSql & ", AU_QUERYSTRING='" & chkString(strQueryString, "sqlstring") & "' "
if MemberID=-1 then 'If guest, update based on IP
strSql = strSql & "WHERE AU_IP = '" & chkString(strUserIP, "sqlstring") & "' "
strSql = strSql & "AND MEMBER_ID = " & MemberID & " "
else 'Update members based on MemberID
strSql = strSql & "WHERE MEMBER_ID = " & MemberID
end if
my_conn.Execute (strSql),,adCmdText + adExecuteNoRecords
else 'Is a new user, make new record
If strLoginStatus = 0 then
strSql = "INSERT INTO " & strTablePrefix & "ACTIVE_USERS (" & _
"MEMBER_ID, AU_IP, AU_LOGINTIME, AU_LASTACTIVETIME, " & _
"AU_LASTPAGE, AU_QUERYSTRING, AU_USER_AGENT) VALUES(" & _
MemberID & ", " & _
"'" & chkString(strUserIP, "sqlstring") & "', " & _
"'" & chkString(strCurrentTime, "sqlstring") & "', " & _
"'" & chkString(strCurrentTime, "sqlstring") & "', " & _
"'" & chkString(strScriptName, "sqlstring") & "', " & _
"'" & chkString(strQueryString, "sqlstring") & "', " & _
"'" & chkString(strUserAgent, "sqlstring") & "')"
my_conn.execute (strSql)
end if
end if
end sub
function chkUserPermissions(fCheck)
chkUserPermissions = 0
select case fCheck
case "1"
if mLev = 4 then
chkUserPermissions = 1
end if
case "2"
if (mLev = "4" or mLev = "3") then
chkUserPermissions = 1
end if
case "3"
if (mLev = "4" or mLev = "3" or mLev = "2") then
chkUserPermissions = 1
end if
case "4"
chkUserPermissions = 1
end select
end function
function chkAURecord(intTotalActiveUsers)
if cLng(intTotalActiveUsers) > cLng(intAURecord) then 'We have a new record!!! :)
'Check to see if it *Really* is a record, or if Application varaibles just got reset
strSql = "SELECT C_VALUE "
strSql = strSql & "FROM " & strTablePrefix & "CONFIG_NEW "
strSql = strSql & "WHERE C_VARIABLE = 'intAURecord'"
Set rs = my_conn.execute (strSql)
intOldRecord = cLng(rs("C_VALUE"))
rs.Close
Set rs = nothing
if cLng(intOldRecord) > cLng(intTotalActiveUsers) then
'Oopsi, this was a false alarm
strSql = "SELECT C_VALUE "
strSql = strSql & "FROM " & strTablePrefix & "CONFIG_NEW "
strSql = strSql & "WHERE C_VARIABLE = 'strAURecordDate'"
Set rs = my_conn.execute (strSql)
strOldDate = rs("C_VALUE")
rs.close
Set rs = nothing
Application(strCookieURL & "INTAURECORD") = intOldRecord
Application(strCookieURL & "STRAURECORDDATE") = strOldDate
intAURecord = intOldRecord
strAURecordDate = strOldDate
else
strSql = "UPDATE " & strTablePrefix & "CONFIG_NEW "
strSql = strSql & "SET C_VALUE = '" & cstr(intTotalActiveUsers) & "' "
strSql = strSql & "WHERE C_VARIABLE = 'intAURecord'"
my_conn.execute(strsql),,adCmdText + adExecuteNoRecords
strSql = "UPDATE " & strTablePrefix & "CONFIG_NEW "
strSql = strSql & "SET C_VALUE = '" &DateToStr(strForumTimeAdjust) & "' "
strSql = strSql & "WHERE C_VARIABLE = 'strAURecordDate'"
my_conn.execute(strsql),,adCmdText + adExecuteNoRecords
intAURecord = intTotalActiveUsers
strAURecordDate = DateToStr(strForumTimeAdjust)
Application(strCookieURL & "INTAURECORD") = intTotalActiveUsers
Application(strCookieURL & "STRAURECORDDATE") = DateToStr(strForumTimeAdjust)
end if
end if
end function
sub deleteInactiveUsers()
strAUTimedOut = DateToStr(DateAdd("n",-strAUTimeout,strForumTimeAdjust))
strSql = "DELETE FROM " & strTablePrefix & "ACTIVE_USERS "
strSql = strSql & "WHERE AU_LASTACTIVETIME < '" & strAUTimedOut & "'"
my_conn.Execute (strSql),,adCmdText + adExecuteNoRecords
end sub
sub AUHandleLoging()
strUserIP2 = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
if strUserIP2 = "" or Left(strUserIP2, 7) = "unknown" then
strUserIP2 = Request.ServerVariables("REMOTE_ADDR")
elseif InStr(strUserIP2, ",") > 0 then
strUserIP2 = Left(strUserIP2, InStr(strUserIP2, ",")-1)
elseif InStr(strUserIP2, ";") > 0 then
strUserIP2= Left(strUserIP2, InStr(strUserIP2, ";")-1)
end if
if InStr(strUserIP2, ":") > 0 then
strUserIP2 = Left(strUserIP2, InStr(strUserIP2, ":")-1)
end if
strSql = "DELETE FROM " & strTablePrefix & "ACTIVE_USERS "
strSql = strSql & "WHERE AU_IP = '" & Chkstring(strUserIP2, "sqlstring") & "'"
my_conn.Execute (strSql),,adCmdText + adExecuteNoRecords
end sub
'##############################################
'## 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, 1) > 0 Then
strArray = Split(strToFormat, sPrefix, -1, 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), 7)) <> "[MEDIA]") and _
(UCase(Right(strArray(Counter-1), 5)) <> "[MP3]") and _
(UCase(Right(strArray(Counter-1), 5)) <> "[PDF]") and _
(UCase(Right(strArray(Counter-1), 8)) <> "_BLANK"">") and _
(UCase(Right(strArray(Counter-1), 5)) <> "[WMV]") and _
(UCase(Right(strArray(Counter-1), 6)) <> "[TUBE]") and _
(UCase(Right(strArray(Counter-1), 9)) <> "[MYSPACE]") and _
(UCase(Right(strArray(Counter-1), 6)) <> "[GVID]") and _
(UCase(Right(strArray(Counter-1), 10)) <> "[METACAFE]") and _
(UCase(Right(strArray(Counter-1), 5)) <> "[WMA]") and _
(UCase(Right(strArray(Counter-1), 4)) <> "[QT]") and _
(UCase(Right(strArray(Counter-1), 4)) <> "[RV]") and _
(UCase(Right(strArray(Counter-1), 7)) <> "FLASH]""") and _
(UCase(Right(strArray(Counter-1), 5)) <> "WMV]""") and _
(UCase(Right(strArray(Counter-1), 4)) <> "QT]""") and _
(UCase(Right(strArray(Counter-1), 4)) <> "RM]""") and _
(UCase(Right(strArray(Counter-1), 7)) <> "[FLASH]") and _
(UCase(Right(strArray(Counter-1), 5)) <> "[FLV]") and _
(UCase(Right(strArray(Counter-1), 5)) <> "TUBE]") 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, "<br />", " <br />", 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, " <br />", "<br />", 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), "<br /><br />")
fString = Replace(fString, CHR(10), "<br />")
if strBadWordFilter = 1 or strBadWordFilter = "1" then
fString = ChkBadWords(fString)
end if
fString = NoParse(fString)
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
fString = iconzip(fString)
if strAllowForumCode = "1" then
fString = extratags(fString)
fString = ReplaceMediaTags(fString) ' Media
fString = ReplaceGoogleVideoTags(fString) ' Google Video
fString = ReplaceTubeTags(fString) ' Youtube video
fString = ReplaceFlashTags(fString) ' Flash video
fString = ReplaceMetaCafeTags(fString) ' metacafe video
fString = ReplaceMySpaceTags(fString) ' MySpace video
fString = ReplaceQTTags(fString) ' QuickTime video
fString = ReplaceWMVTags(fString) ' windows media
fString = ReplaceRVTags(fString) ' Real video
fString = ReplaceMP3Tags(fString) ' MP3
fString = ReplacePDFTags(fString) ' PDF
end if
if strUseAttachments = "1" then
fString=downloadFilePost(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 IconZip(fString)
fString = replace(fString, "[iconattachzip]", getCurrentIcon(strIconAttachZip2,"","align=""middle"""))
IconZip = fString
end function
function Smile(fString)
'############# SmileManager Plus MOD ################
smilesql = "SELECT S_CODE, S_URL FROM " & strTablePrefix & "SMILES ORDER BY S_DESC"
set SMrs = my_conn.execute(smilesql)
if not(SMrs.eof) then
smiledata=SMrs.getrows
numrows=ubound(smiledata,2)
SMrs.close
set SMrs = nothing
for smi = 0 to numrows
fString = replace(fString, smiledata(0,smi), getCurrentIcon(smiledata(1,smi) & "||","","align=""middle"""))
next
else
SMrs.close
set SMrs = nothing
end if
Smile = fString
'####################################################
end function
function extratags(fString)
fString = doCode(fString, "[quote]", "[/quote]", "<div class=""quoteboxhead"">" & fLang("strLangI_F_Common00780") & "</div><div class=""quotebox"">", "</div>")
fString = doCode(fString, "[spoiler2]", "[/spoiler2]", "<font color=""" & CColor & """>", "</font id=""" & CColor & """>")
fString = doCode(fString, "[spoiler]", "[/spoiler]", "<div style=""margin:1em auto; width: 100%;"">" & vbNewline & " <div><b> Spoiler: </b><input type=""button"" value=""Show"" style=""width:45px;font-size:10px;margin:0px;padding:0px;"" onclick=""if (this.parentNode.parentNode.getElementsByTagName('div')[1].getElementsByTagName('div')[0].style.display != ''){ this.parentNode.parentNode.getElementsByTagName('div')[1].getElementsByTagName('div')[0].style.display = '';this.innerText = ''; this.value = 'Hide'; } else { this.parentNode.parentNode.getElementsByTagName('div')[1].getElementsByTagName('div')[0].style.display = 'none'; this.innerText = ''; this.value = 'Show'; }"" /></div>" & vbNewline & " <div style=""margin: 0px; padding: 0px; border: 1px solid; border-color: #333399;"">" & vbNewline & " <div style=""display: none;"">" & vbNewline, " </div>" & vbNewline & " </div>" & vbNewline & "</div>" & vbNewline)
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 "displayflag"
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
fstring = Replace(fstring,"&#","&#")
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]", "<blockquote id=""quote""><font size=""" & strFooterFontSize & """ face=""" & strDefaultFontFace & """ id=""quote"">quote:<hr height=""1"" noshade id=""quote"">", "<hr height=""1"" noshade id=""quote""></font id=""quote""></blockquote id=""quote"">")
'end if
if strAllowForumCode = "1" and fField_Type <> "signature" then
fString = doCode(fString, "[b]", "[/b]", "<b>", "</b>")
fString = doCode(fString, "[s]", "[/s]", "<s>", "</s>")
fString = doCode(fString, "[strike]", "[/strike]", "<s>", "</s>")
fString = doCode(fString, "[u]", "[/u]", "<u>", "</u>")
fString = doCode(fString, "[i]", "[/i]", "<i>", "</i>")
if fField_Type <> "title" then
fString = doCode(fString, "[font=Andale Mono]", "[/font=Andale Mono]", "<font face=""Andale Mono"">", "</font id=""Andale Mono"">")
fString = doCode(fString, "[font=Arial]", "[/font=Arial]", "<font face=""Arial"">", "</font id=""Arial"">")
fString = doCode(fString, "[font=Arial Black]", "[/font=Arial Black]", "<font face=""Arial Black"">", "</font id=""Arial Black"">")
fString = doCode(fString, "[font=Book Antiqua]", "[/font=Book Antiqua]", "<font face=""Book Antiqua"">", "</font id=""Book Antiqua"">")
fString = doCode(fString, "[font=Century Gothic]", "[/font=Century Gothic]", "<font face=""Century Gothic"">", "</font id=""Century Gothic"">")
fString = doCode(fString, "[font=Courier New]", "[/font=Courier New]", "<font face=""Courier New"">", "</font id=""Courier New"">")
fString = doCode(fString, "[font=Comic Sans MS]", "[/font=Comic Sans MS]", "<font face=""Comic Sans MS"">", "</font id=""Comic Sans MS"">")
fString = doCode(fString, "[font=Georgia]", "[/font=Georgia]", "<font face=""Georgia"">", "</font id=""Georgia"">")
fString = doCode(fString, "[font=Impact]", "[/font=Impact]", "<font face=""Impact"">", "</font id=""Impact"">")
fString = doCode(fString, "[font=Tahoma]", "[/font=Tahoma]", "<font face=""Tahoma"">", "</font id=""Tahoma"">")
fString = doCode(fString, "[font=Times New Roman]", "[/font=Times New Roman]", "<font face=""Times New Roman"">", "</font id=""Times New Roman"">")
fString = doCode(fString, "[font=Trebuchet MS]", "[/font=Trebuchet MS]", "<font face=""Trebuchet MS"">", "</font id=""Trebuchet MS"">")
fString = doCode(fString, "[font=Script MT Bold]", "[/font=Script MT Bold]", "<font face=""Script MT Bold"">", "</font id=""Script MT Bold"">")
fString = doCode(fString, "[font=Stencil]", "[/font=Stencil]", "<font face=""Stencil"">", "</font id=""Stencil"">")
fString = doCode(fString, "[font=Verdana]", "[/font=Verdana]", "<font face=""Verdana"">", "</font id=""Verdana"">")
fString = doCode(fString, "[font=Lucida Console]", "[/font=Lucida Console]", "<font face=""Lucida Console"">", "</font id=""Lucida Console"">")
fString = doCode(fString, "[red]", "[/red]", "<font color=""red"">", "</font id=""red"">")
fString = doCode(fString, "[green]", "[/green]", "<font color=""green"">", "</font id=""green"">")
fString = doCode(fString, "[blue]", "[/blue]", "<font color=""blue"">", "</font id=""blue"">")
fString = doCode(fString, "[white]", "[/white]", "<font color=""white"">", "</font id=""white"">")
fString = doCode(fString, "[purple]", "[/purple]", "<font color=""purple"">", "</font id=""purple"">")
fString = doCode(fString, "[yellow]", "[/yellow]", "<font color=""yellow"">", "</font id=""yellow"">")
fString = doCode(fString, "[violet]", "[/violet]", "<font color=""violet"">", "</font id=""violet"">")
fString = doCode(fString, "[brown]", "[/brown]", "<font color=""brown"">", "</font id=""brown"">")
fString = doCode(fString, "[black]", "[/black]", "<font color=""black"">", "</font id=""black"">")
fString = doCode(fString, "[pink]", "[/pink]", "<font color=""pink"">", "</font id=""pink"">")
fString = doCode(fString, "[orange]", "[/orange]", "<font color=""orange"">", "</font id=""orange"">")
fString = doCode(fString, "[gold]", "[/gold]", "<font color=""gold"">", "</font id=""gold"">")
fString = doCode(fString, "[beige]", "[/beige]", "<font color=""beige"">", "</font id=""beige"">")
fString = doCode(fString, "[teal]", "[/teal]", "<font color=""teal"">", "</font id=""teal"">")
fString = doCode(fString, "[navy]", "[/navy]", "<font color=""navy"">", "</font id=""navy"">")
fString = doCode(fString, "[maroon]", "[/maroon]", "<font color=""maroon"">", "</font id=""maroon"">")
fString = doCode(fString, "[limegreen]", "[/limegreen]", "<font color=""limegreen"">", "</font id=""limegreen"">")
fString = doCode(fString, "[h1]", "[/h1]", "<h1>", "</h1>")
fString = doCode(fString, "[h2]", "[/h2]", "<h2>", "</h2>")
fString = doCode(fString, "[h3]", "[/h3]", "<h3>", "</h3>")
fString = doCode(fString, "[h4]", "[/h4]", "<h4>", "</h4>")
fString = doCode(fString, "[h5]", "[/h5]", "<h5>", "</h5>")
fString = doCode(fString, "[h6]", "[/h6]", "<h6>", "</h6>")
fString = doCode(fString, "[size=1]", "[/size=1]", "<font size=""1"">", "</font id=""size1"">")
fString = doCode(fString, "[size=2]", "[/size=2]", "<font size=""2"">", "</font id=""size2"">")
fString = doCode(fString, "[size=3]", "[/size=3]", "<font size=""3"">", "</font id=""size3"">")
fString = doCode(fString, "[size=4]", "[/size=4]", "<font size=""4"">", "</font id=""size4"">")
fString = doCode(fString, "[size=5]", "[/size=5]", "<font size=""5"">", "</font id=""size5"">")
fString = doCode(fString, "[size=6]", "[/size=6]", "<font size=""6"">", "</font id=""size6"">")
fString = doCode(fString, "[list]", "[/list]", "<ul>", "</ul>")
fString = doCode(fString, "[list=1]", "[/list=1]", "<ol type=""1"">", "</ol id=""1"">")
fString = doCode(fString, "[list=a]", "[/list=a]", "<ol type=""a"">", "</ol id=""a"">")
fString = doCode(fString, "[*]", "[/*]", "<li>", "</li>")
fString = doCode(fString, "[left]", "[/left]", "<div align=""left"">", "</div id=""left"">")
fString = doCode(fString, "[center]", "[/center]", "<center>", "</center>")
fString = doCode(fString, "[centre]", "[/centre]", "<center>", "</center>")
fString = doCode(fString, "[right]", "[/right]", "<div align=""right"">", "</div id=""right"">")
'fString = doCode(fString, "[code]", "[/code]", "<pre id=""code""><font face=""courier"" size=""" & strDefaultFontSize & """ id=""code"">", "</font id=""code""></pre id=""code"">")
'fString = doCode(fString, "[code]", "[/code]", "<pre id=""code""><font face=""courier"" size=""" & strDefaultFontSize & """ id=""code"">", "</font id=""code""></pre id=""code"">")
if strUseCallOuts = "1" then
fString = replace(fString, "[duh]", "<img src=images/speech/icon_speech_duh.gif border=0 width=23 height=15>", 1, -1, 1)
fString = replace(fString, "[oops]", "<img src=images/speech/icon_speech_oops.gif border=0 width=29 height=15>", 1, -1, 1)
fString = replace(fString, "[sigh]", "<img src=images/speech/icon_speech_sigh.gif border=0 width=27 height=15>", 1, -1, 1)
fString = replace(fString, "[ugh]", "<img src=images/speech/icon_speech_ugh.gif border=0 width=23 height=15>", 1, -1, 1)
fString = replace(fString, "[wow]", "<img src=images/speech/icon_speech_wow.gif border=0 width=23 height=15>", 1, -1, 1)
fString = replace(fString, "[yeah]", "<img src=images/speech/icon_speech_yeah.gif border=0 width=29 height=15>", 1, -1, 1)
fString = replace(fString, "[ok]", "<img src=images/speech/icon_speech_ok.gif border=0 width=17 height=15>", 1, -1, 1)
fString = replace(fString, "[yes]", "<img src=images/speech/icon_speech_yes.gif border=0 width=23 height=15>", 1, -1, 1)
fString = replace(fString, "[no]", "<img src=images/speech/icon_speech_no.gif border=0 width=17 height=15>", 1, -1, 1)
end if
fString = replace(fString, "[br]", "<br />", 1, -1, 1)
fString = replace(fString, "[hr]", "<hr noshade size=""1"">", 1, -1, 1)
'## POST BUTTONS PLUS
if strPostButtons = "1" then
AllowSupScript = chkUserPermissions(intSupPermission)
AllowSubScript = chkUserPermissions(intSubPermission)
AllowCharacter = chkUserPermissions(intCharacterPermission)
AllowHighlight = chkUserPermissions(intHighlightPermission)
AllowPre = chkUserPermissions(intPrePermission)
AllowTeletype = chkUserPermissions(intTeletypePermission)
AllowMarquee = chkUserPermissions(intMarqueePermission)
AllowSound = chkUserPermissions(intSoundPermission)
if AllowSupScript then
fString = doCode(fString, "[sup]", "[/sup]", "<sup>", "</sup>")
end if
if AllowSubScript then
fString = doCode(fString, "[sub]", "[/sub]", "<sub>", "</sub>")
end if
if AllowCharacter then
fString = doCode(fString, "[bigchar]", "[/bigchar]", "<style type='text/css' id='bigchar'> #BIGCHAR {background-color: black; color: white; font-size: 16pt; } </style id='bigchar'><SPAN ID='bigchar'>", "</SPAN id='bigchar'>")
end if
if AllowHighlight then
fString = doCode(fString, "[hl]", "[/hl]", "<span id='hl' style='background-color: " & strSearchHiLiteColor & "; color: black;'>", "</span id='hl'>")
end if
if AllowPre then
fString = doCode(fString, "[pre]", "[/pre]", "<pre id='pre'><font face=""" & strDefaultFontFace & """ size=" & strDefaultFontSize & " id='pre'>", "</font id='pre'></pre id='pre'>")
end if
if AllowTeletype then
fString = doCode(fString, "[tt]", "[/tt]", "<tt>", "</tt>")
end if
if AllowMarquee then
fString = doCode(fString, "[marquee]", "[/marquee]", "<marquee id='marquee'>", "</marquee id='marquee'>")
end if
if AllowSound then
fString = doCode(fString, "[sound]","[/sound]","<EMBED SRC=""",""" WIDTH=1 HEIGHT=1 HIDDEN=""true"" AUTOSTART=""true"" LOOP=""false"" volume=""100""></EMBED>")
end if
end if
'## POST BUTTONS PLUS
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
oldStrToDate = 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)
oldStrToDate = "" & 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 = "" or left(UserIPAddress, 7) = "unknown" then
UserIPAddress = Request.ServerVariables("REMOTE_ADDR")
elseif InStr(UserIPAddress, ",") > 0 then
UserIPAddress = Left(UserIPAddress, InStr(UserIPAddress, ",")-1)
elseif InStr(UserIPAddress, ";") > 0 then
UserIPAddress = Left(UserIPAddress, InStr(UserIPAddress, ";")-1)
end if
if InStr(UserIPAddress, ":") > 0 then
UserIPAddress = Left(UserIPAddress, InStr(UserIPAddress, ":")-1)
end if
UserIPAddress = Trim(ChkString(UserIPAddress,"SQLString"))
if Not isValidForumDateString(fTime) then
fTime = DateToStr(strForumTimeAdjust)
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 isValidForumDateString(fDate)
Set regEx = New RegExp
regEx.Global = true
regEx.Pattern = "^[123][0-9]{13}$"
retVal = regEx.Test(fDate)
Set regEx = nothing
if Not retVal then
isValidForumDateString = false
else
isValidForumDateString = true
end if
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 strTodayYesterday = "1" then '### Today Yesterday mod
select case Mid(Request.ServerVariables("SCRIPT_NAME"), InstrRev(Request.ServerVariables("SCRIPT_NAME"), "/")+1)
case "admin_accounts_pending.asp", _
"admin_accounts_pending_reminder.asp", _
"admin_config_datetime.asp"
'
' For any page that needs the actual date, add the file name to the above case statement.
'
case else
select case left(fDate,8)
case left(DateToStr(date),8)
chkDate = fLang("strLangInc_Func_Common00250")
case left(DateToStr(date-1),8)
chkDate = fLang("strLangActive00110")
end select
end select
end if '### End Today Yesterday mod
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
'##############################################
'## Admin Level ##
'##############################################
function IsAdminAllowed(fName, fPassword, fAuthor)
Dim rsCheck
Dim strSql
' ## Forum_SQL
strSql = "SELECT MEMBER_ID, M_ALEVEL, 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
IsAdminAllowed = 0 '## Invalid user
else
if rsCheck("M_ALEVEL") > 0 and not(isnull(rsCheck("M_ALEVEL"))) then IsAdminAllowed = 1 '## allowed
end if
rsCheck.Close
Set rsCheck = nothing
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("userid") = MemberID
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 chkUtente(fName, fPassword, fAuthor)
dim rsCheck
dim strSql
'## Login Flood Control ## ADD code below ###############################
if cLng(intLoginFloodControl) = 1 then
chkLoginSession(1)
end if
'## End #################################################################
'## Forum_SQL
strSql = "SELECT MEMBER_ID, M_LEVEL, M_NAME, M_PASSWORD, M_POSTS "
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
chkUtente = 0 '## Invalid Password
if strDBNTUserName <> "" and chkCookie = 1 then
Call ClearCookies()
strDBNTUserName = ""
end if
'## Login Flood Control ## ADD code below ###############################
if cLng(intLoginFloodControl) = 1 then
chkLoginSession(2)
end if
'## End #################################################################
else
'## Login Flood Control ## ADD code below ###############################
if cLng(intLoginFloodControl) = 1 then
chkLoginSession(3)
end if
'## End #################################################################
MemberID = rsCheck("MEMBER_ID")
strDBNTUserName = rsCheck("M_NAME")
if (rsCheck("MEMBER_ID") & "" = fAuthor & "") and (cLng(rsCheck("M_LEVEL")) <> 3) then
chkUtente = 1 '## Author
else
select case cLng(rsCheck("M_LEVEL"))
case 1
chkUtente = 2 '## Normal User
case 2
chkUtente = 3 '## Moderator
case 3
chkUtente = 4 '## Admin
case 4
chkUtente = 5 '## Semi-Admin
case else
chkUtente = cLng(rsCheck("M_LEVEL"))
end select
end if
end if
rsCheck.close
set rsCheck = nothing
end function
'## Login Flood Control ## ADD sub routine below ##############################
Sub chkLoginSession(typ)
select case cLng(typ)
case 1
'## if the user is waiting and hasnt waited long enough ##
'## start the wait all over and send them to password.asp ##
if trim(Session(strCookieURL & "logindelay")) <> "" and isDate(Session(strCookieURL & "logindelay")) then
if DateDiff("s",Session(strCookieURL & "logindelay"),time) < 0 then
Session(strCookieURL & "logindelay") = DateAdd("s",(intLoginCheckTime * 60),time)
Session(strCookieURL & "logingrace") = ""
if cLng(strEMail) = 1 then
Response.Redirect("password2.asp")
else
Response.Redirect("password2.asp")
end if
end if
end if
case 2
'## set variables back to default if user has waited long enough ##
'## and start the login attempts all over ##
if cLng(Session(strCookieURL & "login")) > cLng(intLoginAttempts) then
if trim(Session(strCookieURL & "logindelay")) <> "" and isDate(Session(strCookieURL & "logindelay")) then
Session(strCookieURL & "login") = 0
Session(strCookieURL & "logindelay") = ""
end if
end if
'## set login attempts to "" if grace is on and the time has been met ##
if cLng(intLoginFloodGrace) = 1 then
if trim(Session(strCookieURL & "logingrace")) <> "" and isDate(Session(strCookieURL & "logingrace")) then
if DateDiff("s",trim(Session(strCookieURL & "logingrace")),time) > cLng(intLoginGraceTime) then
if isNumeric(Session(strCookieURL & "login")) = true then
Session(strCookieURL & "login") = ""
end if
end if
end if
Session(strCookieURL & "logingrace") = time
end if
'## Increase login attempts ##
if trim(Session(strCookieURL & "login")) = "" then
Session(strCookieURL & "login") = 1
else
if isNumeric(Session(strCookieURL & "login")) = true then
Session(strCookieURL & "login") = cLng(Session(strCookieURL & "login")) + 1
else
Session(strCookieURL & "login") = 1
end if
end if
'## if user exceeds intLoginAttempts, start the wait ##
if cLng(Session(strCookieURL & "login")) > cLng(intLoginAttempts) then
Session(strCookieURL & "logindelay") = DateAdd("s",(intLoginCheckTime * 60),time)
if cLng(intLoginFloodGrace) = 1 then
Session(strCookieURL & "logingrace") = ""
end if
if cLng(strEMail) = 1 then
Response.Redirect("password2.asp")
else
Response.Redirect("password2.asp")
end if
end if
case 3
'## clean up after successful login
if trim(Session(strCookieURL & "login")) <> "" then
Session(strCookieURL & "login") = ""
Session(strCookieURL & "logindelay") = ""
if cLng(intLoginFloodGrace) = 1 then
if trim(Session(strCookieURL & "logingrace")) <> "" then
Session(strCookieURL & "logingrace") = ""
end if
end if
end if
end select
End Sub
'## End ################################################################
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 = "<a href="""
rc1Tag = """ target=""_blank"">"
rc2Tag = "</a>"
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 & "<a href=""" & strArray2(0) & """ target=""_blank"">" & strFirstPart & "</a>" & 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
strArray2(0) = replace(strArray2(0), " ", "", 1, -1, 1) ' ## filter out space
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 chkUserGroupView(ugMemberID)
chkUserGroupView = false
Select Case cLng(strUGView)
Case 0
if mlev = 4 then
chkUserGroupView = true
else
if mlev = 3 and cLng(strUGModForums) > 0 then chkUserGroupView = true
end if
Case 1
if mlev = 4 then
chkUserGroupView = true
elseif mlev = 3 and cLng(strUGModForums) > 0 then
chkUserGroupView = true
else
strLimitGroups = Session(strCookieURL & "UserGroups" & ugMemberID)
if strLimitGroups = "" or IsNull(strLimitGroups) then
chkUserGroupView = false
UG_Err_Msg = "You are not a member of any UserGroups."
else
chkUserGroupView = true
end if
end if
Case 2
if mlev = 0 then
chkUserGroupView = false
UG_Err_Msg = "You must be logged in to view UserGroups."
else
chkUserGroupView = true
end if
End Select
end function
function isReadOnly (fForum_ID,fMemberID)
if fMemberID <> MemberID then
strGroupsForUser = getGroupMembership(fMemberID,1)
'## get all read-only groups for this forum
strSql = "SELECT USERGROUP_ID "
strSql = strSql & "FROM " & strTablePrefix & "ALLOWED_USERGROUPS "
strSql = strSql & "WHERE FORUM_ID = " & fForum_ID & " "
strSql = strSql & "AND PERMS = 2"
Set rsROGroups = Server.CreateObject("ADODB.Recordset")
rsROGroups.open strSql, my_Conn, adOpenForwardOnly, adLockReadOnly, adCmdText
arROGroups = Null
if not rsROGroups.bof and not rsROGroups.eof then arROGroups = rsROGroups.GetRows
rsROGroups.close
Set rsROGroups = nothing
isReadOnly = 0
if not IsNull(arROGroups) then
for ROCount = LBound(arROGroups,2) to UBound(arROGroups,2)
if InStr("," & strGroupsForUser & ",", arROGroups(0,ROCount)) then isReadOnly = 1
next
end if
exit function
end if
if Session(strCookieURL & "ReadOnlyForums" & MemberID) = "" or IsNull(Session(strCookieURL & "ReadOnlyForums" & MemberID)) then
'## check group membership
strGroupMembership = Session(strCookieURL & "UserGroups" & MemberID)
if strGroupMembership <> "" then
strSql = "SELECT FORUM_ID "
strSql = strSql & "FROM " & strTablePrefix & "ALLOWED_USERGROUPS "
strSql = strSql & "WHERE USERGROUP_ID "
strSql = strSql & "IN (" & strGroupMembership & ") "
strSql = strSql & "AND PERMS = 2"
Set rsROGroup = Server.CreateObject("ADODB.Recordset")
rsROGroup.open strSql, my_Conn, adOpenForwardOnly, adLockReadOnly, adCmdText
arROGroup = Null
if not rsROGroup.bof and not rsROGroup.eof then arROGroup = rsROGroup.GetRows
rsROGroup.close
Set rsROGroup = nothing
if not IsNull(arROGroup) then
for ROCount = LBound(arROGroup,2) to UBound(arROGroup,2)
if isROMember2 <> "" then isROMember2 = isROMember2 & ","
isROMember2 = isROMember2 & arROGroup(0,ROCount)
next
end if
end if
if isROMember2 = "" then
isROMember2 = "-1"
end if
Session(strCookieURL & "ReadOnlyForums" & MemberID) = isROMember2
Session(strCookieURL & "ReadOnlyForums" & MemberID) = isROMember2
end if
if Session(strCookieURL & "ReadOnlyForums" & MemberID) = "-1" then
isReadOnly = 0
elseif InStr("," & Session(strCookieURL & "ReadOnlyForums" & MemberID) & ",","," & fForum_ID & ",") then
isReadOnly = 1
else
isReadOnly = 0
end if
end function
function isDeniedMember (fForum_ID,fMemberID)
if fMemberID <> MemberID then
strGroupsForUser = getGroupMembership(fMemberID,1)
'## get all deny groups for this forum
strSql = "SELECT USERGROUP_ID "
strSql = strSql & "FROM " & strTablePrefix & "ALLOWED_USERGROUPS "
strSql = strSql & "WHERE FORUM_ID = " & fForum_ID & " "
strSql = strSql & "AND PERMS = 1"
Set rsDeniedGroups = Server.CreateObject("ADODB.Recordset")
rsDeniedGroups.open strSql, my_Conn, adOpenForwardOnly, adLockReadOnly, adCmdText
arDeniedGroups = Null
if not rsDeniedGroups.bof and not rsDeniedGroups.eof then arDeniedGroups = rsDeniedGroups.GetRows
rsDeniedGroups.close
Set rsDeniedGroups = nothing
isDeniedMember = 0
if not IsNull(arDeniedGroups) then
for DenyCount = LBound(arDeniedGroups,2) to UBound(arDeniedGroups,2)
if InStr("," & strGroupsForUser & ",", arDeniedGroups(0,DenyCount)) then isDeniedMember = 1
next
end if
exit function
end if
if Session(strCookieURL & "DeniedForums" & MemberID) = "" or IsNull(Session(strCookieURL & "DeniedForums" & MemberID)) then
'## check group membership
strGroupMembership = Session(strCookieURL & "UserGroups" & MemberID)
if strGroupMembership <> "" then
strSql = "SELECT FORUM_ID "
strSql = strSql & "FROM " & strTablePrefix & "ALLOWED_USERGROUPS "
strSql = strSql & "WHERE USERGROUP_ID "
strSql = strSql & "IN (" & strGroupMembership & ") "
strSql = strSql & "AND PERMS = 1"
Set rsDeniedGroup = Server.CreateObject("ADODB.Recordset")
rsDeniedGroup.open strSql, my_Conn, adOpenForwardOnly, adLockReadOnly, adCmdText
arDeniedGroup = Null
if not rsDeniedGroup.bof and not rsDeniedGroup.eof then arDeniedGroup = rsDeniedGroup.GetRows
rsDeniedGroup.close
Set rsDeniedGroup = nothing
if not IsNull(arDeniedGroup) then
for DenyCount = LBound(arDeniedGroup,2) to UBound(arDeniedGroup,2)
if isDeniedMember2 <> "" then isDeniedMember2 = isDeniedMember2 & ","
isDeniedMember2 = isDeniedMember2 & arDeniedGroup(0,DenyCount)
next
end if
end if
if isDeniedMember2 = "" then
isDeniedMember2 = "-1"
end if
Session(strCookieURL & "DeniedForums" & MemberID) = isDeniedMember2
Session(strCookieURL & "DeniedForums" & MemberID) = isDeniedMember2
end if
if Session(strCookieURL & "DeniedForums" & MemberID) = "-1" then
isDeniedMember = 0
elseif InStr("," & Session(strCookieURL & "DeniedForums" & MemberID) & ",","," & fForum_ID & ",") then
isDeniedMember = 1
else
isDeniedMember = 0
end if
end function
function isAllowedMember(fForum_ID,fMemberID)
if isDeniedMember(fForum_ID,fMemberID) then
isAllowedMember = 0
exit function
end if
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
'## check first for individual permission
strSql = "SELECT FORUM_ID "
strSql = strSql & "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
isAllowedMember2 = ""
if not rsAllowedMember.EOF and not rsAllowedMember.BOF then
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
end if
rsAllowedMember.close
Set rsAllowedMember = nothing
'## check group membership
strGroupMembership = Session(strCookieURL & "UserGroups" & MemberID)
if strGroupMembership <> "" then
strSql = "SELECT FORUM_ID "
strSql = strSql & "FROM " & strTablePrefix & "ALLOWED_USERGROUPS "
strSql = strSql & "WHERE USERGROUP_ID "
strSql = strSql & "IN (" & strGroupMembership & ") "
strSql = strSql & "AND PERMS = 0"
Set rsAllowedGroup = Server.CreateObject("ADODB.Recordset")
rsAllowedGroup.open strSql, my_Conn, adOpenForwardOnly, adLockReadOnly, adCmdText
arAllowedGroup = Null
if not rsAllowedGroup.bof and not rsAllowedGroup.eof then arAllowedGroup = rsAllowedGroup.GetRows
rsAllowedGroup.close
Set rsAllowedGroup = nothing
if not IsNull(arAllowedGroup) then
for AllowCount = LBound(arAllowedGroup,2) to UBound(arAllowedGroup,2)
if isAllowedMember2 <> "" then isAllowedMember2 = isAllowedMember2 & ","
isAllowedMember2 = isAllowedMember2 & arAllowedGroup(0,AllowCount)
next
end if
end if
if isAllowedMember2 = "" then
isAllowedMember2 = "-1"
end if
Session(strCookieURL & "AllowedForums" & MemberID) = isAllowedMember2
Session(strCookieURL & "AllowedForums" & MemberID) = isAllowedMember2
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 getGroupMembership(intMemberID, intMemberType)
'## intMemberID can be either userID or UserGroupID
'## intMemberType: 1=user, 2=group
strSql = "SELECT USERGROUP_ID "
strSql = strSql & "FROM " & strTablePrefix & "USERGROUP_MEMBERS "
strSql = strSql & "WHERE MEMBER_TYPE = " & intMemberType & " "
strSql = strSql & "AND MEMBER_ID = " & intMemberID
Set rsGroups = Server.CreateObject("ADODB.Recordset")
rsGroups.open strSql, my_Conn, adOpenForwardOnly, adLockReadOnly, adCmdText
arGroups = Null
if not rsGroups.EOF and not rsGroups.BOF then arGroups = rsGroups.GetRows
rsGroups.close
Set rsGroups = Nothing
if not IsNull(arGroups) then
for iGCnt = LBound(arGroups,2) to UBound(arGroups,2)
getGroupMembership = getGroupMembership & arGroups(0,iGCnt) & "," & getGroupMembership(arGroups(0,iGCnt),2)
next
end if
if Right(getGroupMembership,1) = "," then getGroupMembership = Left(getGroupMembership,Len(getGroupMembership)-1)
end function
function getUserGroupName(fUserGroupID)
if isNull(fUserGroupID) then
getUserGroupName = "UserGroup name not found"
exit function
end if
strSql = "SELECT USERGROUP_NAME "
strSql = strSql & "FROM " & strTablePrefix & "USERGROUPS "
strSql = strSql & "WHERE USERGROUP_ID = " & chkString(fUserGroupID, "sqlstring")
Set rsGetName = Server.CreateObject("ADODB.Recordset")
rsGetName.open strSql, my_Conn
if rsGetName.EOF or rsGetName.BOF then
getUserGroupName = ""
else
getUserGroupName = rsGetName("USERGROUP_NAME")
end if
rsGetName.close
Set rsGetName = nothing
end function
function OldisAllowedMember(fForum_ID,fMemberID)
OldisAllowedMember = 0
if isDeniedMember(fForum_ID, fMemberID) then exit function
strSql = "SELECT MEMBER_ID, FORUM_ID "
strSql = strSql & "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
blnAM = 0
if not rsAllowedMember.bof and not rsAllowedMember.eof then blnAM = 1
rsAllowedMember.close
Set rsAllowedMember = nothing
'## if the member exists as an allowed member for the forum then return value 1
if blnAm = 1 then
OldisAllowedMember = 1
else
'## check for usergroup membership
strGroupsForUser = getGroupMembership(fMemberID,1)
if strGroupsForUser <> "" then
'## check to see if the user's groups are a part of this forum
strSql = "SELECT USERGROUP_ID "
strSql = strSql & "FROM " & strTablePrefix & "ALLOWED_USERGROUPS "
strSql = strSql & "WHERE FORUM_ID = " & fForum_ID & " "
strSql = strSql & "AND PERMS = 0"
Set rsAllowedUserGroups = my_Conn.execute(strSql)
blnAllowed = 0
Do While Not rsAllowedUserGroups.eof Or OldisAllowedMember <> 1
intUserGroupID = rsAllowedUserGroups("USERGROUP_ID")
if InStr("," & strGroupsForUser & ",", "," & intUserGroupID & ",") then OldisAllowedMember = 1
rsAllowedUserGroups.movenext
Loop
rsAllowedUserGroups.close
Set rsAllowedUserGroups = nothing
end if
end if
end function
'####### End UserGroup MOD #######
Function NoParse(fString)
Dim oTag, cTag
Dim roTag, rcTag
Dim oTagPos, cTagPos
Dim nTagPos
Dim counter1, counter2
Dim strCodeText
Dim Tagcount
Dim strTempString, strResultString
TagCount = 2
Dim CodeTags(2,2,2)
Dim strArray, strArray2
CodeTags(1,1,1) = "[noparse]"
CodeTags(1,2,1) = "[/noparse]"
CodeTags(1,1,2) = ""
CodeTags(1,2,2) = ""
CodeTags(2,1,1) = "[noparse]"
CodeTags(2,2,1) = "[/noparse]"
CodeTags(2,1,2) = CodeTags(1,1,2)
CodeTags(2,2,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)
for counter2 = 0 to Ubound(strArray)
if (Instr(1, strArray(counter2), cTag) > 0) then
strArray2 = split(strArray(counter2), cTag, -1)
strCodeText = trim(strArray2(0))
strCodeText = CleanCode(strCodeText)
strCodeText = replace(strCodeText, "[br]", vbNewLine)
strCodeText = replace(strCodeText, "<br />", vbNewLine)
'replace all forumcode tags to their hex equivalent
strCodeText = replace(strCodeText, "#", "#", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, "]", "]", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, "[", "[", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, "/", "/", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, ".", ".", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, ")", ")", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, "(", "(", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, ":", ":", 1, -1, 1) ' ## replace by entity equivalent
'done replacing
strCodeText = replace(strCodeText, vbNewLine, "<br />")
strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1)
else
strResultString = strResultString & strArray(counter2)
end if
next
strTempString = strResultString
strResultString = ""
end if
next
NoParse = strTempString
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 = 9
Dim ImgTags(10,2,2)
Dim strArray, strArray2
ImgTags(1,1,1) = "[img]"
ImgTags(1,2,1) = "[/img]"
ImgTags(1,1,2) = "<img name='img' src="""
ImgTags(1,2,2) = """ border=""0"" style='cursor:default' onClick='doimage(this,event)'>"
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) = "<img name='img' align=""right"" src="""
ImgTags(3,2,2) = """ id=""right"" border=""0"" style='cursor:default' onClick='doimage(this,event)'>"
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) = "<img name='img' align=""left"" src="""
ImgTags(5,2,2) = """ id=""left"" border=""0"" style='cursor:default' onClick='doimage(this,event)'>"
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)
ImgTags(7,1,1) = "[img.nr]"
ImgTags(7,2,1) = "[/img.nr]"
ImgTags(7,1,2) = "<img src="""
ImgTags(7,2,2) = """ border=""0"">"
ImgTags(8,1,1) = "[bimg=right]"
ImgTags(8,2,1) = "[/bimg=right]"
ImgTags(8,1,2) = "<img name='img' style='margin:10px;' align=""right"" src="""
ImgTags(8,2,2) = """ id=""right"" border=""1"" style='cursor:default' onClick='doimage(this,event)'>"
ImgTags(9,1,1) = "[bimg=left]"
ImgTags(9,2,1) = "[/bimg=left]"
ImgTags(9,1,2) = "<img name='img' style='margin:10px;' align=""left"" src="""
ImgTags(9,2,2) = """ id=""left"" border=""1"" style='cursor:default' onClick='doimage(this,event)'>"
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) = "<div align=""left"" id=""code""><form name=""selectall""><font face=""courier"" size=""" & strDefaultFontSize & """ id=""code""><textarea name=""getcode"" class=""code"" cols=""60"" rows=""5"" readonly id=""code"">"
CodeTags(1,2,2) = "</textarea id=""code""></font id=""code""><br /><input type=""button"" class=""bouton"" value=""" & fLang("strLangInc_Func_Common00140") & """ onClick=""JavaScript:this.form.getcode.focus();this.form.getcode.select();"" id=""1"" name=""1""></form></div id=""code"">"
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, "<br />", vbNewLine)
'####### ADD FROM V3
strCodeText = replace(strCodeText, "[br]", vbNewLine) ' ## fix
strCodeText = replace(strCodeText, "<br />", vbNewLine)
strCodeText = replace(strCodeText, "#", "#", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, "]", "]", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, "[", "[", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, "/", "/", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, ".", ".", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, ")", ")", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, "(", "(", 1, -1, 1) ' ## replace by entity equivalent
strCodeText = replace(strCodeText, ":", ":", 1, -1, 1) ' ## replace by entity equivalent
'####### END FROM V3
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 "
strSql = strSql & "FROM " & strActivePrefix & "TOPICS "
strSql = strSql & "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 "
strSql = strSql & "FROM " & strTablePrefix & "FORUM "
strSql = strSql & "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 = fLangN("strLangInc_Func_Common00020",strForumTitle)
Case "active.asp"
strNewTitle = fLangN("strLangInc_Func_Common00030",strForumTitle)
Case "faq.asp"
strNewTitle = fLangN("strLangInc_Func_Common00040",strForumTitle)
Case "search.asp"
strNewTitle = fLangN("strLangInc_Func_Common00050",strForumTitle)
Case "pop_profile.asp"
if request.querystring("mode") = "display" then
strNewTitle = fLangN("strLangInc_Func_Common00060",strForumTitle)
elseif request.querystring("mode") = "edit" then
strNewTitle = fLangN("strLangInc_Func_Common00070",strForumTitle)
else
strNewTitle = fLangN("strLangInc_Func_Common00080",strForumTitle)
end if
Case "register.asp"
strNewTitle = fLangN("strLangInc_Func_Common00100",strForumTitle)
Case "down.asp"
strNewTitle = fLangN("strLangInc_Func_Common00110",strForumTitle)
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 fName = strAnonyName then
profileLink = fName
select case fName
case strAnonyName
profileLink = fLang("strLangInc_Func_Whoisonline00200")
case else
profileLink = fName
end select
exit function
end if
if instr(fName,"img src=") > 0 then
strExtraStuff = ""
else
strExtraStuff = " title=""" & fLangN("strLangInc_Func_Common00120",fName) & """" & dWStatus(fLangN("strLangInc_Func_Common00120",fName))
end if
'## Forum SQL - Get user status
strSql = "SELECT M_LEVEL, M_ALEVEL, M_POSTS "
strSql = strSql & "FROM " & strMemberTablePrefix & "MEMBERS "
strSql = strSql & "WHERE MEMBER_ID = " & fID & " "
strSql = strSql & "AND M_NAME = '" & fName & "' "
strSql = strSql & "AND M_STATUS = " & 1
Set rsLink2 = my_Conn.Execute(strSql)
if rsLink2.EOF or rsLink2.BOF then
LinkLevelStyle = ""
else
if fID = intAdminMemberID then
LinkLevelStyle = "class=""strAdminStyle2"""
elseif rsLink2("M_LEVEL") = 3 and rsLink2("M_ALEVEL") = 1 then
LinkLevelStyle = "class=""strAdminStyle2"""
elseif rsLink2("M_LEVEL") = 3 and rsLink2("M_ALEVEL") = 0 then
LinkLevelStyle = "class=""strSemiAdminStyle4"""
elseif rsLink2("M_LEVEL") = 2 then
LinkLevelStyle = "class=""strModoStyle2"""
else
if rsLink2("M_POSTS") > cLng(intVipMemberNum) then
LinkLevelStyle = "class=""strVIPStyle2"""
else
LinkLevelStyle = ""
end if
end if
end if
rsLink2.Close
Set rsLink2 = nothing
if strUseExtendedProfile then
if strStylesCss = "1" and getStyles = "2" then
strReturn = "<a href=""pop_profile.asp?rand=" & int(10000000*rnd) & "§ionid=2&mode=display&id=" & fID & """" & strExtraStuff & ">"
else
strReturn = "<a " & LinkLevelStyle & " href=""pop_profile.asp?rand=" & int(10000000*rnd) & "§ionid=2&mode=display&id=" & fID & """" & strExtraStuff & ">"
end if
else
if strStylesCss = "1" and getStyles = "2" then
strReturn = "<a href=""JavaScript:openWindow3('pop_profile.asp?rand=" & int(10000000*rnd) & "&mode=display&id=" & fID & "')""" & strExtraStuff & ">"
else
strReturn = "<a " & LinkLevelStyle & " href=""JavaScript:openWindow3('pop_profile.asp?rand=" & int(10000000*rnd) & "&mode=display&id=" & fID & "')""" & strExtraStuff & ">"
end if
end if
profileLink = strReturn & fName & "</a>"
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
' ************************************************************
' * OnlineVideos MOD
' * bruno.in.dk [at] gmail.com
' ************************************************************
Function ReplaceGoogleVideoTags(fString)
Dim oTag, cTag
Dim roTag, rcTag
Dim oTagPos, cTagPos
Dim nTagPos
Dim counter1, counter2
Dim strCodeText
Dim Tagcount
Dim strTempString, strResultString
TagCount = 2
Dim CodeTags(2,2,2)
Dim strArray, strArray2
CodeTags(1,1,1) = "[gvid]"
CodeTags(1,2,1) = "[/gvid]"
CodeTags(1,1,2) = "<div class=""media""><script language=""javascript"">EmbedGvidT("""
CodeTags(1,2,2) = """)</script></div><div class=""break""></div>"
CodeTags(2,1,1) = "[GVID]"
CodeTags(2,2,1) = "[/GVID]"
CodeTags(2,1,2) = CodeTags(1,1,2)
CodeTags(2,2,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)
for counter2 = 0 to Ubound(strArray)
if (Instr(1, strArray(counter2), cTag) > 0) then
strArray2 = split(strArray(counter2), cTag, -1)
strCodeText = trim(strArray2(0))
strCodeText = replace(strCodeText,"http://video.google.com/videoplay?docid=","http://video.google.com/googleplayer.swf?docId=")
if instr(strCodeText,",") > 0 or _
instr(strCodeText,")") >0 or _
instr(strCodeText,"(") >0 or _
instr(strCodeText,";") >0 or _
instr(strCodeText,"""") >0 or _
instr(strCodeText,"<") >0 or _
instr(strCodeText,">") >0 or _
instr(strCodeText,"[") >0 or _
instr(strCodeText,"]") >0 or _
instr(strCodeText,",") >0 then
strCodeText = "illegal"
end if
strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1)
else
strResultString = strResultString & strArray(counter2)
end if
next
strTempString = strResultString
strResultString = ""
end if
next
ReplaceGoogleVideoTags = strTempString
end function
Function ReplaceTubeTags(fString)
Dim oTag, cTag
Dim roTag, rcTag
Dim oTagPos, cTagPos
Dim nTagPos
Dim counter1, counter2
Dim strCodeText
Dim Tagcount
Dim strTempString, strResultString
TagCount = 2
Dim CodeTags(2,2,2)
Dim strArray, strArray2
CodeTags(1,1,1) = "[tube]"
CodeTags(1,2,1) = "[/tube]"
CodeTags(1,1,2) = "<div class=""tube""><script language=""javascript"">EmbedYT("""
CodeTags(1,2,2) = """,375,298,""false"",""high"",""white"",""white"")</script></div><div class=""break""></div>"
CodeTags(2,1,1) = "[TUBE]"
CodeTags(2,2,1) = "[/TUBE]"
CodeTags(2,1,2) = CodeTags(1,1,2)
CodeTags(2,2,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)
for counter2 = 0 to Ubound(strArray)
if (Instr(1, strArray(counter2), cTag) > 0) then
strArray2 = split(strArray(counter2), cTag, -1)
strCodeText = trim(strArray2(0))
strCodeText = replace(strCodeText,"/watch?v=","/v/")
if instr(strCodeText,",") > 0 or _
instr(strCodeText,")") >0 or _
instr(strCodeText,"(") >0 or _
instr(strCodeText,";") >0 or _
instr(strCodeText,"""") >0 or _
instr(strCodeText,"<") >0 or _
instr(strCodeText,">") >0 or _
instr(strCodeText,"[") >0 or _
instr(strCodeText,"]") >0 or _
instr(strCodeText,",") >0 then
strCodeText = "illegal"
end if
strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1)
else
strResultString = strResultString & strArray(counter2)
end if
next
strTempString = strResultString
strResultString = ""
end if
next
ReplaceTubeTags = strTempString
end function
Function ReplaceFlashTags(fString)
Dim oTag, cTag
Dim roTag, rcTag
Dim oTagPos, cTagPos
Dim nTagPos
Dim counter1, counter2
Dim strCodeText
Dim Tagcount
Dim strTempString, strResultString
TagCount = 2
Dim CodeTags(2,2,2)
Dim strArray, strArray2
CodeTags(1,1,1) = "[flash]"
CodeTags(1,2,1) = "[/flash]"
'if mlev > 0 then
'user logged in, show the media """,320,240,""false"",""high"",""white"",""white"")
CodeTags(1,1,2) = "<div class=""media""><script language=""javascript"">EmbedFlashT("""
CodeTags(1,2,2) = """,640,480,""false"",""high"",""white"",""white"")</script></div><div class=""break""></div>"
'else
'user not logged in, show a link to the media
'CodeTags(1,1,2) = "<div class=""wbf""><img src=""images\delete.gif"" border=0 align=""absmiddle""> You're not logged in! Click <a href=""vid.asp?s="
'CodeTags(1,2,2) = "&t=f"" title=""click to watch"" target=""_new"">here</a> to watch this flash animation.</div><div class=""break""></div>"
'end if
CodeTags(2,1,1) = "[FLASH]"
CodeTags(2,2,1) = "[/FLASH]"
CodeTags(2,1,2) = CodeTags(1,1,2)
CodeTags(2,2,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)
for counter2 = 0 to Ubound(strArray)
if (Instr(1, strArray(counter2), cTag) > 0) then
strArray2 = split(strArray(counter2), cTag, -1)
strCodeText = trim(strArray2(0))
if instr(strCodeText,",") > 0 or _
instr(strCodeText,")") >0 or _
instr(strCodeText,"(") >0 or _
instr(strCodeText,";") >0 or _
instr(strCodeText,"""") >0 or _
instr(strCodeText,"<") >0 or _
instr(strCodeText,">") >0 or _
instr(strCodeText,"[") >0 or _
instr(strCodeText,"]") >0 or _
instr(strCodeText,",") >0 then
strCodeText = "illegal"
end if
strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1)
else
strResultString = strResultString & strArray(counter2)
end if
next
strTempString = strResultString
strResultString = ""
end if
next
ReplaceFlashTags = strTempString
end function
Function ReplaceMetaCafeTags(fString)
Dim oTag, cTag
Dim roTag, rcTag
Dim oTagPos, cTagPos
Dim nTagPos
Dim counter1, counter2
Dim strCodeText
Dim Tagcount
Dim strTempString, strResultString
TagCount = 2
Dim CodeTags(2,2,2)
Dim strArray, strArray2
CodeTags(1,1,1) = "[metacafe]"
CodeTags(1,2,1) = "[/metacafe]"
CodeTags(1,1,2) = "<div class=""media""><script language=""javascript"">EmbedMCT("""
CodeTags(1,2,2) = """,400,345,""false"",""high"",""white"",""white"")</script></div><div class=""break""></div>"
CodeTags(2,1,1) = "[METACAFE]"
CodeTags(2,2,1) = "[/METACAFE]"
CodeTags(2,1,2) = CodeTags(1,1,2)
CodeTags(2,2,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)
for counter2 = 0 to Ubound(strArray)
if (Instr(1, strArray(counter2), cTag) > 0) then
strArray2 = split(strArray(counter2), cTag, -1)
strCodeText = trim(strArray2(0))
if right(lcase(strCodeText),4) <> ".swf" then
strCodeText = left(strCodeText,(len(strCodeText)-1)) & ".swf"
strCodeText = replace(strCodeText,"/watch/","/fplayer/")
end if
if instr(strCodeText,",") > 0 or _
instr(strCodeText,")") >0 or _
instr(strCodeText,"(") >0 or _
instr(strCodeText,";") >0 or _
instr(strCodeText,"""") >0 or _
instr(strCodeText,"<") >0 or _
instr(strCodeText,">") >0 or _
instr(strCodeText,"[") >0 or _
instr(strCodeText,"]") >0 or _
instr(strCodeText,"http://www.metacafe.com/fplayer/") = 0 or _
instr(strCodeText,",") >0 then
strCodeText = "illegal"
end if
strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1)
else
strResultString = strResultString & strArray(counter2)
end if
next
strTempString = strResultString
strResultString = ""
end if
next
ReplaceMetaCafeTags = strTempString
end function
Function ReplaceMySpaceTags(fString)
Dim oTag, cTag
Dim roTag, rcTag
Dim oTagPos, cTagPos
Dim nTagPos
Dim counter1, counter2
Dim strCodeText
Dim Tagcount
Dim strTempString, strResultString
TagCount = 2
Dim CodeTags(2,2,2)
Dim strArray, strArray2
CodeTags(1,1,1) = "[myspace]"
CodeTags(1,2,1) = "[/myspace]"
CodeTags(1,1,2) = "<div class=""tube""><script language=""javascript"">EmbedMSVT("""
CodeTags(1,2,2) = """)</script></div><div class=""break""></div>"
CodeTags(2,1,1) = "[TUBE]"
CodeTags(2,2,1) = "[/TUBE]"
CodeTags(2,1,2) = CodeTags(1,1,2)
CodeTags(2,2,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)
for counter2 = 0 to Ubound(strArray)
if (Instr(1, strArray(counter2), cTag) > 0) then
strArray2 = split(strArray(counter2), cTag, -1)
strCodeText = trim(strArray2(0))
strCodeText = replace(strCodeText,"http://vids.myspace.com/index.cfm?fuseaction=vids.individual&videoid=","")
if instr(strCodeText,",") > 0 or _
instr(strCodeText,")") >0 or _
instr(strCodeText,"(") >0 or _
instr(strCodeText,";") >0 or _
instr(strCodeText,"""") >0 or _
instr(strCodeText,"<") >0 or _
instr(strCodeText,">") >0 or _
instr(strCodeText,"[") >0 or _
instr(strCodeText,"]") >0 or _
instr(strCodeText,",") >0 or _
len(strCodeText) < 3 or _
len(strCodeText) > 14 then
strCodeText = "illegal"
end if
strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1)
else
strResultString = strResultString & strArray(counter2)
end if
next
strTempString = strResultString
strResultString = ""
end if
next
ReplaceMySpaceTags = strTempString
end function
Function ReplaceQTTags(fString)
Dim oTag, cTag
Dim roTag, rcTag
Dim oTagPos, cTagPos
Dim nTagPos
Dim counter1, counter2
Dim strCodeText
Dim Tagcount
Dim strTempString, strResultString
TagCount = 2
Dim CodeTags(2,2,2)
Dim strArray, strArray2
CodeTags(1,1,1) = "[qt]"
CodeTags(1,2,1) = "[/qt]"
'if mlev > 0 then
'user logged in, show the media
CodeTags(1,1,2) = "<div class=""media""><script language=""javascript"">EmbedQuicktimeT("""
CodeTags(1,2,2) = """,320,256,false)</script></div><div class=""break""></div>"
'else
'user not logged in, show a link to the media
'CodeTags(1,1,2) = "<div class=""wbf""><img src=""images\delete.gif"" border=0 align=""absmiddle""> You're not logged in! Click <a href=""vid.asp?s="
'CodeTags(1,2,2) = "&t=q"" title=""click to watch"" target=""_new"">here</a> to watch this clip.</div><div class=""break""></div>"
'end if
CodeTags(2,1,1) = "[QT]"
CodeTags(2,2,1) = "[/QT]"
CodeTags(2,1,2) = CodeTags(1,1,2)
CodeTags(2,2,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)
for counter2 = 0 to Ubound(strArray)
if (Instr(1, strArray(counter2), cTag) > 0) then
strArray2 = split(strArray(counter2), cTag, -1)
strCodeText = trim(strArray2(0))
if instr(strCodeText,",") > 0 or _
instr(strCodeText,")") >0 or _
instr(strCodeText,"(") >0 or _
instr(strCodeText,";") >0 or _
instr(strCodeText,"""") >0 or _
instr(strCodeText,"<") >0 or _
instr(strCodeText,">") >0 or _
instr(strCodeText,"[") >0 or _
instr(strCodeText,"]") >0 or _
instr(strCodeText,",") >0 then
strCodeText = "illegal"
end if
strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1)
else
strResultString = strResultString & strArray(counter2)
end if
next
strTempString = strResultString
strResultString = ""
end if
next
ReplaceQTTags = strTempString
end function
Function ReplaceWMVTags(fString)
Dim oTag, cTag
Dim roTag, rcTag
Dim oTagPos, cTagPos
Dim nTagPos
Dim counter1, counter2
Dim strCodeText
Dim Tagcount
Dim strTempString, strResultString
TagCount = 2
Dim CodeTags(2,2,2)
Dim strArray, strArray2
CodeTags(1,1,1) = "[wmv]"
CodeTags(1,2,1) = "[/wmv]"
'if mlev > 0 then
'user logged in, show the media
CodeTags(1,1,2) = "<div class=""media""><script language=""javascript"">EmbedWMVideoT("""
CodeTags(1,2,2) = """,320,300,false)</script></div><div class=""break""></div>"
'else
'user not logged in, show a link to the media
'CodeTags(1,1,2) = "<div class=""wbf""><img src=""images\delete.gif"" border=0 align=""absmiddle""> You're not logged in! Click <a href=""vid.asp?s="
'CodeTags(1,2,2) = "&t=w"" title=""click to watch"" target=""_new"">here</a> to watch this clip.</div><div class=""break""></div>"
'end if
CodeTags(2,1,1) = "[WMV]"
CodeTags(2,2,1) = "[/WMV]"
CodeTags(2,1,2) = CodeTags(1,1,2)
CodeTags(2,2,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)
for counter2 = 0 to Ubound(strArray)
if (Instr(1, strArray(counter2), cTag) > 0) then
strArray2 = split(strArray(counter2), cTag, -1)
strCodeText = trim(strArray2(0))
if instr(strCodeText,",") > 0 or _
instr(strCodeText,")") >0 or _
instr(strCodeText,"(") >0 or _
instr(strCodeText,";") >0 or _
instr(strCodeText,"""") >0 or _
instr(strCodeText,"<") >0 or _
instr(strCodeText,">") >0 or _
instr(strCodeText,"[") >0 or _
instr(strCodeText,"]") >0 or _
instr(strCodeText,",") >0 then
strCodeText = "illegal"
end if
strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1)
else
strResultString = strResultString & strArray(counter2)
end if
next
strTempString = strResultString
strResultString = ""
end if
next
ReplaceWMVTags = strTempString
end function
Function ReplaceRVTags(fString)
Dim oTag, cTag
Dim roTag, rcTag
Dim oTagPos, cTagPos
Dim nTagPos
Dim counter1, counter2
Dim strCodeText
Dim Tagcount
Dim strTempString, strResultString
TagCount = 2
Dim CodeTags(2,2,2)
Dim strArray, strArray2
CodeTags(1,1,1) = "[rv]"
CodeTags(1,2,1) = "[/rv]"
'if mlev > 0 then
'user logged in, show the media
CodeTags(1,1,2) = "<div class=""media""><script language=""javascript"">EmbedRealVideoT("""
CodeTags(1,2,2) = """,320,300,false)</script></div><div class=""break""></div>"
'else
'user not logged in, show a link to the media
'CodeTags(1,1,2) = "<div class=""wbf""><img src=""images\delete.gif"" border=0 align=""absmiddle""> You're not logged in! Click <a href=""vid.asp?s="
'CodeTags(1,2,2) = "&t=w"" title=""click to watch"" target=""_new"">here</a> to watch this clip.</div><div class=""break""></div>"
'end if
CodeTags(2,1,1) = "[RV]"
CodeTags(2,2,1) = "[/RV]"
CodeTags(2,1,2) = CodeTags(1,1,2)
CodeTags(2,2,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)
for counter2 = 0 to Ubound(strArray)
if (Instr(1, strArray(counter2), cTag) > 0) then
strArray2 = split(strArray(counter2), cTag, -1)
strCodeText = trim(strArray2(0))
if instr(strCodeText,",") > 0 or _
instr(strCodeText,")") >0 or _
instr(strCodeText,"(") >0 or _
instr(strCodeText,";") >0 or _
instr(strCodeText,"""") >0 or _
instr(strCodeText,"<") >0 or _
instr(strCodeText,">") >0 or _
instr(strCodeText,"[") >0 or _
instr(strCodeText,"]") >0 or _
instr(strCodeText,",") >0 then
strCodeText = "illegal"
end if
strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1)
else
strResultString = strResultString & strArray(counter2)
end if
next
strTempString = strResultString
strResultString = ""
end if
next
ReplaceRVTags = strTempString
end function
Function ReplaceMP3Tags(fString)
Dim oTag, cTag
Dim roTag, rcTag
Dim oTagPos, cTagPos
Dim nTagPos
Dim counter1, counter2
Dim strCodeText
Dim Tagcount
Dim strTempString, strResultString
TagCount = 2
Dim CodeTags(2,2,2)
Dim strArray, strArray2
CodeTags(1,1,1) = "[mp3]"
CodeTags(1,2,1) = "[/mp3]"
'if mlev > 0 then
'user logged in, show the media
CodeTags(1,1,2) = "<div class=""media""><script language=""javascript"">EmbedMP3("""
CodeTags(1,2,2) = """,290,300,false)</script></div><div class=""break""></div>"
'else
'user not logged in, show a link to the media
'CodeTags(1,1,2) = "<div class=""wbf""><img src=""images\delete.gif"" border=0 align=""absmiddle""> You're not logged in! Click <a href=""vid.asp?s="
'CodeTags(1,2,2) = "&t=w"" title=""click to watch"" target=""_new"">here</a> to watch this clip.</div><div class=""break""></div>"
'end if
CodeTags(2,1,1) = "[mp3]"
CodeTags(2,2,1) = "[/mp3]"
CodeTags(2,1,2) = CodeTags(1,1,2)
CodeTags(2,2,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)
for counter2 = 0 to Ubound(strArray)
if (Instr(1, strArray(counter2), cTag) > 0) then
strArray2 = split(strArray(counter2), cTag, -1)
strCodeText = trim(strArray2(0))
if instr(strCodeText,",") > 0 or _
instr(strCodeText,")") >0 or _
instr(strCodeText,"(") >0 or _
instr(strCodeText,";") >0 or _
instr(strCodeText,"""") >0 or _
instr(strCodeText,"<") >0 or _
instr(strCodeText,">") >0 or _
instr(strCodeText,"[") >0 or _
instr(strCodeText,"]") >0 or _
instr(strCodeText,",") >0 then
strCodeText = "illegal"
end if
strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1)
else
strResultString = strResultString & strArray(counter2)
end if
next
strTempString = strResultString
strResultString = ""
end if
next
ReplaceMP3Tags = strTempString
end function
'##### PDF Begin #####
Function ReplacePDFTags(fString)
Dim oTag, cTag
Dim roTag, rcTag
Dim oTagPos, cTagPos
Dim nTagPos
Dim counter1, counter2
Dim strCodeText
Dim Tagcount
Dim strTempString, strResultString
TagCount = 2
Dim CodeTags(2,2,2)
Dim strArray, strArray2
CodeTags(1,1,1) = "[pdf]"
CodeTags(1,2,1) = "[/pdf]"
CodeTags(1,1,2) = "<div class=""media""><script language=""javascript"">EmbedPDF("""
CodeTags(1,2,2) = """,625,475,false)</script></div><div class=""break""></div>"
CodeTags(2,1,1) = "[pdf]"
CodeTags(2,2,1) = "[/pdf]"
CodeTags(2,1,2) = CodeTags(1,1,2)
CodeTags(2,2,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)
for counter2 = 0 to Ubound(strArray)
if (Instr(1, strArray(counter2), cTag) > 0) then
strArray2 = split(strArray(counter2), cTag, -1)
strCodeText = trim(strArray2(0))
if instr(strCodeText,",") > 0 or _
instr(strCodeText,")") >0 or _
instr(strCodeText,"(") >0 or _
instr(strCodeText,";") >0 or _
instr(strCodeText,"""") >0 or _
instr(strCodeText,"<") >0 or _
instr(strCodeText,">") >0 or _
instr(strCodeText,"[") >0 or _
instr(strCodeText,"]") >0 or _
instr(strCodeText,",") >0 then
strCodeText = "illegal"
end if
strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1)
else
strResultString = strResultString & strArray(counter2)
end if
next
strTempString = strResultString
strResultString = ""
end if
next
ReplacePDFTags = strTempString
end function
'##### PDF End #####
'##### Media Box Begin #####
Function ReplaceMediaTags(fString)
Dim oTag, cTag
Dim roTag, rcTag
Dim oTagPos, cTagPos
Dim nTagPos
Dim counter1, counter2
Dim strCodeText
Dim Tagcount
Dim strTempString, strResultString
TagCount = 2
Dim CodeTags(2,2,2)
Dim strArray, strArray2
CodeTags(1,1,1) = "[media]"
CodeTags(1,2,1) = "[/media]"
CodeTags(1,1,2) = "<div><script language=""javascript"">EmbedMedia("""
CodeTags(1,2,2) = """,290,300,false)</script></div><div></div>"
CodeTags(2,1,1) = "[media]"
CodeTags(2,2,1) = "[/media]"
CodeTags(2,1,2) = CodeTags(1,1,2)
CodeTags(2,2,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)
for counter2 = 0 to Ubound(strArray)
if (Instr(1, strArray(counter2), cTag) > 0) then
strArray2 = split(strArray(counter2), cTag, -1)
strCodeText = trim(strArray2(0))
if instr(strCodeText,",") > 0 or _
instr(strCodeText,")") >0 or _
instr(strCodeText,"(") >0 or _
instr(strCodeText,";") >0 or _
instr(strCodeText,"""") >0 or _
instr(strCodeText,"<") >0 or _
instr(strCodeText,">") >0 or _
instr(strCodeText,"[") >0 or _
instr(strCodeText,"]") >0 or _
instr(strCodeText,",") >0 then
strCodeText = "illegal"
end if
strResultString = strResultString & roTag & strCodeText & rcTag & strArray2(1)
else
strResultString = strResultString & strArray(counter2)
end if
next
strTempString = strResultString
strResultString = ""
end if
next
ReplaceMediaTags = strTempString
end function
'##### Media Box End #####
Sub WriteFooter() %>
<!--#INCLUDE FILE="inc_footer.asp"-->
<% end sub
Sub WriteFooterShort() %>
<!--#INCLUDE FILE="inc_footer_short.asp"-->
<% end sub
'if strUseAttachments = "1" then
function countSubstrInStr(str,subStr)
Dim counter, tempStr, exitWhile
exitWhile = false
counter = 0
tempStr=str
while exitWhile<>true
subStrLoc=instr(tempStr,subStr)
if subStrLoc <> 0 then
counter = counter + 1
tempStr=mid(tempStr,subStrLoc+len(subStr))
else
exitWhile=true
end if
wend
countSubstrInStr=counter
end function
%><!--#INCLUDE FILE="inc_UploadConfig.asp" --><%
function downloadFilePost(fString)
if instr(fString,"[file]")<>0 and instr(fString,"[/file]")<>0 then
Dim fileTag1, fileTag2, begStr, endStr
Dim leftPart, rightPart, midPart
Dim arrFileInfo, fileName, fileNameExt, memberFldrID, cSF, forumID
fileTag1 = countSubstrInStr(fString,"[file]")
fileTag2 = countSubstrInStr(fString,"[/file]")
for i=1 to fileTag1
begStr = instr(fString,"[file]")+6
endStr = instr(fString,"[/file]")
leftPart=Left(fString,begStr-7)
rightPart=right(fString,len(fString)-endStr -6)
arrfileInfo=Mid(fString,begStr,endStr-begStr)
arrFileInfo=Split(arrfileInfo,",")
fileName=arrFileInfo(0)
fileNameExt = UCase(Mid(fileName,InStrRev(fileName,".")))
memberFldrID=arrFileInfo(1)
cSF=arrFileInfo(2)
forumID=arrFileInfo(3)
midPart=""
midPart=midPart & " <table " & TableBorderColor1 & " border=""0"" " & Cellspacing & " cellpadding=""4"" align=""center"">" & vbNewline
midPart=midPart & " <tr>" & vbNewline
midPart=midPart & " <td " & ForumCellColor & " colspan=""2"">" & vbNewline
midPart=midPart & " <font face=""" & strDefaultFontFace & """ size=""" & strFooterFontSize & """ " & ForumFontColor & ">" & vbNewline
if disableAllFileSharing=false and disableDownload=false then
if forumID<>"" and sharedFilesMode = 2 then
physicalUploadFolder = physicalUploadFolder & "\" & forumID
physicalUploadTextFolder = physicalUploadTextFolder & "\" & forumID
end if
if cSF="" then
currentFile = physicalUploadFolder& "\" & memberFldrID & "\" & fileName
currentTextFile = physicalUploadTextFolder& "\" & memberFldrID & "\" & fileName &".txt"
else
currentFile = physicalUploadFolder& "\" & memberFldrID & "\" & cSF & "\" & fileName
currentTextFile = physicalUploadTextFolder& "\" & memberFldrID & "\" & cSF & "\" & fileName &".txt"
end if
Set theFSO=Server.CreateObject("Scripting.FileSystemObject")
if theFSO.FileExists(currentFile) then
Set thisFile=theFSO.GetFile(currentFile)
fileSize=convertSize(thisFile.size)
fileDate=DateAdd("h", strTimeAdjust , thisFile.DateLastModified)
if theFSO.FileExists(currentTextFile) then
currentFileInfo=readFileInfoText(currentTextFile)
fileDesc = currentFileInfo(0)
downloadNo = currentFileInfo(1)
fileCat = currentFileInfo(2)
membersAccess = cLng(currentFileInfo(3))
guestsAccess = cLng(currentFileInfo(4))
else
fileDesc= ""
downloadNo = 0
fileCat=0
membersAccess = 2
guestsAccess = 0
writeFileInfoText currentTextFile,fileDesc,downloadNo,fileCat,membersAccess,guestsAccess
fileDesc= fLang("strLangI_UploadFunc00010") & vbNewLine
end if
Set thisFile = nothing
Set theFSO = nothing
fString=currentTextFile
select case fileNameExt
case ".JPG", ".JPEG", ".GIF", ".PNG"
midPart=midPart & "<b>" & fLang("strLangI_F_Common00700") & "</b> "
midPart=midPart & fileName
midPart=midPart & " (" & fileSize & ")"
midPart=midPart & "<br />" & fLang("strLangI_UploadFunc00050") & " " & fileDate
midPart=midPart & "<br />" & fLangN("strLangI_F_Common00710",downloadNo)
if fileCatMode = true then
midPart=midPart & "<br /><b>" & fLang("strLangPost00360") & "</b> " & fileCatList(fileCat)
end if
midPart=midPart & "<br /><b>" & fLang("strLangFile_Library00350") & ":</b><br />" & fileDesc & "<br />"
midPart=midPart & "<br /><img name='img' src=""download.asp?forumID="&forumID&"&fileName="&fileName&"&memberFldrID="&memberFldrID&"&cSF="&cSF&""" style='cursor:default' onClick='doimage(this,event)'>"
case ".SWF"
Dim width, height
width=arrFileInfo(4)
height=arrFileInfo(5)
width=replace(width,"width=","")
height=replace(height,"height=","")
midPart=midPart & "<b>" & fLang("strLangI_F_Common00720") & "</b> "
midPart=midPart & fileName
midPart=midPart & " (" & fileSize & ")"
midPart=midPart & "<br />" & fLang("strLangI_UploadFunc00050") & " " & fileDate
midPart=midPart & "<br />" & fLangN("strLangI_F_Common00710",downloadNo)
if fileCatMode = true then
midPart=midPart & "<br /><b>" & fLang("strLangPost00360") & "</b> " & fileCatList(fileCat)
end if
midPart=midPart&"<br /><b>" & fLang("strLangFile_Library00350") & ":</b><br />" & fileDesc & "<br />"
midPart=midPart&"<br /><embed src=""download.asp?forumID="&forumID&"&fileName="&fileName&"&memberFldrID="&memberFldrID&"&cSF="&cSF&""" quality=""high"" pluginspage=""http://www.macromedia.com/go/getflashplayer"" type=""application/x-shockwave-flash"" width="""& width &""" height="""& height &"""></embed></object>"
case else
midPart=midPart & "<br /><b>" & fLang("strLangI_F_Common00730") & "</b> "
midPart=midPart & " <a href=""download.asp?forumID="&forumID&"&fileName="&fileName&"&memberFldrID="&memberFldrID&"&cSF="&cSF&""">"
midPart=midPart & fileName
midPart=midPart & "</a>"
midPart=midPart & " (" & fileSize & ")"
midPart=midPart & "<br />" & fLang("strLangI_UploadFunc00050") & " " & fileDate
midPart=midPart & "<br />" & fLangN("strLangI_UploadFunc00060",downloadNo)
if fileCatMode = true then
midPart=midPart & "<br /><b>" & fLang("strLangPost00360") & "</b> " & fileCatList(fileCat)
end if
midPart=midPart & "<br /><b>" & fLang("strLangFile_Library00350") & ":</b><br />" & fileDesc & "<br />"
end select
else
midPart=midPart & "<b>" & fLang("strLangI_F_Common00740") & "</b> "
midPart=midPart & fileName
end if
elseif disableAllFileSharing = true or disableDownload = true then
midPart=midPart & "<font color="""&strHiLiteFontColor&"""><b>" & fLang("strLangI_F_Common00750") & "</b></font> " & fileName
end if
midPart=midPart & " </font></td></tr>"
midPart=midPart & " </table>"
fString = leftPart & midPart & rightPart
next
end if
downloadFilePost=fString
end function
'end if
' HEADER TEXT
sub IntroText()
select case sectionid
case 1 ' Events & Calendar
Response.Write fLang("strLangInc_Header00670")
case 2 ' Members Area
Response.Write fLang("strLangInc_Header00680")
case 3 ' Help & FAQ
Response.Write fLang("strLangInc_Header00690")
case 4 ' Search
Response.Write fLang("strLangInc_Header00700")
case 5 ' Link
Response.Write fLang("strLangInc_Header00710")
case 6 ' Homepage
Response.Write fLang("strLangInc_Header00720")
case 7 ' Guestbook
Response.Write fLang("strLangInc_Header00960")
case 888 ' Admin
Response.Write fLang("strLangInc_Header00730")
case 999 ' Admin Mod Config
Response.Write fLang("strLangInc_Header00730")
case else ' Default
Response.Write fLang("strLangInc_Header00740")
end select
end sub
' LVL 1 NAVIGATION LINKS
sub Level1Links()
select case sectionid
case 1 ' Events & Calendar
if strShowEvents = "1" then
Dim dateHolder
if Request.Querystring("date")="" then
dateHolder=DateValue(strForumTimeAdjust)
else
dateHolder=DateValue(CDate(Request.Querystring("date")))
end if
Response.Write("<span class=""spnMessageText""><a href=""cal.asp?rand=" & int(10000000*rnd) & "&date=" & dateHolder & """ target=""_self"" title=""" & fLang("strLangEvents_Calendar00010") & """" & dWStatus(fLang("strLangEvents_Calendar00010")) & " tabindex=""-1"">" & fLang("strLangCla00030") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""cal.asp?rand=" & int(10000000*rnd) & "&view=weekly&date=" & dateHolder & """ target=""_self"" title=""" & fLang("strLangEvents_Calendar00010") & """" & dWStatus(fLang("strLangEvents_Calendar00010")) & " tabindex=""-1"">" & fLang("strLangCla00040") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""cal.asp?rand=" & int(10000000*rnd) & "&view=monthly&date=" & dateHolder & """ target=""_self"" title=""" & fLang("strLangEvents_Calendar00010") & """" & dWStatus(fLang("strLangEvents_Calendar00010")) & " tabindex=""-1"">" & fLang("strLangCla00050") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""cal.asp?rand=" & int(10000000*rnd) & "&view=yearly&date=" & dateHolder & """ target=""_self"" title=""" & fLang("strLangEvents_Calendar00010") & """" & dWStatus(fLang("strLangEvents_Calendar00010")) & " tabindex=""-1"">" & fLang("strLangCla00060") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""cal.asp?rand=" & int(10000000*rnd) & "&view=eventslist"" target=""_self"" title=""" & fLang("strLangEvents_Calendar00010") & """" & dWStatus(fLang("strLangEvents_Calendar00010")) & " tabindex=""-1"">" & fLang("strLangCla00070") & "</a></span>" & vbNewLine & _
" " & vbNewLine)
end if
case 2 ' Members Area
if (chkUser((strDBNTUserName), (Request.Cookies(strUniqueID & "User")("Pword")), -1) = 0) then
Response.Write("<span class=""spnMessageText""><a href=""register.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangJava_Menu00110") & """" & dWStatus(fLang("strLangJava_Menu00110")) & " tabindex=""-1"">" & fLang("strLangJava_Menu00110") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""register.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00800") & """" & dWStatus(fLang("strLangInc_Header00800")) & " tabindex=""-1"">" & fLang("strLangInc_Header00800") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""register.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00810") & """" & dWStatus(fLang("strLangInc_Header00810")) & " tabindex=""-1"">" & fLang("strLangInc_Header00810") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""password.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00820") & """" & dWStatus(fLang("strLangInc_Header00820")) & " tabindex=""-1"">" & fLang("strLangLogin00150") & "</a></span>" & vbNewLine & _
" " & vbNewLine)
else
Response.Write("<span class=""spnMessageText""><a href=""my.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00830") & """" & dWStatus(fLang("strLangInc_Header00830")) & " tabindex=""-1"">" & fLang("strLangInc_Header00840") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""my_edit_config.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangMy00300") & """" & dWStatus(fLang("strLangMy00300")) & " tabindex=""-1"">" & fLang("strLangMy00300") & "</a></span>" & vbNewLine)
if strBuddyList = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""buddy.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangPop_buddy00130") & """" & dWStatus(fLang("strLangPop_buddy00130")) & " tabindex=""-1"">" & fLang("strLangPop_buddy00130") & "</a></span>" & vbNewLine)
end if
if strShowJavaMenu = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""pop_profile.asp?rand=" & int(10000000*rnd) & "&mode=Edit§ionid=2"" target=""_self"" title=""" & fLang("strLangPop_Profile00960") & """" & dWStatus(fLang("strLangPop_Profile00960")) & " tabindex=""-1"">" & fLang("strLangInc_Header00260") & "</a></span>" & vbNewLine)
end if
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""newmembers.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangDefault00820") & """" & dWStatus(fLang("strLangDefault00820")) & " tabindex=""-1"">" & fLang("strLangJava_Menu00070") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""members.asp?rand=" & int(10000000*rnd) & "§ionid=4"" target=""_self"" title=""" & fLang("strLangInc_Header00350") & """" & dWStatus(fLang("strLangInc_Header00350")) & " tabindex=""-1"">" & fLang("strLangSearch00530") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""register.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangJava_Menu00110") & """" & dWStatus(fLang("strLangJava_Menu00110")) & " tabindex=""-1"">" & fLang("strLangJava_Menu00110") & "</a></span>" & vbNewLine)
if strShowJavaMenu = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""subscription_list.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00860") & """" & dWStatus(fLang("strLangInc_Header00860")) & " tabindex=""-1"">" & fLang("strLangPop_Help00180") & "</a></span>" & vbNewLine)
end if
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""favourites_home.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00870") & """" & dWStatus(fLang("strLangInc_Header00870")) & " tabindex=""-1"">" & fLang("strLangJava_Menu00130") & "</a></span>" & vbNewLine)
if strBookMark = "1" and strShowJavaMenu = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""bookmarks.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00750") & """" & dWStatus(fLang("strLangInc_Header00750")) & " tabindex=""-1"">" & fLang("strLangInc_Header00760") & "</a></span>" & vbNewLine)
end if
end if
case 3 ' Help & FAQ
Response.Write("<span class=""spnMessageText""><a href=""faq.asp?rand=" & int(10000000*rnd) & "§ionid=3"" target=""_self"" title=""" & fLang("strLangFaq00020") & """" & dWStatus(fLang("strLangFaq00020")) & " tabindex=""-1"">" & fLang("strLangFaq00020") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""register.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00810") & """" & dWStatus(fLang("strLangInc_Header00810")) & " tabindex=""-1"">" & fLang("strLangInc_Header00810") & "</a></span>" & vbNewLine)
if (chkUser((strDBNTUserName), (Request.Cookies(strUniqueID & "User")("Pword")), -1) = 0) then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""password.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00270") & """" & dWStatus(fLang("strLangInc_Header00270")) & " tabindex=""-1"">" & fLang("strLangLogin00150") & "</a></span>" & vbNewLine)
end if
case 4 ' Search
Response.Write("<span class=""spnMessageText""><a href=""membersearch.asp?rand=" & int(10000000*rnd) & "§ionid=4"" target=""_self"" title=""" & fLang("strLangInc_Mainmenu00420") & """" & dWStatus(fLang("strLangInc_Mainmenu00420")) & " tabindex=""-1"">" & fLang("strLangInc_Mainmenu00430") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""search_advanced.asp?rand=" & int(10000000*rnd) & "§ionid=4"" target=""_self"" title=""" & fLang("strLangSearch_Advanced00140") & """" & dWStatus(fLang("strLangSearch_Advanced00140")) & " tabindex=""-1"">" & fLang("strLangInc_Mainmenu00370") & "</a></span>" & vbNewLine)
if mLev >= cLng(strSLDisplay) then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""searchlog.asp?rand=" & int(10000000*rnd) & "§ionid=4"" target=""_self"" title=""" & fLang("strLangSearchlog00320") & """" & dWStatus(fLang("strLangSearchlog00320")) & " tabindex=""-1"">" & fLang("strLangSearchlog00010") & "</a></span>" & vbNewLine)
end if
if strGoogleSearch = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""myowngoogle.asp?rand=" & int(10000000*rnd) & "§ionid=4"" target=""_self"" title=""" & fLang("strLangGoogle00010") & """" & dWStatus(fLang("strLangGoogle00010")) & " tabindex=""-1"">" & fLang("strLangGoogle00010") & "</a></span>" & vbNewLine)
end if
if strPortalPhotoAlbum = "1" or strForumPhotoAlbum = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""photo_album.asp?rand=" & int(10000000*rnd) & "§ionid=4"" target=""_self"" title=""" & fLang("strLangInc_Mainmenu00470") & """" & dWStatus(fLang("strLangInc_Mainmenu00470")) & " tabindex=""-1"">" & fLang("strLangPhoto_Album00010") & "</a></span>" & vbNewLine)
end if
if strPortalFileLister = "1" or strForumFileLister = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""file_lister.asp?rand=" & int(10000000*rnd) & "§ionid=4"" target=""_self"" title=""" & fLang("strLangInc_Mainmenu00450") & """" & dWStatus(fLang("strLangInc_Mainmenu00450")) & " tabindex=""-1"">" & fLang("strLangFile_Lister00010") & "</a></span>" & vbNewLine)
end if
case 5 ' Links
if Request.Cookies(strUniqueID & "User")("Name") <> "" then
if (mLev >= 3 or mLev = 4) then
Response.Write("<span class=""spnMessageText""><a href=""javascript: OpenValidate('validate.asp?mode=Resources')"">" & fLang("strLangInc_Header00910") & "</a>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""showbadlinks.asp?rand=" & int(10000000*rnd) & "§ionid=5"">" & fLang("strLangInc_Header00920") & "</a>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""javascript: OpenValidate('editcategory.asp?rand=" & int(10000000*rnd) & "&addsub=true&category=" & Request.QueryString("catid") & "')"">" & fLang("strLangInc_Header00930") & "</a></span>" & vbNewLine & _
" | " & vbNewLine)
end if
Response.Write("<span class=""spnMessageText""><a href=""AddContent.asp?rand=" & int(10000000*rnd) & "§ionid=5&method=add&area=4&catid=" & Request.QueryString("catid") & "&cattitle=" & Request.QueryString("cattitle") & """>" & fLang("strLangInc_Header00940") & "</a></span>" & vbNewLine & _
" | " & vbNewLine)
end if
Response.Write("<span class=""spnMessageText""><a href=""WhatsNew.asp?rand=" & int(10000000*rnd) & "§ionid=5&area=5"" target=""_self"" title=""" & fLang("strLangInc_Mainmenu00380") & """" & dWStatus(fLang("strLangInc_Mainmenu00380")) & " tabindex=""-1"">" & fLang("strLangFile_Library00900") & "</a></span>" & vbNewLine)
if strShowJavaMenu = "0" then
Response.Write("| " & vbNewLine & _
"<span class=""spnMessageText""><a href=""portal_resources.asp?rand=" & int(10000000*rnd) & "§ionid=5&area=4"" target=""_self"" title=""" & fLang("strLangInc_Header00950") & """" & dWStatus(fLang("strLangInc_Header00950")) & " tabindex=""-1"">" & fLang("strLangInc_Header00620") & "</a></span>" & vbNewLine)
end if
if strPortalArticles = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""portal_articles.asp?rand=" & int(10000000*rnd) & "§ionid=5&area=3"" target=""_self"" title=""" & fLang("strLangInc_News00010") & """" & dWStatus(fLang("strLangInc_News00010")) & " tabindex=""-1"">" & fLang("strLangLinks01180") & "</a></span>" & vbNewLine)
end if
if strPortalLinks = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""portal_links.asp?rand=" & int(10000000*rnd) & "§ionid=5"" target=""_self"" title=""" & fLang("strLangInc_Header00950") & """" & dWStatus(fLang("strLangInc_Header00950")) & " tabindex=""-1"">" & fLang("strLangLinks01130") & "</a></span>" & vbNewLine)
end if
if strAdvert = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""adverts.asp?rand=" & int(10000000*rnd) & "§ionid=5"" target=""_self"" title=""" & fLang("strLangAdvert00010") & """" & dWStatus(fLang("strLangAdvert00010")) & " tabindex=""-1"">" & fLang("strLangAdvert00010") & "</a></span>" & vbNewLine)
end if
case 6 'Homepage
Response.Write("<span class=""spnMessageText""><a href=""portal_content.asp?rand=" & int(10000000*rnd) & "§ionid=6"" target=""_self"" title=""" & fLang("strLangSite_Portal00010") & """" & dWStatus(fLang("strLangSite_Portal00010")) & " tabindex=""-1"">" & fLang("strLangSite_Portal00010") & "</a></span>" & vbNewLine)
if strPortalLinks = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""portal_links.asp?rand=" & int(10000000*rnd) & "§ionid=5"" target=""_self"" title=""" & fLang("strLangInc_Header00950") & """" & dWStatus(fLang("strLangInc_Header00950")) & " tabindex=""-1"">" & fLang("strLangLinks01130") & "</a></span>" & vbNewLine)
end if
if strPortalnews = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""portal_news.asp?rand=" & int(10000000*rnd) & "§ionid=5"" target=""_self"" title=""" & fLang("strLangLinks01140") & """" & dWStatus(fLang("strLangLinks01140")) & " tabindex=""-1"">" & fLang("strLangLinks01140") & "</a></span>" & vbNewLine)
end if
if strShowJavaMenu = "0" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""portal_resources.asp?rand=" & int(10000000*rnd) & "§ionid=5&area=4"" target=""_self"" title=""" & fLang("strLangInc_Header00950") & """" & dWStatus(fLang("strLangInc_Header00950")) & " tabindex=""-1"">" & fLang("strLangInc_Header00620") & "</a></span>" & vbNewLine)
end if
if strPortalArticles = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""portal_articles.asp?rand=" & int(10000000*rnd) & "§ionid=5"" target=""_self"" title=""" & fLang("strLangLinks01180") & """" & dWStatus(fLang("strLangLinks01180")) & " tabindex=""-1"">" & fLang("strLangLinks01180") & "</a></span>" & vbNewLine)
end if
if strPortalPhotoAlbum = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""photo_album.asp?rand=" & int(10000000*rnd) & "§ionid=5"" target=""_self"" title=""" & fLang("strLangPhoto_Album00010") & """" & dWStatus(fLang("strLangPhoto_Album00010")) & " tabindex=""-1"">" & fLang("strLangPhoto_Album00010") & "</a></span>" & vbNewLine)
end if
if strPortalFileLister = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""file_lister.asp?rand=" & int(10000000*rnd) & "§ionid=5"" target=""_self"" title=""" & fLang("strLangFile_Lister00010") & """" & dWStatus(fLang("strLangFile_Lister00010")) & " tabindex=""-1"">" & fLang("strLangFile_Lister00010") & "</a></span>" & vbNewLine)
end if
if strShowJavaMenu = "1" and strUseFileLibrary = "1" then
Response.Write (" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""file_library.asp?rand=" & int(10000000*rnd) & "§ionid=5&area=4"" target=""_self"" title=""" & fLang("strLangLinks01150") & """" & dWStatus(fLang("strLangLinks01150")) & " tabindex=""-1""><b>" & fLang("strLangLinks01160") & "</b></a></span>" & vbNewLine)
end if
if strClassifieds = "1" then
Response.Write (" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""classifieds.asp?rand=" & int(10000000*rnd) & "§ionid=7&area=3"" target=""_self"" title=""" & fLang("strLangClassifieds00550") & """" & dWStatus(fLang("strLangClassifieds00550")) & " tabindex=""-1"">" & fLang("strLangClassifieds00040") & "</a></span>" & vbNewLine)
end if
if strAdvert = "1" then
Response.Write (" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""adverts.asp?rand=" & int(10000000*rnd) & "§ionid=5"" target=""_self"" title=""" & fLang("strLangAdvert00010") & """" & dWStatus(fLang("strLangAdvert00010")) & " tabindex=""-1"">" & fLang("strLangAdvert00010") & "</a></span>" & vbNewLine)
end if
if strShowJavaMenu = "1" and strShowEvents = "1" then
Response.Write (" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""cal.asp?rand=" & int(10000000*rnd) & "§ionid=1"" target=""_self"" title=""" & fLang("strLangInc_Header00540") & """" & dWStatus(fLang("strLangInc_Header00540")) & " tabindex=""-1"">" & fLang("strLangEvents_Calendar00010") & "</a></span>" & vbNewLine)
end if
case 7 'Guestbook
if strGuestbook = 1 then
Response.Write("<span class=""spnMessageText""><a href=""guestbook.asp?rand=" & int(10000000*rnd) & "§ionid=7&action=view"" target=""_self"" title=""" & fLang("strLangInc_Header00880") & """" & dWStatus(fLang("strLangInc_Header00880")) & " tabindex=""-1"">" & fLang("strLangInc_Header00890") & "</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""Guestbook.asp?rand=" & int(10000000*rnd) & "§ionid=7&action=sign"" target=""_self"" title=""" & fLang("strLangInc_Header00580") & """" & dWStatus(fLang("strLangInc_Header00580")) & " tabindex=""-1"">" & fLang("strLangInc_Header00900") & "</a></span>" & vbNewLine)
end if
case 888 ' Admin
' ADMIN OPTIONS
if (mlev = 4) or (lcase(strNoCookies) = "1") then
Response.Write("<span class=""spnMessageText""><a href=""admin_home.asp?rand=" & int(10000000*rnd) & "§ionid=888"">Admin Home</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""javascript:openWindow3('admin_run_config.asp')"">Reset Variables</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""subscription_list.asp?rand=" & int(10000000*rnd) & "§ionid=2&MODE=all"">Subscriptions</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""javascript:openWindow1('pop_upload.asp?rand=" & int(10000000*rnd) & "&referrer=admin_upload')"">Upload Files</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_accounts_pending.asp?rand=" & int(10000000*rnd) & "§ionid=888"">Pending Members</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_emaillist.asp?rand=" & int(10000000*rnd) & "§ionid=888"">Mailing Lists</a></span>" & vbNewLine & _
" " & vbNewLine)
if strBanIP = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_ipgate.asp?rand=" & int(10000000*rnd) & "§ionid=888"">Ban IP's</a></span>" & vbNewLine & _
" " & vbNewLine)
end if
end if
if (mlev = 3) or (lcase(strNoCookies) = "1") then
if (strBadWordFilter = "1") and strModeratorBadWord = "1" then
Response.Write("<span class=""spnMessageText""><a href=""javascript:openWindow3('admin_config_badwords.asp')"">Bad Word Filter</a></span>" & vbNewLine & _
" | " & vbNewLine)
end if
Response.Write "<span class=""spnMessageText""><a href=""admin_style_guidelines.asp?rand=" & int(10000000*rnd) & "§ionid=888"">Style Guidelines</a></span>" & vbNewLine
if (strPMStatus = "1") and strModeratorPmM = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_pmmaint.asp?rand=" & int(10000000*rnd) & "§ionid=888"">Private Message Maintenance</a></span>" & vbNewLine & _
" " & vbNewLine)
end if
if strAllowAvatars = "1" and strModeratorAvatar = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_avatar_home.asp?rand=" & int(10000000*rnd) & "§ionid=888"">Avatar Setup</a></span>" & vbNewLine & _
" " & vbNewLine)
end if
if strModeratorEmail = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_emaillist.asp?rand=" & int(10000000*rnd) & "§ionid=888"">Email List</a></span>" & vbNewLine & _
" " & vbNewLine)
end if
if strModeratorComplaint = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""cmanager.asp?rand=" & int(10000000*rnd) & "§ionid=888"">View Complaints</a></span>" & vbNewLine & _
" " & vbNewLine)
end if
end if
case 999 ' Admin Mod Config
' ADMIN OPTIONS
if (mlev = 4) or (lcase(strNoCookies) = "1") then
Response.Write("<span class=""spnMessageText""><a href=""admin_config_portal_mod.asp?rand=" & int(10000000*rnd) & "§ionid=999"">Portal Config</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_config_image_mod.asp?rand=" & int(10000000*rnd) & "§ionid=999"">Image's Mods</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_file_attachment.asp?rand=" & int(10000000*rnd) & "§ionid=999"">Attachments</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_avatar_home.asp?rand=" & int(10000000*rnd) & "§ionid=999"">Avatars</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_user_fields.asp?rand=" & int(10000000*rnd) & "§ionid=999"">Member Fields</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_pmmaint.asp?rand=" & int(10000000*rnd) & "§ionid=999"">PM Maint.</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_etc.asp?rand=" & int(10000000*rnd) & "§ionid=999"">Forum Cleanup Tools</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""admin_poll.asp?rand=" & int(10000000*rnd) & "§ionid=999"">Poll Admin</a></span>" & vbNewLine & _
" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""showbadlinks.asp?rand=" & int(10000000*rnd) & "§ionid=5"">Review Links</a></span>" & vbNewLine & _
" " & vbNewLine)
end if
case else ' Default
Response.Write("<span class=""spnMessageText""><a href=""active.asp?rand=" & int(10000000*rnd) & """ target=""_self"" title=""" & fLang("strLangInc_Header00290") & """" & dWStatus(fLang("strLangInc_Header00290")) & " tabindex=""-1"">" & fLang("strLangInc_Header00300") & "</a></span> (<b>" & ActiveTopicCount & "</b>)" & vbNewLine)
if strPolls = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""active_polls.asp?rand=" & int(10000000*rnd) & """ target=""_self"" title=""" & fLang("strLangInc_Header00460") & """" & dWStatus(fLang("strLangInc_Header00460")) & " tabindex=""-1"">" & fLang("strLangActive_Polls00010") & "</a></span> (<b>" & ActivePollCount & "</b>)" & vbNewLine)
end if
if strShowUserGroups = "1" then
blnCanView = ""
blnCanView = chkUserGroupView(MemberID)
if blnCanView = true then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""usergroups.asp?rand=" & int(10000000*rnd) & """ target=""_self"" title=""" & fLang("strLangUserGroup00010") & """" & dWStatus(fLang("strLangUserGroup00010")) & " tabindex=""-1"">" & fLang("strLangUserGroup00020") & "</a></span>" & vbNewLine)
end if
end if
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""members.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00350") & """" & dWStatus(fLang("strLangInc_Header00350")) & " tabindex=""-1"">" & fLang("strLangMembers200010") & "</a></span>" & vbNewLine)
if strAUEnable = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""active_users.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00480") & """" & dWStatus(fLang("strLangInc_Header00480")) & " tabindex=""-1"">" & fLang("strLangInc_Header00490") & "</a></span>" & vbNewLine)
end if
if strShowLiveChat = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""liquidchat.asp?rand=" & int(10000000*rnd) & """ target=""_self"">" & fLang("strLangInc_Header00630") & "</a></span>" & vbNewLine)
end if
if strShowDreamChat = "1" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""chatlog.asp?rand=" & int(10000000*rnd) & """ target=""_self"">" & fLang("strLangDream_Chat00010") & "</a></span>" & vbNewLine)
end if
if strShowFlashChat = "1" then
Dim vUserCount, vRoomCount
vRoomCount = 1 '# of users for room1
vUserCount = (0 + Application("UserCount" & vRoomCount))
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""JavaScript:openWindow7('flash_chat/login_html.asp')"" title=""" & fLang("strLangFlash_Chat00060") & """" & dWStatus(fLang("strLangFlash_Chat00060")) & " tabindex=""-1"">" & fLang("strLangFlash_Chat00050") & "</a></span> (<b>" & vUserCount & "</b>)" & vbNewLine)
end if
if strAllowAvatars = "1" then
Response.Write (" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""advanced_avatarlegend.asp?rand=" & int(10000000*rnd) & """ target=""_self"" title=""" & fLang("strLangInc_Header00500") & """" & dWStatus(fLang("strLangInc_Header00500")) & " tabindex=""-1"">" & fLang("strLangInc_Header00510") & "</a></span>" & vbNewLine)
end if
if strShowJavaMenu = "1" then
Response.Write (" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""search.asp?rand=" & int(10000000*rnd) & "§ionid=4"" target=""_self"" title=""" & fLang("strLangInc_Header00370") & """" & dWStatus(fLang("strLangInc_Header00370")) & " tabindex=""-1"">" & fLang("strLangInc_Header00380") & "</a></span>" & vbNewLine)
end if
if strBookMark = "1" and strShowJavaMenu = "1" then
Response.Write (" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""bookmarks.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00750") & """" & dWStatus(fLang("strLangInc_Header00750")) & " tabindex=""-1"">" & fLang("strLangInc_Header00760") & "</a></span>" & vbNewLine)
end if
end select
end sub
' LVL 2 NAVIGATION LINKS
sub Level2Links()
select case sectionid
case else ' Default
if strMemberActivePost = "1" and (mlev = 1 or mlev = 2 or mlev = 3 or mlev = 4) then
Response.Write("<span class=""spnMessageText""><a href=""active_my_posts.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLangN("strLangMy_Posts00010", strDBNTUserName) & "...""" & dWStatus("" & fLangN("strLangMy_Posts00010", strDBNTUserName) & "...") & " tabindex=""-1"">" & fLangN("strLangMy_Posts00010", strDBNTUserName) & "</a></span>" & vbNewLine & _
" | " & vbNewLine)
end if
if strWeblogs = "1" then
Response.Write("<span class=""spnMessageText""><a href=""weblogs.asp?rand=" & int(10000000*rnd) & """ target=""_self"" title=""" & fLang("strLangI_F_Common00760") & """" & dWStatus(fLang("strLangI_F_Common00760")) & " tabindex=""-1"">" & fLang("strLangI_F_Common00770") & "</a></span>" & vbNewLine & _
" | " & vbNewLine)
end if
Response.Write("<span class=""spnMessageText""><a href=""default_category.asp?rand=" & int(10000000*rnd) & """ target=""_self"" title=""" & fLang("strLangForum00990") & """" & dWStatus(fLang("strLangForum00990")) & " tabindex=""-1"">" & fLang("strLangForum00980") & "</a></span>" & vbNewLine)
if strMostRecent = "1" and strShowJavaMenu = "0" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""recent_topics.asp?rand=" & int(10000000*rnd) & """ target=""_self"" title=""" & fLang("strLangInc_Header00970") & """" & dWStatus(fLang("strLangInc_Header00970")) & " tabindex=""-1"">" & fLang("strLangPop_Profile00300") & "</a></span>" & vbNewLine)
end if
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""search.asp?rand=" & int(10000000*rnd) & "§ionid=4"" target=""_self"" title=""" & fLang("strLangInc_Header00370") & """" & dWStatus(fLang("strLangInc_Header00370")) & " tabindex=""-1"">" & fLang("strLangInc_Header00380") & "</a></span>" & vbNewLine)
if (mlev = 1 or mlev = 2 or mlev = 3 or mlev = 4) then
if strStatistics = "1" and strShowJavaMenu = "0" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""forum_stats.asp?rand=" & int(10000000*rnd) & """ target=""_self"" title=""" & fLang("strLangInc_Header00600") & """" & dWStatus(fLang("strLangInc_Header00600")) & " tabindex=""-1"">" & fLang("strLangStatistics00010") & "</a></span>" & vbNewLine)
end if
end if
if strBookMark = "1" and strShowJavaMenu = "0" then
Response.Write (" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""bookmarks.asp?rand=" & int(10000000*rnd) & "§ionid=2"" target=""_self"" title=""" & fLang("strLangInc_Header00980") & """" & dWStatus(fLang("strLangInc_Header00980")) & " tabindex=""-1"">" & fLang("strLangInc_Header00760") & "</a></span>" & vbNewLine)
end if
if strUseFileLibrary = "1" and strShowJavaMenu = "0" then
Response.Write (" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""file_library.asp?rand=" & int(10000000*rnd) & "§ionid=5&area=4"" target=""_self"" title=""" & fLang("strLangLinks01150") & """" & dWStatus(fLang("strLangLinks01150")) & " tabindex=""-1""><b>" & fLang("strLangLinks01160") & "</b></a></span>" & vbNewLine)
end if
if strDonation = "1" and strShowJavaMenu = "0" then
Response.Write(" | " & vbNewLine & _
"<span class=""spnMessageText""><a href=""donate_infos.asp?rand=" & int(10000000*rnd) & """ target=""_self"" title=""" & fLang("strLangDonation00030") & """" & dWStatus(fLang("strLangDonation00030")) & " tabindex=""-1"">" & fLang("strLangDonation00010") & "</a></span>" & vbNewLine)
end if
end select
end sub
sub CornerTop()
if ((strTheme = "1" and getStyles = "1") or (strStylesCss = "0")) and flag_showroundedcorner then
Response.Write(" <table border=""0"" width=""100%"" cellspacing=""0"" cellpadding=""0"">" & vbNewLine & _
" <tr>" & vbNewLine & _
" <td " & CategoryCellColor & ">" & getCurrentIcon(strIconCornerTopLeft,"","") & "</td><td " & CategoryCellColor & " width=""100%""><font face=""" & strDefaultFontFace & """ size=""" & strDefaultFontSize & """ " & CategoryFontColor & "> </font></td><td " & CategoryCellColor & ">" & getCurrentIcon(strIconCornerTopRight,"","") & "</td>" & vbNewLine & _
" </tr>" & vbNewLine & _
" </table>")
end if
end sub
sub CornerBottom()
if ((strTheme = "1" and getStyles = "1") or (strStylesCss = "0")) and flag_showroundedcorner then
Response.Write(" <table border=""0"" width=""100%"" cellspacing=""0"" cellpadding=""0"">" & vbNewLine & _
" <tr>" & vbNewLine & _
" <td " & CategoryCellColor & ">" & getCurrentIcon(strIconCornerBottomLeft,"","") & "</td><td " & CategoryCellColor & " width=""100%""><font face=""" & strDefaultFontFace & """ size=""" & strDefaultFontSize & """ " & CategoryFontColor & "> </font></td><td " & CategoryCellColor & ">" & getCurrentIcon(strIconCornerBottomRight,"","") & "</td>" & vbNewLine & _
" </tr>" & vbNewLine & _
" </table>")
end if
end sub
function fUserAgent(ua)
ua = Request.ServerVariables("HTTP_USER_AGENT")
If instr(ua, "ia_archiver") Then
strBrowser = "Alexa"
ElseIf instr(ua, "crawler@fast") Then
strBrowser = "AllTheWeb"
ElseIf instr(ua, "Scooter") Then
strBrowser = "Altavista"
ElseIf instr(ua, "Amaya") Then
strBrowser = "Amaya"
ElseIf instr(ua, "AOL 3") Then
strBrowser = "AOL 3"
ElseIf instr(ua, "AOL 4") Then
strBrowser = "AOL 4"
ElseIf instr(ua, "AOL 5") Then
strBrowser = "AOL 5"
ElseIf instr(ua, "AOL 6") Then
strBrowser = "AOL 6"
ElseIf instr(ua, "AOL 7") Then
strBrowser = "AOL 7"
ElseIf instr(ua, "AOL 8") Then
strBrowser = "AOL 8"
ElseIf instr(ua, "AOL 9") Then
strBrowser = "AOL 9"
ElseIf instr(ua, "AOL") Then
strBrowser = "AOL"
ElseIf instr(ua, "arianna.libero.it") Then
strBrowser = "Arianna/Libero"
ElseIf instr(ua, "Ask Jeeves") or instr(ua, "Ask+Jeeves") Then
strBrowser = "Ask Jeeves"
ElseIf instr(ua, "Camino") or instr(ua, "Chimera") Then
strBrowser = "Camino"
ElseIf instr(ua, "Chrome") Then
strBrowser = "Chrome"
ElseIf instr(ua, "Dillo") Then
strBrowser = "Dillo"
ElseIf instr(ua, "Robozilla") Then
strBrowser = "DMOZ"
ElseIf instr(ua, "DocZilla") Then
strBrowser = "DocZilla"
ElseIf instr(ua, "Dreamcast") Then
strBrowser = "Dreamcast"
ElseIf instr(ua, "Speedy+Spider") Then
strBrowser = "EntireWeb"
ElseIf instr(ua, "Epiphany") Then
strBrowser = "Epiphany"
ElseIf instr(ua, "EudoraWeb") Then
strBrowser = "Eudora Web"
ElseIf instr(ua, "ArchitextSpider") Then
strBrowser = "Excite"
ElseIf instr(ua, "Flock") Then
strBrowser = "Flock"
ElseIf instr(ua, "Galeon") Then
strBrowser = "Galeon"
ElseIf instr(ua, "Googlebot") Then
strBrowser = "Googlebot"
ElseIf instr(ua, "Sun") AND instr(ua, "Mozilla/3") Then
strBrowser = "HotJava"
ElseIf instr(ua, "iCab") Then
strBrowser = "iCab"
ElseIf instr(ua, "ICE") Then
strBrowser = "ICE"
ElseIf instr(ua, "slurp") Then
strBrowser = "Inktomi"
ElseIf instr(ua, "internetseer") Then
strBrowser = "InternetSeer"
ElseIf instr(ua, "Konqueror") Then
strBrowser = "Konqueror"
ElseIf instr(ua, "ZyBorg") Then
strBrowser = "Look Smart"
ElseIf instr(ua, "Lycos") Then
strBrowser = "Lycos"
ElseIf instr(ua, "Lynx") Then
strBrowser = "Lynx"
ElseIf instr(ua, "MSIE 1") Then
strBrowser = "Microsoft IE 1"
ElseIf instr(ua, "MSIE 2") Then
strBrowser = "Microsoft IE 2"
ElseIf instr(ua, "MSIE 3") Then
strBrowser = "Microsoft IE 3"
ElseIf instr(ua, "MSIE 4") Then
strBrowser = "Microsoft IE 4"
ElseIf instr(ua, "MSIE 5") Then
strBrowser = "Microsoft IE 5"
ElseIf instr(ua, "MSIE 6") Then
strBrowser = "Microsoft IE 6"
ElseIf (instr(ua, "MSIE 7") or mid(ua,26,6)="MSIE 7") Then
strBrowser = "Microsoft IE 7"
if right(ua, 12) = "MS-RTC LM 8)" then
strBrowser = "Microsoft IE 8"
end if
ElseIf instr(ua, "MSIE 8") Then
strBrowser = "Microsoft IE 8"
ElseIf instr(ua, "MSIE 9") Then
strBrowser = "Microsoft IE 9"
ElseIf instr(ua, "Gecko") AND instr(ua, "Netscape") AND instr(ua, "rv:0") Then
strBrowser = "Mozilla"
ElseIf instr(ua, "Gecko") AND instr(ua, "Netscape") AND instr(ua, "rv:1") Then
strBrowser = "Mozilla 1"
ElseIf instr(ua, "Gecko") AND instr(ua, "Netscape") AND instr(ua, "rv:2") Then
strBrowser = "Mozilla 2"
ElseIf instr(ua, "Firebird") AND instr(ua, "Gecko") Then
strBrowser = "Mozilla Firebird"
ElseIf (instr(ua, "Firefox") AND instr(ua, "Gecko")) or (mid(ua,len(ua)-13,7)="FireFox") Then
strBrowser = "Mozilla Firefox "
for x = 1 to len(ua)-8
if mid(ua,x,8)="Firefox/" then
strBrowser = "Firefox " & mid(ua,x+8,3)
end if
next
ElseIf instr(ua, "msnbot") Then
strBrowser = "MSN"
ElseIf instr(ua, "NameProtect") Then
strBrowser = "NameProtect"
ElseIf instr(ua, "NetCaptor") Then
strBrowser = "Net Captor"
ElseIf instr(ua, "Mozilla/1") Then
strBrowser = "Netscape 1"
ElseIf instr(ua, "Mozilla/2") Then
strBrowser = "Netscape 2"
ElseIf instr(ua, "Mozilla/3") Then
strBrowser = "Netscape 3"
ElseIf instr(ua, "Mozilla/4") Then
strBrowser = "Netscape 4"
ElseIf instr(ua, "Mozilla/5") Then
strBrowser = "Netscape 5"
ElseIf instr(ua, "Netscape/6") Then
strBrowser = "Netscape 6"
ElseIf instr(ua, "Netscape/7") Then
strBrowser = "Netscape 7"
ElseIf instr(ua, "Netscape/8") Then
strBrowser = "Netscape 8"
ElseIf instr(ua, "Gulliver") Then
strBrowser = "Northernlight"
ElseIf instr(ua, "Opera") Then
strBrowser = "Opera"
ElseIf instr(ua, "Opera 1") Then
strBrowser = "Opera 1"
ElseIf instr(ua, "Opera 2") Then
strBrowser = "Opera 2"
ElseIf instr(ua, "Opera 3") Then
strBrowser = "Opera 3"
ElseIf instr(ua, "Opera 4") Then
strBrowser = "Opera 4"
ElseIf instr(ua, "Opera 5") Then
strBrowser = "Opera 5"
ElseIf instr(ua, "Opera 6") Then
strBrowser = "Opera 6"
ElseIf instr(ua, "Opera 7") Then
strBrowser = "Opera 7"
ElseIf instr(ua, "Opera 8") Then
strBrowser = "Opera 8"
ElseIf instr(ua, "PhpDig") Then
strBrowser = "PhpDig"
ElseIf instr(ua, "MSPIE 1") Then
strBrowser = "Pocket IE 1"
ElseIf instr(ua, "MSPIE 2") Then
strBrowser = "Pocket IE 2"
ElseIf instr(ua, "StackRambler") Then
strBrowser = "Rambler"
ElseIf instr(ua, "Safari") Then
strBrowser = "Safari"
ElseIf instr(ua, "SeaMonkey") Then
strBrowser = "Sea Monkey"
ElseIf instr(ua, "TurnitinBot") Then
strBrowser = "Turnitin"
ElseIf instr(ua, "UbiCrawler") Then
strBrowser = "UbiCrawler"
ElseIf instr(ua, "W3C_Validator") Then
strBrowser = "W3C Validator"
Else strBrowser = "Unknown"
End If
GetBrowser = strBrowser
If instr(ua, "Amiga") Then
strSystem = "Amiga"
ElseIf instr(ua, "AOLTV") or instr(ua, "AOL_TV") Then
strSystem = "AOL TV"
ElseIf instr(ua, "BSD") or instr(ua, "FreeBSD") Then
strSystem = "Free BSD"
ElseIf instr(ua, "Linux") Then
strSystem = "Linux"
ElseIf instr(ua, "68000") or instr(ua, "68k") AND instr(ua, "Mac") Then
strSystem = "Mac 68k"
ElseIf instr(ua, "Mac OS X") Then
strSystem = "Mac OS X"
ElseIf instr(ua, "Mac_PowerPC") or instr(ua, "PPC") Then
strSystem = "Mac PowerPC"
ElseIf instr(ua, "Mac") or (instr(ua, "Apple") and not instr(ua, "AppleWebKit")) Then
strSystem = "Macintosh"
ElseIf instr(ua, "Nokia") Then
strSystem = "Nokia"
ElseIf instr(ua, "OS/2") Then
strSystem = "OS/2"
ElseIf instr(ua, "PalmOS") Then
strSystem = "Palm OS"
ElseIf instr(ua, "Elaine") Then
strSystem = "PalmPilot"
ElseIf instr(ua, "Solaris") Then
strSystem = "Solaris"
ElseIf instr(ua, "SunOS") Then
strSystem = "Sun OS"
ElseIf instr(ua, "Unix") or instr(ua, "X11") Then
strSystem = "Unix"
ElseIf instr(ua, "WebTV") Then
strSystem = "Web TV"
ElseIf instr(ua, "NT 6.1") or instr(ua, "Windows 7") then
strSystem = "Windows 7"
ElseIf instr(ua, "Windows Vista") or instr(ua, "Windows NT 6.0") then
strSystem = "Windows Vista"
ElseIf instr(ua, "Windows 2003") or instr(ua, "Windows NT 5.2") or (mid(ua,36,14)="Windows NT 5.2") Then
strSystem = "Windows 2003"
ElseIf instr(ua, "Windows XP") or instr(ua, "Windows NT 5.1") Then
strSystem = "Windows XP"
ElseIf instr(ua, "Windows 2000") or instr(ua, "Windows NT 5") Then
strSystem = "Windows 2000"
ElseIf instr(ua, "Windows NT") or instr(ua, "WinNT") Then
strSystem = "Windows NT 4"
ElseIf instr(ua, "Windows 95") or instr(ua, "Win95") Then
strSystem = "Windows 95"
ElseIf instr(ua, "Windows ME") or instr(ua, "Win 9x 4.90") Then
strSystem = "Windows ME"
ElseIf instr(ua, "Windows 98") or instr(ua, "Win98") Then
strSystem = "Windows 98"
ElseIf instr(ua, "Windows 3.1") or instr(ua, "Win16") Then
strSystem = "Windows 3.x"
ElseIf instr(ua, "Windows CE") Then
strSystem = "Windows CE"
ElseIf instr(ua, "aardvark-crawler") or instr(ua, "AbachoBOT") or instr(ua, "AbachoBOT (Mozilla compatible)") or instr(ua, "About/0.1libwww-perl/5.47") or instr(ua, "Accelatech RSSCrawler/0.4") then
strSystem = "Search Robot"
ElseIf instr(ua, "accoona") or instr(ua, "Accoona-AI-Agent/1.1.1") or instr(ua, "Accoona-AI-Agent/1.1.2") or instr(ua, "Acoon Robot v1.50.001") or instr(ua, "Acoon Robot v1.52") then
strSystem = "Search Robot"
ElseIf instr(ua, "Acorn/Nutch-0.9") or instr(ua, "AESOP_com_SpiderMan") or instr(ua, "aipbot/1.0") or instr(ua, "aipbot/2-beta") or instr(ua, "Aladin/3.324") or instr(ua, "AlkalineBOT/1.3") then
strSystem = "Search Robot"
ElseIf instr(ua, "AlkalineBOT/1.4") or instr(ua, "AmfibiBOT") or instr(ua, "Amfibibot/0.06") or instr(ua, "Amfibibot/0.07") or instr(ua, "amibot") or instr(ua, "Amiga-AWeb/3.4.167SE") then
strSystem = "Search Robot"
ElseIf instr(ua, "AmigaVoyager/3.4.4") or instr(ua, "amzn_assoc") or instr(ua, "AnnoMille spider 0.1 alpha") or instr(ua, "AnswerChase PROve x.0") or instr(ua, "AnswerChase x.0") then
strSystem = "Search Robot"
ElseIf instr(ua, "AnzwersCrawl/2.0") or instr(ua, "Apexoo Spider 1.x") or instr(ua, "Aport") or instr(ua, "appie 1.1") or instr(ua, "ArabyBot") or instr(ua, "Arachnoidea") or instr(ua, "aranhabot") then
strSystem = "Search Robot"
ElseIf instr(ua, "ArchitectSpider") or instr(ua, "ArchitextSpider") or instr(ua, "archive.org_bot") or instr(ua, "Argus/1.1") or instr(ua, "arianna.libero.it") or instr(ua, "Arikus_Spider") then
strSystem = "Search Robot"
ElseIf instr(ua, "Arquivo-web-crawler") or instr(ua, "ASAHA Search Engine Turkey V.001") or instr(ua, "ask.24x.info") or instr(ua, "AskAboutOil/0.06-rcp") or instr(ua, "asked/Nutch-0.8") then
strSystem = "Search Robot"
ElseIf instr(ua, "ASPSeek/1.2.5") or instr(ua, "crawler@fast") or instr(ua, "exactseek") or instr(ua, "Fast-WebCrawler") or instr(ua, "FeedSeek") or instr(ua, "Fluffy") or instr(ua, "Gigabot") then
strSystem = "Search Robot"
ElseIf instr(ua, "Googlebot") or instr(ua, "Google CHTML Proxy/1.0") or instr(ua, "Gulliver") or instr(ua, "ia_archiver") or instr(ua, "InfoSeek") or instr(ua, "InternetSeer") then
strSystem = "Search Robot"
ElseIf instr(ua, "Jeeves") or instr(ua, "Jetbot") or instr(ua, "KIT_Fireball") or instr(ua, "Lycos") or instr(ua, "MantraAgent") or instr(ua, "Mediapartners-Google") then
strSystem = "Search Robot"
ElseIf instr(ua, "Mercator") or instr(ua, "Microsoft URL Control") or instr(ua, "Moget") or instr(ua, "msnbot") or instr(ua, "MuscatFerret") or instr(ua, "NameProtect") then
strSystem = "Search Robot"
ElseIf instr(ua, "NPBot") or instr(ua, "PhpDig") or instr(ua, "Robozilla") or instr(ua, "Scooter") or instr(ua, "Sleek Spider") or instr(ua, "slurp") or instr(ua, "Speedy+Spider") then
strSystem = "Search Robot"
ElseIf instr(ua, "StackRambler") or instr(ua, "T-H-U-N-D-E-R-S-T-O-N-E") or instr(ua, "TurnitinBot") or instr(ua, "Ultraseek") or instr(ua, "UbiCrawler") then
strSystem = "Search Robot"
ElseIf instr(ua, "VoilaBot") or instr(ua, "WebCrawler") or instr(ua, "wombat") or instr(ua, "ZyBorg") Then
strSystem = "Search Robot"
Else
strSystem = "Unknown"
End If
GetOS = strSystem
fUserAgent = GetOS & "<br/>" & GetBrowser
End Function
%>
<script language="javascript1.2" runat="server">
function edit_hrefs(sURL, iType) {
sOutput = new String(sURL);
if (iType == 1) {
sOutput = sOutput.replace(/\b(http\:\/\/[\w+\.]+[\w+\.\:\/\@\_\?\=\&\-\'\#\%\~\;\,\$\!\+\*]+)/gi,
"<a href=\"$1\" target=\"_blank\">$1<\/a>");
} else if (iType == 2) {
sOutput = sOutput.replace(/\b(https\:\/\/[\w+\.]+[\w+\.\:\/\@\_\?\=\&\-\'\#\%\~\;\,\$\!\+\*]+)/gi,
"<a href=\"$1\" target=\"_blank\">$1<\/a>");
} else if (iType == 3) {
sOutput = sOutput.replace(/\b(www\.[\w+\.\:\/\@\_\?\=\&\-\'\#\%\~\;\,\$\!\+\*]+)/gi,
"<a href=\"http://$1\" target=\"_blank\">$1<\/a>");
} else if (iType == 4) {
sOutput = sOutput.replace(/\b([\w+\-\'\#\%\.\_\,\$\!\+\*]+@[\w+\.?\-\'\#\%\~\_\.\;\,\$\!\+\*]+\.[\w+\.?\-\'\#\%\~\_\.\;\,\$\!\+\*]+)/gi,
"<a href=\"mailto\:$1\">$1<\/a>");
} else if (iType == 5) {
sOutput = sOutput.replace(/\b(ftp\:\/\/[\w+\.]+[\w+\.\:\/\@\_\?\=\&\-\'\#\%\~\;\,\$\!\+\*]+)/gi,
"<a href=\"$1\" target=\"_blank\">$1<\/a>");
} else if (iType == 6) {
sOutput = sOutput.replace(/\b(file\:\/\/\/[\w+\:\/\\]+[\w+\/\w+\.\:\/\\\@\_\?\=\&\-\'\#\%\~\;\,\$\!\+\*]+)/gi,
"<a href=\"$1\" target=\"_blank\">$1<\/a>");
}
return sOutput;
}
</script>