Including a function from another file

The Forum has been Updated

The code has been upgraded to the latest .NET core version. Please check instructions in the Community Announcements about migrating your account.

Including a function from another file - نوشته شده در 27 Mar 2011 (1393 Views)

Webbo

Average Member

مطلب: 982

982

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

Code:

          '##CHAT ROOM ###################
%>
<!-- #INCLUDE FILE="chat/chatapi.asp" -->
<%
          Response.Write "              " & vbNewline & _
                         "        <a href=""/forum/chat/default.asp""" & dWStatus("Chat with others live...") & " tabindex=""-1""><acronym title=""Chat with other users..."">Chat Room</acronym> (" & UsersCountGet() & ")</a>" & vbNewline & _
         "         | " & vbNewline

I have also tried: 
which didn't work either

The function I am trying to use is: " & UsersCountGet() & " which is within the chatapi.asp file

Many thanks,

Dave

نوشته شده در 27 Mar 2011

AnonJr

Forum Moderator

مطلب: 5768

5768

Does the function rely on a component/variable/something that isn't also being included/primed/etc.?

نوشته شده در 27 Mar 2011

Webbo

Average Member

مطلب: 982

982

Not that I can see, below is a copy of the function..

Code:

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

That file has an include for another file within the same directory/application pool, would that make a difference?

نوشته شده در 28 Mar 2011

Carefree

Advanced Member

مطلب: 4224

4224

That function is so small, why not simply append it to the bottom of the page you want it displayed in?

نوشته شده در 28 Mar 2011

Webbo

Average Member

مطلب: 982

982

I've tried that and get a syntax error message

نوشته شده در 28 Mar 2011

Carefree

Advanced Member

مطلب: 4224

4224

Post a link to the file in .txt format and provide the exact error message you're getting.

نوشته شده در 29 Mar 2011

Webbo

Average Member

مطلب: 982

982

Hi Carefree,

The chatapi file doesn't want to display in txt format in a browser so I've pasted it below:

Code:

<!-- #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

نوشته شده در 29 Mar 2011

Carefree

Advanced Member

مطلب: 4224

4224

~~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"

Code:


<%
'###############################################################################
'##
'##			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>

آخرین ویرایش توسط