| T O P I C R E V I E W |
| Webbo |
Posted - 27 March 2011 : 06:43:49
Hi, I have a problem that is now starting to bug me...
How do you include a file to use a function within it when the file is in another application pool?
I've tried the usual suspects ie INCLUDE VIRTUAL, and INCLUDE FILE but this does not work
Basically what I am trying to do is to grab a user count that is calculated within a function in a file that is within a directory in a separate application pool and display it alongside a link that is written into the inc_header.asp file of my forum.
Here is the code within my inc_header.asp file which previously worked prior to putting the chat directory into it's own application pool
I have also tried: <!-- #INCLUDE VIRTUAL="/forum/chat/chatapi.asp" -->
which didn't work either
The function I am trying to use is: " & UsersCountGet() & " which is within the chatapi.asp file
Many thanks,
Dave
|
| 13 L A T E S T R E P L I E S (Newest First) |
| Classicmotorcycling |
Posted - 01 April 2011 : 18:28:39
This function call in the inc_header.asp that Carefree supplied is at line 656 and the actual funtion is at line 647. quote:
Originally posted by Webbo
Also, including the Function element gave the same syntax error as I was receiving:
Microsoft VBScript compilation error '800a03ea'
Syntax error
/forum/inc_header.asp, line 694
Function UsersCountGet()
^
The only thing I can think of now that you are calling the Chat application from the seperate App Pool in IIS is that you may need to also add a connection string to the Chat Database.
|
| Classicmotorcycling |
Posted - 01 April 2011 : 18:17:55
This one is an easy fix. Line 342 is missing: & _
quote:
Originally posted by Webbo
That gives an error:
Microsoft VBScript compilation error '800a0400'
Expected statement
/forum/inc_header.asp, line 343
"}" & vbNewLine & _
|
| Webbo |
Posted - 30 March 2011 : 17:59:00
Also, including the Function element gave the same syntax error as I was receiving:
Microsoft VBScript compilation error '800a03ea'
Syntax error
/forum/inc_header.asp, line 694
Function UsersCountGet()
^
|
| Webbo |
Posted - 30 March 2011 : 17:54:40
That gives an error:
Microsoft VBScript compilation error '800a0400'
Expected statement
/forum/inc_header.asp, line 343
"}" & vbNewLine & _
|
| Carefree |
Posted - 29 March 2011 : 20:53:03
What is the syntax error that you get when you include the function? I saw a few errors in your inc_header, so I cleaned it up a bit. Try this:
"inc_header.asp"
<%
'###############################################################################
'##
'## Snitz Forums 2000 v3.4.07
'##
'###############################################################################
'##
'## Copyright © 2000-06 Michael Anderson, Pierre Gorissen,
'## Huw Reddick and Richard Kinser
'##
'## This program is free. You can redistribute and/or modify it under the
'## terms of the GNU General Public License as published by the Free Software
'## Foundation; either version 2 or (at your option) any later version.
'##
'## All copyright notices regarding Snitz Forums 2000 must remain intact in
'## the scripts and in the HTML output. 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 an 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:
'##
'## Free Software Foundation, Inc.
'## 59 Temple Place, Suite 330
'## Boston, MA 02111-1307
'##
'## Support can be obtained from our support forums at:
'##
'## http://forum.snitz.com
'##
'## Correspondence and marketing questions can be sent to:
'##
'## manderson@snitz.com
'##
'###############################################################################
%>
<!--#INCLUDE FILE="inc_func_common.asp" -->
<%
if instr(request.querystring,";")>0 or instr(lcase(request.querystring),"declare") >0 or instr(lcase(request.querystring),"cast")>0 then
Response.End
end if
if strShowTimer = "1" then
' ## Timer Below
Dim StopWatch(19)
sub StartTimer(x)
StopWatch(x) = timer
end sub
function StopTimer(x)
EndTime = Timer
' Watch for the midnight wraparound...
if EndTime < StopWatch(x) then
EndTime = EndTime + (86400)
end if
StopTimer = EndTime - StopWatch(x)
end function
StartTimer 1
' ## Timer Above
end if
strArchiveTablePrefix = strTablePrefix & "A_"
strScriptName = request.servervariables("script_name")
' ## Referer Below
strRefScriptName = "http://" & Request.ServerVariables("SERVER_NAME") & Request.ServerVariables("PATH_INFO") ' added by me
If Len(Request.QueryString) > 0 Then
strRefScriptName = strRefScriptName & "?" & Request.ServerVariables("QUERY_STRING")
End If
If StrComp(Session("CurrentPage"),strRefScriptName)<>0 Then
If (InStr(Session("CurrentPage"),"post_info.asp")=0) and (InStr(Session("CurrentPage"),"post.asp")=0) Then
Session("LastPage") = Session("CurrentPage")
End if
Session("CurrentPage") = chkString(strRefScriptName, "refer")
End If
strReferer = Session("LastPage")
If (InStr(strReferer,"register.asp")<>0) Then
strReferer = "default.asp"
End If
' ## Referer Above
if Application(strCookieURL & "down") then
if not Instr(strScriptName,"admin_") > 0 then
Response.redirect("down.asp")
end if
end if
if strPageBGImageURL = "" then
strTmpPageBGImageURL = ""
elseif Instr(strPageBGImageURL,"/") > 0 or Instr(strPageBGImageURL,"\") > 0 then
strTmpPageBGImageURL = " background=""" & strPageBGImageURL & """" & " bgproperties=""fixed"""
else
strTmpPageBGImageURL = " background=""" & strImageUrl & strPageBGImageURL & """" & " bgproperties=""fixed"""
end if
If strDBType = "" then
Response.Write "<html>" & vbNewLine & _
"<head>" & vbNewline & _
"<title>" & strForumTitle & "</title>" & vbNewline
' ## START - REMOVAL, MODIFICATION OR CIRCUMVENTING THIS CODE WILL VIOLATE THE SNITZ FORUMS 2000 LICENSE AGREEMENT
Response.Write "<meta name=""copyright"" content=""This Forum code is Copyright (C) 2000-02 Michael Anderson, Pierre Gorissen, Huw Reddick and Richard Kinser, Non-Forum Related code is Copyright (C) " & strCopyright & """>" & vbNewline
' ## END - REMOVAL, MODIFICATION OR CIRCUMVENTING THIS CODE WILL VIOLATE THE SNITZ FORUMS 2000 LICENSE AGREEMENT
Response.Write "</head>" & vbNewLine & _
"<body" & strTmpPageBGImageURL & " bgColor=""" & strPageBGColor & """ text=""" & strDefaultFontColor & """ link=""" & strLinkColor & """ aLink=""" & strActiveLinkColor & """ vLink=""" & strVisitedLinkColor & """>" & vbNewLine & _
"<table border=""0"" cellspacing=""0"" cellpadding=""5"" width=""50%"" height=""40%"" align=""center"">" & vbNewLine & _
" <tr>" & vbNewLine & _
" <td bgColor=""navyblue"" align=""center""><p><font face=""Verdana, Arial, Helvetica"" size=""2"">" & _
"<b>There has been a problem...</b><br /><br />" & _
"Your <b>strDBType</b> is not set, please edit your <b>config.asp</b><br />to reflect your database type." & _
"</font></p></td>" & vbNewLine & _
" </tr>" & vbNewLine & _
" <tr>" & vbNewLine & _
" <td align=""center""><font face=""Verdana, Arial, Helvetica"" size=""2"">" & _
"<a href=""default.asp"" target=""_top"">Click here to retry.</a></font></td>" & vbNewLine & _
" </tr>" & vbNewLine & _
"</table>" & vbNewLine & _
"</body>" & vbNewLine & _
"</html>" & vbNewLine
Response.End
end if
Response.Write "<a name=""top""></a>" & vbNewLine
if strSiteIntegEnabled = "1" then
Response.Write "<table width=""100%"" border="""
if strSiteBorder = "1" then
Response.Write "1"
else
Response.Write "0"
end if
Response.Write """ cellspacing=""0"" cellpadding=""0"">" & vbNewLine
if strSiteHeader = "1" then
Response.Write " <tr>" & vbNewLine & _
" <td"
if strSiteLeft = "1" or strSiteRight = "1" then
if strSiteLeft = "1" and strSiteRight = "1" then
Response.Write " colspan=""3"""
else
Response.Write " colspan=""2"""
end if
end if
Response.Write ">"
%>
<!--#include file="inc_site_header.asp"-->
<%
Response.Write "</td>" & vbNewLine & _
" </tr>" & vbNewLine
end if
Response.Write " <tr>" & vbNewLine & _
" <td valign=""top"">" & vbNewLine
if strSiteLeft = "1" then
%>
<!--#include file="inc_site_left.asp"-->
<%
Response.Write "</td>" & vbNewLine & _
" <td valign=""top"">" & vbNewLine
end if
end if
Response.Write " " & vbNewLine
set my_Conn = Server.CreateObject("ADODB.Connection")
my_Conn.Open strConnString
if (strAuthType = "nt") then
call NTauthenticate()
if (ChkAccountReg() = "1") then
call NTUser()
end if
end if
if strGroupCategories = "1" then
if Request.QueryString("Group") = "" then
if Request.Cookies(strCookieURL & "GROUP") = "" Then
Group = 2
else
Group = Request.Cookies(strCookieURL & "GROUP")
end if
else
Group = cLng(Request.QueryString("Group"))
end if
' set default
Session(strCookieURL & "GROUP_ICON") = "icon_group_categories.gif"
Session(strCookieURL & "GROUP_IMAGE") = strTitleImage
' Forum_SQL - Group exists ?
strSql = "SELECT GROUP_ID, GROUP_NAME, GROUP_ICON, GROUP_IMAGE "
strSql = strSql & " FROM " & strTablePrefix & "GROUP_NAMES "
strSql = strSql & " WHERE GROUP_ID = " & Group
set rs2 = my_Conn.Execute (strSql)
if rs2.EOF or rs2.BOF then
Group = 2
strSql = "SELECT GROUP_ID, GROUP_NAME, GROUP_ICON, GROUP_IMAGE "
strSql = strSql & " FROM " & strTablePrefix & "GROUP_NAMES "
strSql = strSql & " WHERE GROUP_ID = " & Group
set rs2 = my_Conn.Execute (strSql)
end if
Session(strCookieURL & "GROUP_NAME") = rs2("GROUP_NAME")
if instr(rs2("GROUP_ICON"), ".") then
Session(strCookieURL & "GROUP_ICON") = rs2("GROUP_ICON")
end if
if instr(rs2("GROUP_IMAGE"), ".") then
Session(strCookieURL & "GROUP_IMAGE") = rs2("GROUP_IMAGE")
end if
rs2.Close
set rs2 = nothing
Response.Cookies(strCookieURL & "GROUP") = Group
Response.Cookies(strCookieURL & "GROUP").Expires = dateAdd("d", intCookieDuration, strForumTimeAdjust)
if Session(strCookieURL & "GROUP_IMAGE") <> "" then
strTitleImage = Session(strCookieURL & "GROUP_IMAGE")
end if
end if
strDBNTUserName = Request.Cookies(strUniqueID & "User")("Name")
strDBNTFUserName = trim(chkString(Request.Form("Name"),"SQLString"))
if strDBNTFUserName = "" then strDBNTFUserName = trim(chkString(Request.Form("User"),"SQLString"))
if strAuthType = "nt" then
strDBNTUserName = Session(strCookieURL & "userID")
strDBNTFUserName = Session(strCookieURL & "userID")
end if
if strRequireReg = "1" and strDBNTUserName = "" then
if not Instr(strScriptName,"policy.asp") > 0 and _
not Instr(strScriptName,"register.asp") > 0 and _
not Instr(strScriptName,"password.asp") > 0 and _
not Instr(strScriptName,"faq.asp") > 0 and _
not Instr(strScriptName,"login.asp") > 0 then
scriptname = split(request.servervariables("SCRIPT_NAME"),"/")
if Request.QueryString <> "" then
Response.Redirect("login.asp?target=" & lcase(scriptname(ubound(scriptname))) & "?" & Request.QueryString)
else
Response.Redirect("login.asp?target=" & lcase(scriptname(ubound(scriptname))))
end if
end if
end if
select case Request.Form("Method_Type")
case "login"
strEncodedPassword = sha256("" & Request.Form("Password"))
select case chkUser(strDBNTFUserName, strEncodedPassword,-1)
case 1, 2, 3, 4
Call DoCookies(Request.Form("SavePassword"))
strLoginStatus = 1
case else
strLoginStatus = 0
end select
case "logout"
Call ClearCookies()
end select
if trim(strDBNTUserName) <> "" and trim(Request.Cookies(strUniqueID & "User")("Pword")) <> "" then
chkCookie = 1
mLev = cLng(chkUser(strDBNTUserName, Request.Cookies(strUniqueID & "User")("Pword"),-1))
chkCookie = 0
' ## Sponsor Below
strSql = "SELECT M_NAME, M_SPONSORLEVEL, M_SPONSORDATE"
strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS "
strSql = strSql & " WHERE M_NAME= '" & ChkString(strDBNTUserName, "SQLString") & "'"
strSql = strSql & " AND M_SPONSORDATE > '" & DatetoStr(strForumTimeAdjust) & "'"
set rsSponsor = my_Conn.Execute (strSql)
if rsSponsor.EOF or rsSponsor.BOF then
sLev = 0
else
sLev = rsSponsor("M_SPONSORLEVEL")
SponsorDate = rsSponsor("M_SPONSORDATE")
if SponsorDate <= DatetoStr(DateAdd("d",+14,strForumTimeAdjust)) then ' Send PM or EM
%>
<!--#INCLUDE FILE="inc_sponsor_renew.asp" -->
<%
end if
end if
rsSponsor.close
set rsSponsor = nothing
' ## Sponsor Above
else
MemberID = -1
mLev = 0
end if
select case Request.Form("Method_Type")
case "login"
if strLoginStatus = 1 then
AUHandleLoging()
end if
case "logout"
AUHandleLoging()
end select
ActiveUserTracker()
if mLev > 3 and strEmailVal = "1" and strRestrictReg = "1" and strEmail = "1" then
' ## Forum_SQL - Get membercount from DB
strSql = "SELECT COUNT(MEMBER_ID) AS U_COUNT FROM " & strMemberTablePrefix & "MEMBERS_PENDING WHERE M_APPROVE = " & 0
set rs = Server.CreateObject("ADODB.Recordset")
rs.open strSql, my_Conn
if not rs.EOF then
User_Count = cLng(rs("U_COUNT"))
else
User_Count = 0
end if
rs.close
set rs = nothing
end if
' ## UserGroup Below
if Session(strCookieURL & "UserGroups" & MemberID) = "" or IsNull(Session(strCookieURL & "UserGroups" & MemberID)) then
strGroupMembership = getGroupMembership(MemberID,1)
Session(strCookieURL & "UserGroups" & MemberID) = strGroupMembership
Session(strCookieURL & "UserGroups" & MemberID) = strGroupMembership
end if
' ## UserGroup Above
Response.Write "<html>" & vbNewline & vbNewline & _
"<head>" & vbNewline & _
"<title>" & GetNewTitle(strScriptName) & "</title>" & vbNewline
' ## START - REMOVAL, MODIFICATION OR CIRCUMVENTING THIS CODE WILL VIOLATE THE SNITZ FORUMS 2000 LICENSE AGREEMENT
Response.Write "<meta name=""copyright"" content=""This Forum code is Copyright (C) 2000-02 Michael Anderson, Pierre Gorissen, Huw Reddick and Richard Kinser, Non-Forum Related code is Copyright (C) " & strCopyright & """>" & vbNewline
' ## END - REMOVAL, MODIFICATION OR CIRCUMVENTING THIS CODE WILL VIOLATE THE SNITZ FORUMS 2000 LICENSE AGREEMENT
' Response.Write "<script src=""smooth.pack.js"" type=""text/javascript""></script>" & vbNewLine
Response.Write "<script type=""text/javascript"" src=""formfieldlimiter.js""></script>" & vbNewLine & _
"<script language=""JavaScript1.2"" src=""resizeimgs.js""></script>" & vbNewLine & _
"<script language=""JavaScript"" type=""text/javascript"">" & vbNewLine & _
"<!-- hide from JavaScript-challenged browsers" & vbNewLine & _
"function openWindow(url) {" & vbNewLine & _
" popupWin = window.open(url,'new_page','width=400,height=400')" & vbNewLine & _
"}" & vbNewLine & _
"function openWindow2(url) {" & vbNewLine & _
" popupWin = window.open(url,'new_page','width=400,height=450')" & vbNewLine & _
"}" & vbNewLine & _
"function openWindow3(url) {" & vbNewLine & _
" popupWin = window.open(url,'new_page','width=400,height=450,scrollbars=yes')" & vbNewLine & _
"}" & vbNewLine & _
"function openWindow4(url) {" & vbNewLine & _
" popupWin = window.open(url,'new_page','width=400,height=525')" & vbNewLine & _
"}" & vbNewLine & _
"function openWindow5(url) {" & vbNewLine & _
" popupWin = window.open(url,'new_page','width=450,height=525,scrollbars=yes,toolbars=yes,menubar=yes,resizable=yes')" & vbNewLine & _
"}" & vbNewLine & _
"function openWindow6(url) {" & vbNewLine & _
" popupWin = window.open(url,'new_page','width=500,height=450,scrollbars=yes')" & vbNewLine & _
"}" & vbNewLine & _
"function openWindow7(url) {" & vbNewLine & _
" popupWin = window.open(url,'new_page','width=550,height=500,scrollbars=yes,status=yes')" & vbNewLine & _
"}" & vbNewLine & _
"function openWindowHelp(url) {" & vbNewLine & _
" popupWin = window.open(url,'new_page','width=470,height=200,scrollbars=yes')" & vbNewLine & _
"}" & vbNewLine & _
"function openWindowIgnore(url) {" & vbNewLine & _
" popupWin = window.open(url,'new_page','width=750,height=450,scrollbars=yes')" & vbNewLine & _
"}" & vbNewLine & _
"function openWindow9(url) {" & vbNewLine & _
" popupWin = window.open(url,'new_page','width=350,height=350,scrollbars=yes,status=no,resizable=yes')" & vbNewLine & _
"}" & vbNewLine & _
"function openWindow10(url) {" & vbNewLine & _
" popupWin = window.open(url,'new_page','width=650,height=550,scrollbars=yes,status=yes,resizable=yes')" & vbNewLine & _
"}" & vbNewLine & _
"function openWindow8(url) {" & vbNewLine & _
" popupWin = window.open(url,'new_page','width=450,height=550,scrollbars=yes')" & vbNewLine
"}" & vbNewLine & _
"// ## Poll Below" & vbNewLine & _
" popupWin = window.open(url,'new_page','width='+w+',height='+h+',scrollbars=yes')" & vbNewLine & _
"}" & vbNewLine & _
"function submitPoll(btnPressed) {" & vbNewLine & _
" btnPressed.disabled=true;" & vbNewLine & _
" if (btnPressed.name == ""results"") {" & vbNewLine & _
" document.Poll.Method_Type.value = ""guest_vote"";" & vbNewLine & _
" } else {" & vbNewLine & _
" document.Poll.Method_Type.value = ""member_vote"";" & vbNewLine & _
" }" & vbNewLine & _
" document.Poll.submit();" & vbNewLine & _
"}" & vbNewLine & _
"// ## Poll Above" & vbNewLine & _
"// done hiding -->" & vbNewLine & _
"</script>" & vbNewLine & _
"<style type=""text/css"">" & vbNewLine & _
"<!--" & vbNewLine & _
"a:link {color:" & strLinkColor & ";text-decoration:" & strLinkTextDecoration & "}" & vbNewLine & _
"a:visited {color:" & strVisitedLinkColor & ";text-decoration:" & strVisitedTextDecoration & "}" & vbNewLine & _
"a:hover {color:" & strHoverFontColor & ";text-decoration:" & strHoverTextDecoration & "}" & vbNewLine & _
"a:active {color:" & strActiveLinkColor & ";text-decoration:" & strActiveTextDecoration & "}" & vbNewLine & _
".spnMessageText a:link {color:" & strForumLinkColor & ";text-decoration:" & strForumLinkTextDecoration & "}" & vbNewLine & _
".spnMessageText a:visited {color:" & strForumVisitedLinkColor & ";text-decoration:" & strForumVisitedTextDecoration & "}" & vbNewLine & _
".spnMessageText a:hover {color:" & strForumHoverFontColor & ";text-decoration:" & strForumHoverTextDecoration & "}" & vbNewLine & _
".spnMessageText a:active {color:" & strForumActiveLinkColor & ";text-decoration:" & strForumActiveTextDecoration & "}" & vbNewLine & _
".spnSearchHighlight {background-color:" & strSearchHiLiteColor & "}" & vbNewLine & _
"input.radio {background:" & strPopUpTableColor & ";color:#000000}" & vbNewLine & _
".quoteboxhead {margin-left:50px; margin-right:0px; margin-top:5px; margin-bottom:2px;font-family: " & strDefaultFontFace & "; font-size: 8pt}" & vbNewLine & _
".quotebox {margin-right:50px;margin-left:50px; margin-bottom:8px; margin-top:4px; padding:4px; border:1px "& strTableBorderColor &" dashed; height:auto; font-family: ""Lucida Sans Unicode"", ""Verdana"", ""sans-serif""; font-size: 9pt}" & vbNewLine & _
"acronym {border-bottom:0px}" & vbNewLine & _
"-->" & vbNewLine & _
"</style>" & vbNewLine & _
"</head>" & vbNewLine & _
"<body onload=walkImages() " & strTmpPageBGImageURL & " bgColor=""" & strPageBGColor & """ text=""" & strDefaultFontColor & """ link=""" & strLinkColor & """ aLink=""" & strActiveLinkColor & """ vLink=""" & strVisitedLinkColor & """>" & vbNewLine & _
" <table align=""center"" width=""95%"" height=""82"" border=""0"" bgcolor=""" & strHeadCellColor & """ cellPadding=""2"" cellSpacing=""0"" >" & vbNewline & _
" <tr>" & vbNewline & _
" <td valign=""top"">" & vbNewline & _
" <table align=""center"" border=""0"" cellPadding=""2"" cellSpacing=""0"" width=""100%"" height=""80"">" & vbNewLine & _
" <tr>" & vbNewLine & _
" <td valign=""center"" width=""30%"" bgcolor=""#FFFFFF""><a href=""default.asp"" tabindex=""-1"">" & getCurrentIcon(strTitleImage & "||",strForumTitle,"") & "</a>" & vbNewline & _
" </td>" & vbNewLine & _
" <td align=""center"" valign=""center"" width=""70%"" bgcolor=""#FFFFFF"">" & vbNewLine & _
" <font face=""" & strDefaultFontFace & """ color=""" & strHeadFontColor & """ size=""" & strFooterFontSize & """>" & vbNewline
%>
<!--#INCLUDE FILE="inc_banner_header.asp" -->
<%
Response.Write " </font>" & vbNewLine & _
" </td>" & vbNewLine & _
" </tr>" & vbNewLine & _
" </table>" & vbNewLine & _
" <table align=""center"" width=""95%"" height=""20"" border=""0"" bgcolor=""" & strHeadCellColor & """ cellPadding=""2"" cellSpacing=""0"" >" & vbNewline & _
" <tr>" & vbNewLine & _
" <td align=""left"" valign=""center"" width=""30%"" bgcolor=""" & strHeadCellColor & """>" & vbNewline & _
" <font face=""" & strDefaultFontFace & """ color=""" & strHeadFontColor & """ size=""" & strTopicFontSize & """><b> Maggotdrowning.com</b></font>" & vbNewline & _
" </td>" & vbNewLine
if (mlev = 0) then
if not(Instr(Request.ServerVariables("Path_Info"), "register.asp") > 0) and _
not(Instr(Request.ServerVariables("Path_Info"), "pop_profile.asp") > 0) and _
not(Instr(Request.ServerVariables("Path_Info"), "search.asp") > 0) and _
not(Instr(Request.ServerVariables("Path_Info"), "login.asp") > 0) and _
not(Instr(Request.ServerVariables("Path_Info"), "password.asp") > 0) and _
not(Instr(Request.ServerVariables("Path_Info"), "faq.asp") > 0) and _
not(Instr(Request.ServerVariables("Path_Info"), "contact.asp") > 0) and _
not(Instr(Request.ServerVariables("Path_Info"), "post.asp") > 0) then
Response.Write " <form action=""" & Request.ServerVariables("URL") & """ method=""post"" id=""form1"" name=""form1"">" & vbNewLine & _
" <input type=""hidden"" name=""Method_Type"" value=""login"">" & vbNewLine
if (strAuthType = "db") then
Response.Write " <td align=""center"" valign=""center"" width=""70%"" bgcolor=""" & strHeadCellColor & """>" & vbNewline & _
" <font face=""" & strDefaultFontFace & """ color=""" & strHeadFontColor & """ size=""" & strFooterFontSize & """><b>Username:</b></font>" & vbNewLine & _
" <input type=""text"" name=""Name"" size=""10"" maxLength=""25"" value="""">" & vbNewLine & _
" <font face=""" & strDefaultFontFace & """ color=""" & strHeadFontColor & """ size=""" & strFooterFontSize & """><b>Password:</b> " & vbNewLine & _
" <input type=""password"" name=""Password"" size=""10"" maxLength=""25"" value="""">" & vbNewLine & _
" <input type=""checkbox"" name=""SavePassWord"" value=""true"" tabindex=""-1"" CHECKED><b> Save Password</b></font>" & vbNewLine
if strGfxButtons = "1" then
Response.Write " <input src=""" & strImageUrl & "button_login.gif"" type=""image"" border=""0"" value=""Login"" id=""submit1"" name=""Login"">" & vbNewLine
else
Response.Write " <input type=""submit"" value=""Login"" id=""submit1"" name=""submit1"">" & vbNewLine
end if
end if
Response.Write " </td>" & vbNewLine & _
" </form>" & vbNewLine
end if
else
Response.Write " <form action=""" & Request.ServerVariables("URL") & """ method=""post"" id=""form2"" name=""form2"">" & vbNewLine & _
" <input type=""hidden"" name=""Method_Type"" value=""logout"">" & vbNewLine & _
" <td align=""center"" valign=""center"" width=""70%"" bgcolor=""" & strHeadCellColor & """>" & vbNewline
if strAuthType="nt" then
Response.Write "<b>" & Session(strCookieURL & "username") & " (" & Session(strCookieURL & "userid") & ")</b></font>" & vbNewLine
else
if strAuthType = "db" then
Response.Write " <font face=""" & strDefaultFontFace & """ color=""" & strHeadFontColor & """ size=""" & strDefaultFontSize & """>" & vbNewline & _
" You are logged in as: <b>" & ChkString(strDBNTUserName, "display") & "</b></font>" & vbNewLine
if strGfxButtons = "1" then
Response.Write " <input src=""" & strImageUrl & "button_logout.gif"" type=""image"" border=""0"" value=""Logout"" id=""submit1"" name=""Logout"" tabindex=""-1"">"
else
Response.Write " <input type=""submit"" value=""Logout"" id=""submit1"" name=""submit1"" tabindex=""-1"">"
end if
end if
end if
end if
Response.Write " </td>" & vbNewLine & _
" </form>" & vbNewLine & _
" </tr>" & vbNewLine & _
" </table>" & vbNewLine & _
" </td>" & vbNewLine & _
" </tr>" & vbNewLine & _
" </table>" & vbNewLine & _
" <font face=""" & strDefaultFontFace & """>" & vbNewLine & _
" <table align=""center"" border=""0"" cellPadding=""0"" cellSpacing=""0"" width=""100%"">" & vbNewLine & _
" <tr>" & vbNewLine & _
" <td align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strFooterFontSize & """>" & vbNewLine
if strDBType = "access" then
strSqL = "SELECT count(FORUM_PM.M_ID) as [pmcount] "
else
strSQL = "SELECT count(FORUM_PM.M_ID) as pmcount "
end if
strSql = strSql & " FROM FORUM_MEMBERS , FORUM_PM "
strSql = strSql & " WHERE FORUM_MEMBERS.M_NAME = '" & strDBNTUserName & "'"
strSql = strSql & " AND FORUM_MEMBERS.MEMBER_ID = FORUM_PM.M_TO "
Set rsPM = my_Conn.Execute(strSql)
pmcount = rsPM("pmcount")
rsPM.Close
set rsPM = Nothing
call sForumNavigation()
Response.Write "</font></td>" & vbNewLine & _
" </tr>" & vbNewLine
select case Request.Form("Method_Type")
case "login"
Response.Write " </table>" & vbNewLine & _
" </td>" & vbNewLine & _
" </tr>" & vbNewLine & _
"</table>" & vbNewLine
if strLoginStatus = 0 then
Response.Write "<p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strHeaderFontSize & """>Your username and/or password were incorrect.</font></p>" & vbNewLine & _
"<p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strHeaderFontSize & """>Please either try again or register for an account.</font></p>" & vbNewLine
else
Response.Write "<p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strHeaderFontSize & """>You logged on successfully!</font></p>" & vbNewLine & _
"<p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strHeaderFontSize & """>Thank you for your participation.</font></p>" & vbNewLine
end if
Response.Write "<meta http-equiv=""Refresh"" content=""2; URL=" & Request.ServerVariables("HTTP_REFERER") & """>" & vbNewLine & _
"<p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strDefaultFontSize & """><a href=""" & Request.ServerVariables("HTTP_REFERER") & """>Back To Forum</font></a></p>" & vbNewLine & _
"<table align=""center"" border=""0"" cellPadding=""0"" cellSpacing=""0"" width=""95%"">" & vbNewLine & _
" <tr>" & vbNewLine & _
" <td>" & vbNewLine
WriteFooter
Response.End
case "logout"
Response.Write " </table>" & vbNewLine & _
" </td>" & vbNewLine & _
" </tr>" & vbNewLine & _
"</table>" & vbNewLine & _
"<p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strHeaderFontSize & """>You logged out successfully!</font></p>" & vbNewLine & _
"<p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strHeaderFontSize & """>Thank you for your participation.</font></p>" & vbNewLine & _
"<meta http-equiv=""Refresh"" content=""2; URL=default.asp"">" & vbNewLine & _
"<p align=""center""><font face=""" & strDefaultFontFace & """ size=""" & strDefaultFontSize & """><a href=""default.asp"">Back To Forum</font></a></p>" & vbNewLine & _
"<table align=""center"" border=""0"" cellPadding=""0"" cellSpacing=""0"" width=""95%"">" & vbNewLine & _
" <tr>" & vbNewLine & _
" <td>" & vbNewLine
WriteFooter
Response.End
end select
Response.Write " </table>" & vbNewLine & _
" <table align=""center"" border=""0"" cellPadding=""0"" cellSpacing=""0"" width=""95%"">" & vbNewLine
' ## GROUP Categories Below
%>
<!--#INCLUDE FILE="inc_groupjump_to.asp" -->
<%
' ## GROUP Categories Above
Response.Write " <tr>" & vbNewLine & _
" <td>" & vbNewLine
sub sForumNavigation()
' DEM --> Added code to show the subscription line
if strSubscription > 0 and strEmail = "1" then
if mlev > 0 then
strSql = "SELECT COUNT(*) AS MySubCount FROM " & strTablePrefix & "SUBSCRIPTIONS"
strSql = strSql & " WHERE MEMBER_ID = " & MemberID
set rsCount = my_Conn.Execute (strSql)
if rsCount.BOF or rsCount.EOF then
' No Subscriptions found, do nothing
MySubCount = 0
rsCount.Close
set rsCount = nothing
else
MySubCount = rsCount("MySubCount")
rsCount.Close
set rsCount = nothing
end if
if mLev = 4 then
strSql = "SELECT COUNT(*) AS SubCount FROM " & strTablePrefix & "SUBSCRIPTIONS"
set rsCount = my_Conn.Execute (strSql)
if rsCount.BOF or rsCount.EOF then
' No Subscriptions found, do nothing
SubCount = 0
rsCount.Close
set rsCount = nothing
else
SubCount = rsCount("SubCount")
rsCount.Close
set rsCount = nothing
end if
end if
else
SubCount = 0
MySubCount = 0
end if
else
SubCount = 0
MySubCount = 0
end if
Response.Write " <table align=""center"" width=""95%"" height="""" border=""0"" bgcolor=""" & strHeadCellColor & """ cellPadding=""2"" cellSpacing=""0"" >" & vbNewline & _
" <tr>" & vbNewline & _
" <td valign=""top"">" & vbNewline & _
" <table align=""center"" width=""100%"" height=""20"" border=""0"" cellPadding=""2"" cellSpacing=""0"" >" & vbNewline & _
" <tr>" & vbNewline & _
" <td valign=""top"" width=""15%"" bgcolor=""" & strForumCellColor & """ align=""left"">" & vbNewline & _
" <font face=""" & strDefaultFontFace & """ size=""" & strFooterFontSize & """ color=""" & strDefaultFontColor & """>" & vbNewline & _
" <b> GENERAL TOOLS: </b>" & vbNewLine & _
" </font>" & vbNewline & _
" </td>" & vbNewline & _
" <td valign=""top"" width=""85%"" bgcolor=""" & strForumCellColor & """ align=""left"">" & vbNewline & _
" <font face=""" & strDefaultFontFace & """ size=""" & strFooterFontSize & """ color=""" & strDefaultFontColor & """>" & vbNewline & _
" <a href=""" & strHomeURL & """" & dWStatus("Homepage") & " tabindex=""-1""><acronym title=""Maggotdrowning.com Home Page"">Home Page</acronym></a>" & vbNewline & _
" | " & vbNewline
if strAutoLogon <> "1" then
if strProhibitNewMembers <> "1" then
Response.Write " <a href=""policy.asp""" & dWStatus("Register to post to our forum...") & " tabindex=""-1""><acronym title=""Register to post to our forum..."">Register</acronym></a>" & vbNewline & _
" | " & vbNewline
end if
end if
Response.Write " <a href=""active.asp""" & dWStatus("See what topics have been active since your last visit...") & " tabindex=""-1""><acronym title=""See what topics have been active since your last visit..."">Active Topics</acronym></a>" & vbNewline & _
" | " & vbNewline & _
" <a href=""unanswered.asp""" & dWStatus("View Unanswered Posts") & " tabindex=""-1""><acronym title=""View Unanswered Posts"">Unanswered</acronym></a>" & vbNewline & _
" | " & vbNewline
' DEM --> End of Code added to show subscriptions if they exist
Response.Write " <a href=""search.asp"
if Request.QueryString("FORUM_ID") <> "" then Response.Write("?FORUM_ID=" & cLng(Request.QueryString("FORUM_ID")))
Response.Write """" & dWStatus("Perform a search by keyword, date, and/or name...") & " tabindex=""-1""><acronym title=""Perform a search by keyword, date, and/or name..."">Search</acronym></a>" & vbNewline & _
" | " & vbNewline & _
" <a href=""faq.asp""" & dWStatus("Answers to Frequently Asked Questions...") & " tabindex=""-1""><acronym title=""Answers to Frequently Asked Questions..."">FAQ</acronym></a>" & vbNewline & _
" | " & vbNewline & _
" <a href=""../events/default.asp""" & dWStatus("Check out Future Events...") & " tabindex=""-1""><acronym title=""Check out Future Events..."">Calendar</acronym></a>" & vbNewline & _
" | " & vbNewline & _
" <a href=""classifieds.asp""" & dWStatus("The Maggotdrowners Classified Adverts...") & " tabindex=""-1""><acronym title=""The Maggotdrowners Classified Adverts..."">Classifieds</acronym></a>" & vbNewline & _
" | " & vbNewline & _
" <a href=""contact.asp""" & dWStatus("Contact Us") & " tabindex=""-1""><acronym title=""Contact Us"">Contact us</acronym></a>" & vbNewline & _
" | " & vbNewline & _
" <a href=""../forms/advertise.htm"" " & dWStatus("Advertising Enquiries...") & " tabindex=""-1""><acronym title=""Advertising Enquiries..."">Advertise</acronym></a>" & vbNewline & _
" | " & vbNewline & _
" <a href=""../store/index.php""" & dWStatus("Our Online Shop...") & " tabindex=""-1""><acronym title=""Our Online Shop..."">Online Shop</acronym></a>" & vbNewline & _
" </td>" & vbNewline & _
" </tr>" & vbNewline & _
" " & vbNewline & _
" <tr>" & vbNewline & _
" <td bgcolor=""" & strForumCellColor & """ width=""15%"" align=""left"">" & vbNewline & _
" <font face=""" & strDefaultFontFace & """ size=""" & strFooterFontSize & """ color=""" & strDefaultFontColor & """>" & vbNewline & _
" <b> MEMBER TOOLS: </b>" & vbNewLine & _
" </font>" & vbNewline & _
" </td> " & vbNewline & _
" " & vbNewline & _
" <td bgcolor=""" & strForumCellColor & """ width=""85%"" align="""">" & vbNewline
" <font face=""" & strDefaultFontFace & """ size=""" & strFooterFontSize & """ color=""" & strDefaultFontColor & """>" & vbNewline
if (mlev = 0) then
Response.Write " <a href=""javascript:openWindow('pop_login.asp')""" & dWStatus("Log In...") & " tabindex=""-1""><acronym title=""Log In...""><font face=""" & strDefaultFontFace & """ size=""" & strFooterFontSize & """ >Log In</acronym></a> or</font>" & vbNewLine & _
" | " & vbNewline & _
" <a href=""policy.asp""" & dWStatus("Register to post to our forum...") & " tabindex=""-1""><acronym title=""Register to post to our forum...""><font face=""" & strDefaultFontFace & """ size=""" & strFooterFontSize & """ >Click Here to Register</acronym></a> and access these tools. | </font>" & vbNewline & _
" | " & vbNewline & _
" <a href=""password.asp""" & dWStatus("Choose a new password if you have forgotten your current one...") & " tabindex=""-1"">Forgot your "
if strAuthType = "nt" then Response.Write("Admin ")
Response.Write "Password?</a>" & vbNewLine
else
' ## Profile Below
if strUseExtendedProfile then
Response.Write " | " & vbNewLine & _
" <a href=""pop_profile.asp?mode=Edit""" & dWStatus("Edit your personal profile...") & " tabindex=""-1""><acronym title=""Edit your personal profile..."">Profile</acronym></a>" & vbNewline
else
Response.Write " | " & vbNewLine & _
" <a href=""javascript:openWindow3('pop_profile.asp?mode=Edit')""" & dWStatus("Edit your personal profile...") & " tabindex=""-1""><acronym title=""Edit your personal profile..."">Profile</acronym></a>" & vbNewline
end if
' ## Profile Above
if MySubCount > 0 then
Response.Write " | " & vbNewLine & _
" <a href=""subscription_list.asp""" & dWStatus("See all of your subscriptions") & " tabindex=""-1""><acronym title=""See all of your subscriptions"">My Subscriptions</acronym></a>" & vbNewline
end if
' ## User Space Below
if trim(strUSSwitch) <> "" then
Response.Write " | " & vbNewLine & _
" <a href=""user_space.asp?mode=0"" " & dWStatus("View your forum folders") & " tabindex=""-1""><acronym title=""View your forum folders"">Your Space</acronym></a>" & vbNewline
end if
' ## User Space Above
' ## Photos Below
if strAllowAttachment = "1" then
Response.Write " | " & vbNewLine & _
" <a href=""myfiles.asp""" & dWStatus("My Files") & " tabindex=""-1""><acronym title=""Picture files"">Photos</acronym></a>" & vbNewline
end if
' ## Photos Above
' ## Private Messages Below
if strDBNTUserName <> "" and strPMStatus = "1" then
Response.Write " | " & vbNewLine & _
" <a href=""pm_view.asp""" & dWStatus("Check Your Private Messages...") & " tabindex=""-1""><acronym title=""Check Your Private Messages..."">Private Messages</acronym></a>" & vbNewline
end if
' ## Private Messages Above
' ## Chat Room Below
Function UsersCountGet()
Dim iUserId,iCount
iCount=Clng(0)
for iUserId=0 to MAX_USERS-1
if isArray(Application(iUserId & "Usr" & APP_VAR_FIX)) Then iCount=iCount+1
next
UsersCountGet=iCount
End Function
Response.Write " | " & vbNewLine & _
" <a href=""chat/default.asp""" & dWStatus("Chat with others live...") & " tabindex=""-1""><acronym title=""Chat with other users..."">Chat Room (" & UsersCountGet & ")</acronym></a>" & vbNewline
' ## Chat Room Above
' ## Donations Below
Response.Write " | " & vbNewLine & _
" <a href=""/site_supporter.htm""" & dWStatus("Support us - become a Site Supporter...") & " tabindex=""-1"" target=""_blank""><acronym title=""Support us - become a Site Supporter..."">Support MDs</acronym></a>" & vbNewline
' ## Donations Above
' ## Mods/Admins Member List
if mlev > 2 then
Response.Write " | " & vbNewLine & _
" <a href=""members.asp""" & dWStatus("Members List...") & " tabindex=""-1""><acronym title=""Members List..."">Members</acronym></a>" & vbNewline
end if
' ## UserGroup Below
blnCanView = ""
blnCanView = chkUserGroupView(MemberID)
if blnCanView = true then
Response.Write " | " & vbNewLine & _
" <a href=""usergroups.asp""" & dWStatus("View UserGroup Information") & " tabindex=""-1""><acronym title=""View UserGroup Information"">UserGroups</acronym></a>" & vbNewline
end if
' ## UserGroup Above
Response.Write " </td> " & vbNewline
end if
end if
Response.Write " </tr>" & vbNewline
if mLev > 3 then
Response.Write " " & vbNewline & _
" <tr>" & vbNewline & _
" <td bgcolor=""" & strForumCellColor & """ width=""15%"" align=""left"">" & vbNewline & _
" <font face=""" & strDefaultFontFace & """ size=""" & strFooterFontSize & """ color=""" & strDefaultFontColor & """>" & vbNewline & _
" <b> ADMIN TOOLS: </b>" & vbNewLine & _
" </font>" & vbNewline & _
" </td> " & vbNewline & _
" " & vbNewline & _
" <td bgcolor=""" & strForumCellColor & """ width=""85%"" align=""left"">" & vbNewline & _
" <font face=""" & strDefaultFontFace & """ size=""" & strFooterFontSize & """ color=""" & strDefaultFontColor & """>" & vbNewline
' ## Admin Members Pending Below
if (strEmailVal = "1" and strRestrictReg = "1" and strEmail = "1" and User_Count > 0) then
Response.Write(" | <a href=""admin_accounts_pending.asp""" & dWStatus("(" & User_Count & ") Member(s) awaiting approval") & " tabindex=""-1"">(" & User_Count & ") Member(s) awaiting approval</a>") & vbNewline & _
" | " & vbNewline
end if
' ## Admin Members Pending Above
' DEM --> Start of code added to show subscriptions if they exist
if (strSubscription > 0) then
if mlev > 3 and SubCount > 0 then
Response.Write " | " & vbNewLine & _
" <a href=""subscription_list.asp?MODE=all""" & dWStatus("See all current subscriptions") & " tabindex=""-1""><acronym title=""See all current subscriptions"">All Subscriptions</acronym></a>" & vbNewline
end if
end if
' ## Admin Tools Below
if (mlev > 3) or (lcase(strNoCookies) = "1") then
Response.Write " | " & vbNewLine & _
" <a href=""admin_home.asp""" & dWStatus("Access the Forum Admin Functions...") & " tabindex=""-1""><acronym title=""Access the Forum Admin Functions..."">Admin Options</acronym></a>" & vbNewLine & _
" | " & vbNewLine & _
" <a href=""setup.asp""" & dWStatus("Reset Forum Variables...") & " tabindex=""-1""><acronym title=""Reset Forum Variables..."">Reset Forum</acronym></a>" & vbNewline & _
" | " & vbNewLine & _
" <a href=""/forum/chat/admin.asp""" & dWStatus("Reset Forum Variables...") & " tabindex=""-1""><acronym title=""Chat Room Administration..."">Chat Admin</acronym></a>" & vbNewline
end if
Response.Write " </td>" & vbNewline & _
" </tr>" & vbNewline & _
" </table>" & vbNewLine & _
" </td>" & vbNewLine & _
" </tr>" & vbNewLine & _
" </table>" & vbNewLine
" </td>" & vbNewLine & _
" </tr>" & vbNewLine & _
" </table>" & vbNewLine
end if
end sub
if strGroupCategories = "1" then
if Session(strCookieURL & "GROUP_NAME") = "" then
GROUPNAME = " Default Groups "
else
GROUPNAME = Session(strCookieURL & "GROUP_NAME")
end if
' Forum_SQL - Get Groups
strSql = "SELECT GROUP_ID, GROUP_CATID "
strSql = strSql & " FROM " & strTablePrefix & "GROUPS "
strSql = strSql & " WHERE GROUP_ID = " & Group
set rsgroups = Server.CreateObject("ADODB.Recordset")
rsgroups.Open strSql, my_Conn, adOpenForwardOnly, adLockReadOnly, adCmdText
if rsgroups.EOF then
recGroupCatCount = ""
else
allGroupCatData = rsgroups.GetRows(adGetRowsRest)
recGroupCatCount = UBound(allGroupCatData, 2)
end if
rsgroups.Close
set rsgroups = nothing
end if
%>
<!--#INCLUDE FILE="inc_ipgate.asp"-->
<!--#INCLUDE FILE="inc_message.asp" -->
<table border="0" cellpadding="4" cellspacing="0" width="100%">
<tr>
<td width="100%">
<font face="<% =strDefaultFontFace %>" size="<% =strFooterFontSize %>">
<%
if strDBNTUserName <> "" then
' Get Private Message count for display on Default.asp
if strDBType = "access" then
strSqL = "SELECT count(M_TO) as [pmcount] "
else
strSqL = "SELECT count(M_TO) as pmcount "
end if
strSql = strSql & " FROM " & strMemberTablePrefix & "MEMBERS , " & strTablePrefix & "PM "
strSql = strSql & " WHERE " & strMemberTablePrefix & "MEMBERS.M_NAME = '" & strDBNTUserName & "'"
strSql = strSql & " AND " & strMemberTablePrefix & "MEMBERS.MEMBER_ID = " & strTablePrefix & "PM.M_TO "
strSql = strSql & " AND " & strTablePrefix & "PM.M_READ = 0 "
Set rsPM = my_Conn.Execute(strSql)
if not rsPM.EOF then
pmcount = rsPM("pmcount")
rsPM.close
end if
set rsPM = nothing
if pmCount > 0 then
response.write " " & vbNewline & _
" <a href=""pm_view.asp""><img border=""0"" src=""icon_newmes.gif""><acronym title=""Click to read Message"">You have a new Private Message</acronym></a>" & vbNewline
end if
end if
%>
</font><br>
</td>
</tr>
</table>
|
| Webbo |
Posted - 29 March 2011 : 17:21:37
Hi Carefree,
The chatapi file doesn't want to display in txt format in a browser so I've pasted it below:
<!-- #include file="settings.asp" -->
<script language=vbscript runat=server>
'A uniform way of getting a users data
'returns boolean indicating success of operation
Function UserGet(iUserId,aUsr)
aUsr=Application(iUserId & "Usr" & APP_VAR_FIX)
UserGet=isArray(aUsr)
End Function
'A uniforma way of storing user's data
'returns boolean indicating success of operation
Function UserSet(iUserId,aUsr)
if isArray(aUsr) Then
Application(iUserId & "Usr" & APP_VAR_FIX)=aUsr
UserSet=true
Else
UserSet=false
End if
End function
'Returns a total user count (in all chat rooms)
Function UsersCountGet()
Dim iUserId,iCount
iCount=Clng(0)
for iUserId=0 to MAX_USERS-1
if isArray(Application(iUserId & "Usr" & APP_VAR_FIX)) Then iCount=iCount+1
next
UsersCountGet=iCount
End Function
'fills aUsers parameter with array of users, each elemet od that array is an array itself
'also fills an array of user id into aIds
Function UsersArrayGet(aUsers,aIds)
Dim iCount,iCurrCount,iUserId
iCount=UsersCountGet()
Redim aUsers(iCount)
Redim aIds(iCount)
iCurrCount=0
for iUserId=0 to MAX_USERS-1
if iCurrCount>=iCount Then Exit For
if isArray(Application(iUserId & "Usr" & APP_VAR_FIX)) Then
aUsers(iCurrCount)=Application(iUserId & "Usr" & APP_VAR_FIX)
aIds(iCurrCount)=iUserId
iCurrCount=iCurrCount+1
End If
Next
UsersArrayGet=iCurrCount
End Function
'Verifies user Id against the password
'you most likely are going to rewrite this function to accomodate your database
'the code here is just a sample
Function UserAuthenticate(sUserName,sPassword)
Dim oRs
Set oRs=Server.CreateObject("ADODB.Recordset")
oRs.Open "select user_name from users where user_name='" & EscQ(sUserName) & "' AND password='" & EscQ(sPassword) & "'" ,_
"Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & Server.MapPath("db1.mdb"),0,1,1
UserAuthenticate=NOT (oRs.BOF AND oRs.EOF)
Set oRs=Nothing
End Function
'Logges in user "sUserName" and returns a new user ID in "iUserId" param
'function reurns true on success and false on falire with "sError" describing error
Function UserLogin(sUserName,sPassword,iRoomIdParam,sError,iError,iUserId)
Dim sUser,iUsrCount,iUid,aUsr,i,ub,bUsrNameFound,iNextAvailIndx,iRoomId
UserLogin=false
sError=""
iError=0
sUser=Trim(sUserName)
sUser=Replace(sUser,"<","<")
sUser=Replace(sUser,">",">")
If Len(sUser) <1 Then
sError = "You have to enter a username before starting to chat."
iError=2
ElseIf Len(sUser) > MAX_USERNAME_LENGTH Then
sError = "Username must not exceed " & MAX_USERNAME_LENGTH & " characters."
iError=3
ElseIf InStr(sUser, Chr(1)) > 0 Then
sError = "Your username contains inappropriate characters. Please choose another one."
iError=4
Else
if ValidSessionUserGet(iUid,aUsr) Then
sError="You are already logged in as " & aUsr(ZBC_COL_USER_NAME)
iError=5
Exit Function
End If
If USE_AUTHENTICATION>0 Then
If USE_AUTHENTICATION=2 Then
If strcomp(sPassword,"test",1)<>0 Then
sError="Invalid login: please use ""test"" as a password in this demo mode."
iError=18
Exit Function
End If
Else 'USE_AUTHENTICATION=1
If NOT UserAuthenticate(sUserName,sPassword) Then
sError="Invalid login "
iError=18
Exit Function
End If
End If
End If
bUsrNameFound=false
iNextAvailIndx=-1
Application.Lock
'because we are in Application-lock mode, for maximum officiency, do everythin inline (don't call subprocedures)
For i=0 to MAX_USERS-1
If UserGet(i,aUsr) Then
if strcomp(sUser,aUsr(ZBC_COL_USER_NAME),1)=0 Then
bUsrNameFound=true
Exit For 'note: the iNextAvailIndx is going to be inaccurate, but we don't care
End If
Else
If iNextAvailIndx<0 Then iNextAvailIndx=i
End if
Next
If bUsrNameFound Then
sError = "Sorry,<br><br>You cannot use this username, since another person is using this already."
iError=6
ElseIf iNextAvailIndx=-1 Then
sError = "The maximum number of users have been reached. You are not allowed to login at this time."
iError=7
Else
iRoomId=0
if IsNumeric(iRoomIdParam) Then
if iRoomIdParam>0 Then iRoomId=Cint(iRoomIdParam)
End if
call RooomUsrCountUp(iRoomId)
Dim aUsrNew(9)
aUsrNew(ZBC_COL_USER_GUID)=Session.SessionID
aUsrNew(ZBC_COL_USER_NAME)=sUser
aUsrNew(ZBC_COL_USER_ROOM)=iRoomId
aUsrNew(ZBC_COL_USER_LAST_MSGS)=0
aUsrNew(ZBC_COL_USER_LAST_USRS)=0
aUsrNew(ZBC_COL_USER_LAST_ROMS)=0
aUsrNew(ZBC_COL_USER_LREQ_TIME)=now()
call ChatSessionUidSet(iNextAvailIndx)
Application(iNextAvailIndx & "Usr" & APP_VAR_FIX)=aUsrNew
' tell all other users about this new user
call MessageAdd(iRoomId,-1,-1,chr(6) & sUser & " logged on at " & time(),sError)
UserLogin=true
End If
Application.UnLock
End If
End Function
'remove user "iUserId" from the chat
'retursn the room id where user was last seen or -1 on error
Function RemoveUser(iUserId)
dim iRoomId,aUsr,i,aRoom,sErr
iRoomId=-1
If UserGet(iUserId,aUsr) Then
' we need to remove all rooms for this user as well
For iRoomId=0 to MAX_ROOMS-1
if RoomGet(iRoomId,aRoom) Then
If aRoom(ZBC_COL_ROOM_OWNER) = iUserId Then
call RoomRemove(iRoomId,sErr)
End If
End If
Next
Application.Lock
If UserGet(iUserId,aUsr) Then 'need to reget user since his room id might have changed
iRoomId=aUsr(ZBC_COL_USER_ROOM)
'Application.Contents.Remove(iUserId & "Usr" & APP_VAR_FIX)
Application(iUserId & "Usr" & APP_VAR_FIX)=Empty
call RooomUsrCountDown(iRoomId)
End If
Application.UnLock
End if
RemoveUser=iRoomId
End Function
'logges off user "iUid" from the chat
'"bFromUI" parameter indicates wheter user logged off volonterally or has been forced out
Function LogOffUser(iUid,bFromUI)
Dim aUsr,iRoomId,sError
If UserGet(iUid,aUsr) Then
iRoomId=RemoveUser(iUid)
If EXIT_TROUGH_PRIME_ONLY OR iRoomId<0 Then
iRoomId=0
End If
If bFromUI Then
Call MessageAdd(iRoomId,-1,-1,chr(7) & aUsr(ZBC_COL_USER_NAME) & " logged off at " & time(),sError)
Else
Call MessageAdd(iRoomId,-1,-1,chr(8) & aUsr(ZBC_COL_USER_NAME) & " has been logged out at " & time(),sError)
End if
If iUid=ChatSessionUidGet() Then
call ChatSessionUidSet(Empty)
End If
MessageMaintanace(false)
LogOffUser=true
Else
LogOffUser=false
End If
End Function
Function GhostAdd(iUid)
Dim arrGhost,iIndx
Application.Lock
arrGhost=Application("arrGhost" & APP_VAR_FIX)
if IsArray(arrGhost) Then
iIndx=Ubound(arrGhost,2)+1
redim preserve arrGhost(1,iIndx)
Else
iIndx=0
redim arrGhost(1,iIndx)
End If
arrGhost(ZBC_COL_GHOST_ID,iIndx)=iUid
arrGhost(ZBC_COL_GHOST_TIME,iIndx)=now()
Application("arrGhost" & APP_VAR_FIX)=arrGhost
Application.UnLock
End Function
Function GhostRemove(iUid)
Dim arrGhost,ub,i,j
GhostRemove=false
Application.Lock
arrGhost=Application("arrGhost" & APP_VAR_FIX)
if IsArray(arrGhost) Then
ub=Ubound(arrGhost,2)
for i=0 to ub
if arrGhost(ZBC_COL_GHOST_ID,i)=iUid Then
if ub>0 Then
for j=i to ub-1 step 1 'shift the array
arrGhost(ZBC_COL_GHOST_ID,j)=arrGhost(ZBC_COL_GHOST_ID,j+1)
arrGhost(ZBC_COL_GHOST_TIME,j)=arrGhost(ZBC_COL_GHOST_TIME,j+1)
Next
redim preserve arrGhost(1,ub-1)
Else
arrGhost=Empty
End If
Application("arrGhost" & APP_VAR_FIX)=arrGhost
GhostRemove=true
exit for
End If
next
End If
Application.UnLock
End Function
Sub GhostsCheck()
Dim arrGhost,ub,i
Dim iUserId,aUser
If datediff("s",Application("ChkIntrShr" & APP_VAR_FIX),now())>=GHOST_CHECK_INERVAL_SHORT Then
'don't want to lock application yet - we must be super efficient
if IsArray(Application("arrGhost" & APP_VAR_FIX)) Then
arrGhost=Application("arrGhost" & APP_VAR_FIX)
ub=Ubound(arrGhost,2)
for i=0 to ub
If datediff("s",arrGhost(ZBC_COL_GHOST_TIME,i),now())>MAX_GHOST_TIME_SHORT Then
'call MessageLog(-1,-1,-1,"ghost=" & arrGhost(ZBC_COL_GHOST_ID,i) & " time" & arrGhost(ZBC_COL_GHOST_TIME,i) & " now=" & now() & " chkShort=" & Application("ChkIntrShr" & APP_VAR_FIX))
Application.Lock
call LogOffUser(arrGhost(ZBC_COL_GHOST_ID,i),false)
call GhostRemove(arrGhost(ZBC_COL_GHOST_ID,i))
Application.UnLock
End If
Next
End If
Application("ChkIntrShr" & APP_VAR_FIX)=now()
End If
If datediff("s",Application("ChkIntrLng" & APP_VAR_FIX),now())>=GHOST_CHECK_INERVAL_LONG Then
'for maximum efficiency doing everything inline
for iUserId=0 to MAX_USERS-1 step 1
if isArray(Application(iUserId & "Usr" & APP_VAR_FIX)) Then
aUser=Application(iUserId & "Usr" & APP_VAR_FIX)
if datediff("s",aUser(ZBC_COL_USER_LREQ_TIME),now())>MAX_GHOST_TIME_LONG Then
'call MessageLog(-2,-1,-1,"ghost=" & iUserId & " time" & aUser(ZBC_COL_USER_LREQ_TIME) & " now=" & now() & " chkLong=" & Application("ChkIntrLng" & APP_VAR_FIX))
Application.Lock
call LogOffUser(iUserId,false)
call GhostRemove(iUserId)
Application.UnLock
End If
End If
Next
Application("ChkIntrLng" & APP_VAR_FIX)=now()
End If
End Sub
Function GhostArrayGet(arrGhost)
arrGhost=Application("arrGhost" & APP_VAR_FIX)
If IsArray(arrGhost) Then
GhostArrayGet=Ubound(arrGhost,2)+1
Else
GhostArrayGet=0
End If
End Function
'a uniform way of getting a chat session user id
Function ChatSessionUidGet()
ChatSessionUidGet=Session(UID_SESSION_VAR_NAME)
End Function
Sub ChatSessionUidSet(iUid)
if (NOT IsEmpty(iUid)) AND IsNumeric(iUid) Then
Session(UID_SESSION_VAR_NAME)=Clng(iUid)
Else
Session(UID_SESSION_VAR_NAME)=Empty
End If
End Sub
Function ChatSessionGUidGet()
ChatSessionGUidGet=Session.SessionID
End Function
Function ValidSessionUserGet(iUidRet,aUsrRet)
iUidRet=ChatSessionUidGet()
if NOT isEmpty(iUidRet) Then
if UserGet(iUidRet,aUsrRet) Then
if aUsrRet(ZBC_COL_USER_GUID)=ChatSessionGUidGet() Then
ValidSessionUserGet=true
Exit Function
End If
End If
End If
call ChatSessionUidSet(Empty)
ValidSessionUserGet=false
End Function
'Get the last update in a room
Function RoomUserListLastId(iRoomId)
RoomUserListLastId=Application(iRoomId & "_UsersUpd" & APP_VAR_FIX)
End function
'returns a room array from the "iRoomId"
Function RoomGet(iRoomId,aRoom)
aRoom=Application(iRoomId & "Room" & APP_VAR_FIX)
RoomGet=isArray(aRoom)
End Function
'a uniform way of storing Room information
Function RoomSet(iRoomId,aRoom)
if isArray(aRoom) Then
Application(iRoomId & "Room" & APP_VAR_FIX)=aRoom
RoomSet=true
Else
RoomSet=false
End if
End function
'gets number of rooms
Function RoomsCountGet()
Dim iRoomId,iCount
iCount=Clng(0)
for iRoomId=0 to MAX_ROOMS-1
if isArray(Application(iRoomId & "Room" & APP_VAR_FIX)) Then iCount=iCount+1
next
RoomsCountGet=iCount
End Function
'similar to UserArrayGet but for rooms
Function RoomsArrayGet(aRooms,aIds)
Dim iCount,iCurrCount,iRoomId,v
iCurrCount=0
If DefaultRoomsCheck(v)=0 Then Exit Function
call GhostsCheck()
iCount=RoomsCountGet()
Redim aRooms(iCount)
Redim aIds(iCount)
for iRoomId=0 to MAX_ROOMS-1
if iCurrCount>=iCount Then Exit For
if isArray(Application(iRoomId & "Room" & APP_VAR_FIX)) Then
aRooms(iCurrCount)=Application(iRoomId & "Room" & APP_VAR_FIX)
aIds(iCurrCount)=iRoomId
iCurrCount=iCurrCount+1
End If
Next
RoomsArrayGet=iCurrCount
End Function
'Checks if the default rooms have been created and if not creates them
'function retuns non-zero on success or 0 on failure and an error in "sError"
Function DefaultRoomsCheck(sError)
Dim aRoom,aRooms,sRoomName,roomCount,i
If RoomGet(0,aRoom) Then
DefaultRoomsCheck=-1
Else
aRooms = Split(DEFAULT_ROOMS, ";")
If IsArray(aRooms) Then
For i = 0 To UBound(aRooms)
sRoomName = Trim(aRooms(i))
If len(sRoomName)>0 Then
If Not RoomIdAdd(i,sRoomName, "-1",sError) Then
DefaultRoomsCheck=0
Exit Function
End If
End If
Next
DefaultRoomsCheck=i
Else
sError="rooms array can not be created."
DefaultRoomsCheck=0
End If
End If
End Function
'adds a new room with an id "iRoomId" named "sRoomName" and created by "iUserId" to the chat
'returns True on success; returns False on failure with "sError" parameter filled in
Function RoomIdAdd(iRoomId,sRoomName,iUserId,sError)
' check for valid room name
Dim check,aRoom(2)
RoomIdAdd = False
Set check = New RegExp
check.Pattern ="([\x01-\x1F\&\#\+\=\<\>])" ' "[a-zA-z0-9 ]"
check.IgnoreCase = False
check.Global = True
If check.Test(sRoomName) Then
sError="Invalid Room Name"
Exit Function
End If
aRoom(ZBC_COL_ROOM_NAME)=sRoomName
aRoom(ZBC_COL_ROOM_OWNER)=iUserId
aRoom(ZBC_COL_ROOM_COUNT)=0
Application.Lock
If Not IsEmpty(Application(iRoomId & "Room" & APP_VAR_FIX)) Then
sError="Room Id (" & iRoomId & ") already used"
Else
Application(iRoomId & "Room" & APP_VAR_FIX)=aRoom
Application("RoomsUpd" & APP_VAR_FIX)=clng(1)+Application("RoomsUpd" & APP_VAR_FIX)
RoomIdAdd = True
End if
Application.UnLock
End Function
'adds a new room "sRoomName" created by "iUserId" to the chat
'returns True on success; returns False on failure and fills in "sError" parameter
Function RoomAdd(sRoomName,iUserId,sError)
Dim iRoomId,aRoom,iNextRoomId
RoomAdd=false
if MAX_ROOMNAME_LENGTH<len(sRoomName) Then
sError="Room name (" & sRoomName & ") is too long. Maximum length is " & MAX_ROOMNAME_LENGTH
Exit Function
End If
iNextRoomId=-1
For iRoomId=0 to MAX_ROOMS-1
if RoomGet(iRoomId,aRoom) Then
if Strcomp(sRoomName,aRoom(ZBC_COL_ROOM_NAME),1)=0 Then
sError="Room name (" & sRoomName & ") alresdy exists."
Exit Function
End If
Else
if iNextRoomId<0 Then iNextRoomId=iRoomId
End if
Next
If iNextRoomId=-1 then
sError="Maximum number of rooms allowed (" & MAX_ROOMS & ") is reached."
RoomAdd = False
Exit Function
End if
RoomAdd=RoomIdAdd(iNextRoomId,sRoomName,iUserId,sError)
End Function
'returns a string containg all users in a room "iRoomId"
'the string is delimited by special character accourding to our custom protocol
'"vCurUserId" is passed to diferentiate between current user and all the other users
Function RoomUsersGet(iRoomId,vCurUserId)
Dim iUserId,aUsr,sOut,iCurUserId
iCurUserId=CLng(vCurUserId)
For iUserId=0 to MAX_USERS-1
If (UserGet(iUserId,aUsr)) Then
If (aUsr(ZBC_COL_USER_ROOM) = iRoomId) Then
if iUserId=iCurUserId Then
sOut=sOut & chr(4) & iUserId & chr(3) & aUsr(ZBC_COL_USER_NAME)
Else
sOut=sOut & chr(2) & iUserId & chr(3) & aUsr(ZBC_COL_USER_NAME)
End if
End If
End If
Next
RoomUsersGet=sOut
End Function
'returns a string containg all Rooms in the chat
'the string is delimited by special character accourding to our custom protocol
'"iCurRoomId" is passed to diferentiate between current room and all the other rooms
Function RoomsGet(iCurRoomId)
Dim iRoomId,aRoom,sOut
For iRoomId=0 to MAX_ROOMS-1
If RoomGet(iRoomId,aRoom) Then
if iCurRoomId=iRoomId Then
sOut=sOut & chr(2) & chr(4) & iRoomId & chr(3) & aRoom(ZBC_COL_ROOM_NAME) & " (" & aRoom(ZBC_COL_ROOM_COUNT) & ")"
Else
sOut=sOut & chr(2) & iRoomId & chr(3) & aRoom(ZBC_COL_ROOM_NAME) & " (" & aRoom(ZBC_COL_ROOM_COUNT) & ")"
End If
End If
Next
RoomsGet=sOut
End Function
'Removes room "vRoomId" from the chat
'returns True on success; returns False on failure and fills in "sError" parameter
Function RoomRemove(vRoomId,sErr)
Dim iRoomId,aRoom,iUserId,aUsr
iRoomId=CLng(vRoomId)
RoomRemove=false
Application.Lock
' make sure we actually have the room we are about to remove
If RoomGet(iRoomId,aRoom) Then
' remove from global internal structure
'Application.Contents.Remove(iRoomId & "Room" & APP_VAR_FIX)
Application(iRoomId & "Room" & APP_VAR_FIX)=Empty
' transfer all users from this (removed) room to main entrance
For iUserId=0 To MAX_USERS-1
If UserGet(iUserId,aUsr) Then
If (aUsr(ZBC_COL_USER_ROOM) = iRoomId) Then
call UserRoomSwitch(iUserId,0,sErr,false)
End If
End If
Next
call MessagesRemove(iRoomId,false)
Application("RoomsUpd" & APP_VAR_FIX)=clng(1)+Application("RoomsUpd" & APP_VAR_FIX)
RoomRemove=true
Else
sErr="Room ID (" & iRoomId & ") does not exist"
End If
Application.UnLock
End Function
'increment a user count in a given room
Function RooomUsrCountUp(iRoomId)
Dim aRoom
RooomUsrCountUp=false
If RoomGet(iRoomId,aRoom) Then
aRoom(ZBC_COL_ROOM_COUNT)=CLng(1) + aRoom(ZBC_COL_ROOM_COUNT)
call RoomSet(iRoomId,aRoom)
Application("RoomsUpd" & APP_VAR_FIX)=Clng(1)+Application("RoomsUpd" & APP_VAR_FIX)
Application(iRoomId & "_UsersUpd" & APP_VAR_FIX)=CLng(1)+Application(iRoomId & "_UsersUpd" & APP_VAR_FIX)
RooomUsrCountUp=true
End If
End Function
'decrement a user count in a given room
Function RooomUsrCountDown(iRoomId)
Dim aRoom
RooomUsrCountDown=false
If RoomGet(iRoomId,aRoom) Then
If aRoom(ZBC_COL_ROOM_COUNT)>0 Then
aRoom(ZBC_COL_ROOM_COUNT)=aRoom(ZBC_COL_ROOM_COUNT)-CLng(1)
call RoomSet(iRoomId,aRoom)
Application("RoomsUpd" & APP_VAR_FIX)=Clng(1)+Application("RoomsUpd" & APP_VAR_FIX)
Application(iRoomId & "_UsersUpd" & APP_VAR_FIX)=CLng(1)+Application(iRoomId & "_UsersUpd" & APP_VAR_FIX)
RooomUsrCountDown=true
End If
End If
End Function
'Removes room "iRoomId" from the chat requested by user "iUserId"
'returns True on success; returns False on failure and fills in "sError" parameter
Function UserRoomRemove(iUserId,iRoomId,sError)
Dim aRoom
UserRoomRemove=false
If Not RoomGet(iRoomId,aRoom) Then
sError="Room not found"
Exit Function
End if
If aRoom(ZBC_COL_ROOM_OWNER)<>iUserId Then
sError="Can not delete a room that was not created by you."
Exit Function
End if
UserRoomRemove=RoomRemove(iRoomId,sError)
End Function
'user "iUserId" switches room to "newRoomId"
'returns True on success; returns False on failure and fills in "sError" parameter
Function UserRoomSwitch(iUserId,vRoomId,sError,bNotifyOldRoom)
Dim aUsr,iRoomId,iOldRoomId
UserRoomSwitch=false
iRoomId=CLng(vRoomId)
If UserGet(iUserId,aUsr) Then
iOldRoomId=aUsr(ZBC_COL_USER_ROOM)
if iOldRoomId=iRoomId Then
sError="Error in UserRoomSwitch: old and new Room Ids are the same."
Exit Function
End if
' change room
aUsr(ZBC_COL_USER_ROOM) = iRoomId
if NOT UserSet(iUserId,aUsr) Then
sError="Error storing user data in UserRoomSwitch"
Exit Function
End if
Application.Lock
call RooomUsrCountDown(iOldRoomId)
call RooomUsrCountUp(iRoomId)
Application.UnLock
If bNotifyOldRoom Then
' notify users in old room
Call MessageAdd(iOldRoomId,-1,-1,chr(8) & aUsr(ZBC_COL_USER_NAME) & " left the room at " & time(),sError)
End If
' notify users in new room
Call MessageAdd(iRoomId,-1,-1,chr(8) & aUsr(ZBC_COL_USER_NAME) & " has entered the room at " & time(),sError)
UserRoomSwitch=true
Else
sError="User is not found"
End if
End Function
'returns the ID of the last update in the list of rooms
Function RoomsListLastId()
RoomsListLastId=Application("RoomsUpd" & APP_VAR_FIX)
End function
Function MessageLineGet(sTxt,iSessionUser,iFromId,sFromName,iPrivInd)
MessageLineGet=""
if iFromId>=0 Then
If iPrivInd Then
MessageLineGet=chr(4)
Else
MessageLineGet=chr(2)
End If
If iSessionUser=iFromId Then MessageLineGet=MessageLineGet & chr(5)
MessageLineGet=MessageLineGet & sFromName & chr(3)
End If
MessageLineGet=MessageLineGet & sTxt
End function
'returns alls the messages in a room "iRoomId"
Function MesegesGet(iRoomId,iUserId)
dim sOut,i,indx,iCurrMsg,aMsgs,aUser,aPrivMsgs,iPrivMsgPtr,iPrivIndx,iMsgCount,iSessionUser
sOut=""
iPrivMsgPtr=-1
If UserGet(iUserId,aUser) Then
If IsArray(aUser(ZBC_COL_USER_PRIV_MSGS)) Then
aPrivMsgs=aUser(ZBC_COL_USER_PRIV_MSGS)
iPrivMsgPtr=aUser(ZBC_COL_USER_PRIV_PTR)
End If
Else
Exit Function
End if
iSessionUser=aUser(ZBC_COL_USER_GUID)
iPrivIndx=iPrivMsgPtr
aMsgs=Application(iRoomId & "Msg" & APP_VAR_FIX)
iCurrMsg=Application(iRoomId & "PtrMsg" & APP_VAR_FIX)
If isArray(aMsgs) Then
iMsgCount=0
For i = 0 To MAX_MSG_LINES-1
indx=iCurrMsg-i
if indx<0 Then indx=MAX_MSG_LINES+indx
if iPrivIndx<>-1 Then
do while indx=aPrivMsgs(ZBC_COL_PMSG_INDX,iPrivIndx)
if aPrivMsgs(ZBC_COL_PMSG_ID,iPrivIndx)=aMsgs(ZBC_COL_MSG_ID,indx) Then
If (TOP_MESSAGE_ORDER) Then
sOut=sOut & MessageLineGet(aPrivMsgs(ZBC_COL_PMSG_TEXT,iPrivIndx),iSessionUser,aPrivMsgs(ZBC_COL_PMSG_FROM_ID,iPrivIndx),aPrivMsgs(ZBC_COL_PMSG_FROM_NAME,iPrivIndx),1)
Else
sOut=MessageLineGet(aPrivMsgs(ZBC_COL_PMSG_TEXT,iPrivIndx),iSessionUser,aPrivMsgs(ZBC_COL_PMSG_FROM_ID,iPrivIndx),aPrivMsgs(ZBC_COL_PMSG_FROM_NAME,iPrivIndx),1) & sOut
End If
iMsgCount=iMsgCount+1
if iMsgCount>=MAX_MSG_LINES Then exit for
End if
iPrivIndx=iPrivIndx-1
if iPrivIndx<0 Then iPrivIndx=MAX_MSG_LINES-1
if iPrivIndx=iPrivMsgPtr Then
iPrivIndx=-1
exit do
End If
loop
End If
if IsEmpty(aMsgs(ZBC_COL_MSG_FROM_ID,indx)) Then
Exit For
Else
If (TOP_MESSAGE_ORDER) Then
sOut=sOut & MessageLineGet(aMsgs(ZBC_COL_MSG_TEXT,indx),iSessionUser,aMsgs(ZBC_COL_MSG_FROM_ID,indx),aMsgs(ZBC_COL_MSG_FROM_NAME,indx),0)
Else
sOut=MessageLineGet(aMsgs(ZBC_COL_MSG_TEXT,indx),iSessionUser,aMsgs(ZBC_COL_MSG_FROM_ID,indx),aMsgs(ZBC_COL_MSG_FROM_NAME,indx),0) & sOut
End If
iMsgCount=iMsgCount+1
if iMsgCount>=MAX_MSG_LINES Then exit for
End If
Next
End if
'sOut=time() & sOut
MesegesGet=sOut
End Function
'adds a privite message to one user (iUserId)
'returns boolean indicating success of operation
Function MessagePrivateAdd(iUserId,iUpdMsg,iMsgId,sMessage,iUserFrom,sError)
Dim aPrivMsgs,aUsr,iPrivMsgPtr,aFromUsr
MessagePrivateAdd=false
If UserGet(iUserId,aUsr) Then
aPrivMsgs=aUsr(ZBC_COL_USER_PRIV_MSGS)
If VarType(aPrivMsgs)=0 Then
redim aPrivMsgs(4,MAX_MSG_LINES-1)
aUsr(ZBC_COL_USER_PRIV_PTR)=-1
End If
If isArray(aPrivMsgs) Then
iPrivMsgPtr=aUsr(ZBC_COL_USER_PRIV_PTR)
if iPrivMsgPtr>=MAX_MSG_LINES-1 Then iPrivMsgPtr=0 Else iPrivMsgPtr=CLng(1)+iPrivMsgPtr
aPrivMsgs(ZBC_COL_PMSG_INDX,iPrivMsgPtr)=iUpdMsg
aPrivMsgs(ZBC_COL_PMSG_ID,iPrivMsgPtr)=iMsgId
aPrivMsgs(ZBC_COL_PMSG_TEXT,iPrivMsgPtr)=sMessage
aPrivMsgs(ZBC_COL_PMSG_FROM_ID,iPrivMsgPtr)=iUserFrom
if iUserId=iUserFrom Then
aPrivMsgs(ZBC_COL_PMSG_FROM_ID,iPrivMsgPtr)=aUsr(ZBC_COL_USER_GUID)
aPrivMsgs(ZBC_COL_PMSG_FROM_NAME,iPrivMsgPtr)=aUsr(ZBC_COL_USER_NAME)
Else
if UserGet(iUserFrom,aFromUsr) Then
aPrivMsgs(ZBC_COL_PMSG_FROM_ID,iPrivMsgPtr)=aFromUsr(ZBC_COL_USER_GUID)
aPrivMsgs(ZBC_COL_PMSG_FROM_NAME,iPrivMsgPtr)=aFromUsr(ZBC_COL_USER_NAME)
Else
sError="MessagePrivateAdd - error getting user's information"
Exit Function
End If
End If
aUsr(ZBC_COL_USER_PRIV_MSGS)=aPrivMsgs
aUsr(ZBC_COL_USER_PRIV_PTR)=iPrivMsgPtr
aUsr(ZBC_COL_USER_LAST_MSGS)=-1 'will forse refresh
If UserSet(iUserId,aUsr) Then
MessagePrivateAdd=true
Else
sError="MessagePrivateAdd - error saving user's data"
End If
Else
sError="MessagePrivateAdd - aPrivMsgs is not of valid type"
End If
End if
End Function
'if logging is enabled saves text of the message in designated log file
Function MessageLog(iRoomId,iUsrFrom,iUsrTo,sMessage)
Dim sFilePath,sDate,fso,oFile,oCon,sSql
Dim aUsr,aRm,sUfrom,sUTo,sRoomName
MessageLog=""
If len(CHAT_SAVE_LOG_FILE)<1 AND NOT CHAT_SAVE_LOG_DB Then
Exit Function
End If
if CHAT_DETAILED_LOG Then
if UserGet(iUsrFrom,aUsr) Then sUfrom=aUsr(ZBC_COL_USER_NAME)
if UserGet(iUsrTo,aUsr) Then sUTo=aUsr(ZBC_COL_USER_NAME)
if RoomGet(iRoomId,aRm) Then sRoomName=aRm(ZBC_COL_ROOM_NAME)
End If
if len(CHAT_SAVE_LOG_FILE)>0 Then
If instr(1,CHAT_SAVE_LOG_FILE,"%date%",1)>0 Then
sDate=replace(Date(),"/","_")
sDate=replace(sDate,"\","_")
sFilePath=replace(CHAT_SAVE_LOG_FILE,"%date%",sDate,1,-1,1)
Else
sFilePath=CHAT_SAVE_LOG_FILE
End If
Set fso = Server.CreateObject("Scripting.FileSystemObject")
on error resume next
Set oFile= fso.OpenTextFile(sFilePath,8,true,0)
if err.number<>0 Then
MessageLog=err.Description & " opening file " & sFilePath
Else
if CHAT_DETAILED_LOG Then
oFile.WriteLine now() & vbTab & sRoomName & vbTab & sUfrom & vbTab & sUTo & vbTab & sMessage
Else
oFile.WriteLine now() & vbTab & iRoomId & vbTab & iUsrFrom & vbTab & iUsrTo & vbTab & sMessage
End If
if err.number<>0 Then
MessageLog=err.Description & " writing to file " & sFilePath
End If
oFile.Close
End If
on error goto 0
Set oFile=Nothing
Set fso=Nothing
End if
if CHAT_SAVE_LOG_DB Then
if CHAT_DETAILED_LOG Then
sSql="insert into msg(iUserFrom,iUserTo,iRoomId,sMsg,sUserFrom,sUserTo,sRoomName) values(" &_
iUsrFrom & "," & iUsrTo & "," & iRoomId & ",'" & EscQ(sMessage) & "','" & EscQ(sUfrom) & "','" & EscQ(sUTo) & "','" & EscQ(sRoomName) & "')"
Else
sSql="insert into msg(iUserFrom,iUserTo,iRoomId,sMsg) values(" &_
iUsrFrom & "," & iUsrTo & "," & iRoomId & ",'" & EscQ(sMessage) & "')"
End if
Set oCon=Server.CreateObject("ADODB.Connection")
on error resume next
oCon.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & Server.MapPath("db1.mdb")
if err.number<>0 Then
MessageLog=err.Description & " connecting to DB " & CHAT_SAVE_LOG_DB
Else
oCon.Execute sSql
if err.number<>0 Then
MessageLog=err.Description & " writing to DB " & sSql
End If
oCon.Close()
End If
on error goto 0
End If
End Function
'adds new message "sMessage" in the room "iRoomId"
'returns True on success; returns False on failure
Function MessageAdd(iRoomId,iUsrFrom,iUsrTo,sMessage,sError)
Dim iCurrMsg,iUpdMsg,iMsgId,aRoom,aMsgs,aUsr
MessageAdd=false
If RoomGet(iRoomId,aRoom) Then
sError=MessageLog(iRoomId,iUsrFrom,iUsrTo,sMessage)
Application.Lock
aMsgs=Application(iRoomId & "Msg" & APP_VAR_FIX)
if vartype(aMsgs)=0 Then
redim aMsgs(3,MAX_MSG_LINES-1)
Application(iRoomId & "PtrMsg" & APP_VAR_FIX)=-1
End If
if isArray(aMsgs) Then
iCurrMsg=Application(iRoomId & "PtrMsg" & APP_VAR_FIX)
if iCurrMsg>=MAX_MSG_LINES-1 then iUpdMsg=0 Else iUpdMsg=iCurrMsg+1
if iUsrTo=-1 Then
iMsgId=CLng(1)+Application(iRoomId & "_MsgUpd" & APP_VAR_FIX)
aMsgs(ZBC_COL_MSG_ID,iUpdMsg)=iMsgId
aMsgs(ZBC_COL_MSG_TEXT,iUpdMsg)=sMessage
aMsgs(ZBC_COL_MSG_FROM_ID,iUpdMsg)=iUsrFrom
if iUsrFrom>=0 Then
if UserGet(iUsrFrom,aUsr) Then
aMsgs(ZBC_COL_MSG_FROM_ID,iUpdMsg)=aUsr(ZBC_COL_USER_GUID)
aMsgs(ZBC_COL_MSG_FROM_NAME,iUpdMsg)=aUsr(ZBC_COL_USER_NAME)
End If
End If
Application(iRoomId & "Msg" & APP_VAR_FIX)=aMsgs
Application(iRoomId & "PtrMsg" & APP_VAR_FIX)=iUpdMsg
Application(iRoomId & "_MsgUpd" & APP_VAR_FIX)=iMsgId
MessageAdd=true
Else
iMsgId=Application(iRoomId & "_MsgUpd" & APP_VAR_FIX)
If Not MessagePrivateAdd(iUsrFrom,iCurrMsg,iMsgId,sMessage,iUsrFrom,sError) Or Not MessagePrivateAdd(iUsrTo,iCurrMsg,iMsgId,sMessage,iUsrFrom,sError) Then Exit Function
if isEmpty(aMsgs(ZBC_COL_MSG_ID,iCurrMsg)) Then
aMsgs(ZBC_COL_MSG_ID,iCurrMsg)=iMsgId
Application(iRoomId & "Msg" & APP_VAR_FIX)=aMsgs
End If
MessageAdd=true
End If
Else
sError="MessageAdd - aMsgs is not of valid type"
End If
Application.UnLock
End if
End Function
'verifies and adds a user message (public or private) to the chat
'returns boolean indicating success of operation
Function MessageAddUsr(iUserId,sMessage,iUserToParam,sError,iError)
Dim aUsr,regEx,sOut,iRoomId,iUsrTo,sTmp,ipos,aBadWords,i
MessageAddUsr=false
if len(sMessage)<1 Then
iError=15
sError="MessageAddUsr - can't add an empty message"
Exit Function
End If
if len(ABUSIVE_WORDS_FILTER)>0 Then
aBadWords=split(ABUSIVE_WORDS_FILTER,";")
for i=0 to ubound(aBadWords)
if Instr(1,sMessage,aBadWords(i),1)>0 Then
iError=12
sError="Message contains abusive words and will not be sent."
Exit Function
End If
Next
End if
If Not UserGet(iUserId,aUsr) Then
iError=1
sError="user " & iUserId & " session expired"
Exit Function
End If
If MIN_SEND_MSG_INTERVAL>0 Then
If Not IsEmpty(aUsr(ZBC_COL_USER_LMSG_TIME)) Then
if datediff("s",aUsr(ZBC_COL_USER_LMSG_TIME),now())<MIN_SEND_MSG_INTERVAL Then
iError=13
sError="Current settings do not allow you to send messages faster than every " & MIN_SEND_MSG_INTERVAL & " second(s)."
Exit Function
End If
End If
End If
iUsrTo=-1
if len(iUserToParam)>0 Then
if isNumeric(iUserToParam) Then
iUsrTo=Clng(iUserToParam)
End If
End If
' we do not support most tags, however <b>, <i> and <u> ARE supported,
' thus we have to make check for these and replace with actual tags
sOut=Replace(sMessage,"<","<")
sOut=Replace(sOut,">",">")
sOut = Replace(sOut, "<b>", "<b>", 1, -1, 1)
sOut = Replace(sOut, "</b>", "</b>", 1, -1, 1)
sOut = Replace(sOut, "<i>", "<i>", 1, -1, 1)
sOut = Replace(sOut, "</i>", "</i>", 1, -1, 1)
sOut = Replace(sOut, "<u>", "<u>", 1, -1, 1)
sOut = Replace(sOut, "</u>", "</u>", 1, -1, 1)
Set regEx = New RegExp
regEx.Global=true
regEx.Pattern="\<font color\=""(\#[0-9A-Fa-f]{6})""\>((.|\n)*)\<\/font\>"
sOut=regEx.Replace(sOut,"<font color=""$1"">$2</font>")
set regEx=Nothing
'sOut=chr(2) & aUsr(ZBC_COL_USER_NAME) & chr(3) & sOut
iRoomId=aUsr(ZBC_COL_USER_ROOM)
MessageAddUsr=MessageAdd(iRoomId,iUserId,iUsrTo,sOut,sError)
if MessageAddUsr Then
If UserGet(iUserId,aUsr) Then
aUsr(ZBC_COL_USER_LMSG_TIME)=Now()
call UserSet(iUserId,aUsr)
End If
Else
iError=11
End If
End function
'removes all messages in a given room
'returns boolean indicating success of operation
Function MessagesRemove(iRoomId,bAdminRequest)
Dim sError
MessagesRemove=false
Application.Lock
'Application.Contents.Remove(iRoomId & "Msg" & APP_VAR_FIX)
'Application.Contents.Remove(iRoomId & "PtrMsg" & APP_VAR_FIX)
Application(iRoomId & "Msg" & APP_VAR_FIX)=Empty
Application(iRoomId & "PtrMsg" & APP_VAR_FIX)=Empty
If bAdminRequest Then
call MessageAdd(iRoomId,-1,-1,chr(8) & "All messages has been cleared by administrator",sError)
End if
Application.UnLock
MessagesRemove=true
End Function
'if CLEAR_ON_EMPTY is set to true cleans out all the messages after
'last user logges out of the chat
Function MessageMaintanace(bAdminRequest)
Dim iRoomId
'If CLEAR_ON_EMPTY Or bAdminRequest Then
If (CLEAR_ON_EMPTY AND UsersCountGet()=0) OR bAdminRequest Then
' clear all messages in all rooms
For iRoomId = 0 TO MAX_ROOMS-1
call MessagesRemove(iRoomId,bAdminRequest)
Next
MessageMaintanace="success"
End If
End function
'returns the id of the last update in the list of messages in the room "iRoomId"
Function RoomMessagesLastId(iRoomId)
RoomMessagesLastId=Application(iRoomId & "_MsgUpd" & APP_VAR_FIX)
End function
Function EscQ(sField)
EscQ=Replace(sField,"'","''")
End Function
</script>
Our inc_header.txt file can be found here Link Lines 693 onwards |
| Webbo |
Posted - 29 March 2011 : 02:38:57
quote:
Originally posted by Carefree
Post a link to the file in .txt format and provide the exact error message you're getting.
I'll do that tonight as I don't have access to the files today
Will try that Doug |
| Doug G |
Posted - 28 March 2011 : 15:41:30
include file should work if you give a full absolute disk path to the file and the webserver user has adequate file permissions. Your code snip example is using a relative file path.
|
| Carefree |
Posted - 28 March 2011 : 04:56:23
Post a link to the file in .txt format and provide the exact error message you're getting. |
| Webbo |
Posted - 28 March 2011 : 02:45:37
I've tried that and get a syntax error message
|
| Carefree |
Posted - 28 March 2011 : 00:46:42
That function is so small, why not simply append it to the bottom of the page you want it displayed in? |
| Webbo |
Posted - 27 March 2011 : 16:07:40
Not that I can see, below is a copy of the function..
That file has an include for another file within the same directory/application pool, would that make a difference? |
| AnonJr |
Posted - 27 March 2011 : 14:06:25
Does the function rely on a component/variable/something that isn't also being included/primed/etc.? |
|
|
