functions_common.asp

简单的asp论坛源码系统,很适用于初学者!界面简洁,功能齐全

	'Get the number of new pm's this user has
	intRecievedPMs = CInt(rsCommon("CountOfPM"))

	'Update the number of unread PM's the user has
	intNoOfPms = CInt(rsCommon("CountOfPM"))

	'Close the recordset
	rsCommon.Close



	'Update database
	strSQL = "UPDATE " & strDbTable & "Author " & strRowLock & " " & _
	"SET " & strDbTable & "Author.No_of_PM = " & intRecievedPMs & " " & _
	"WHERE " & strDbTable & "Author.Author_ID=" & lngMemID & ";"

	'Write the updated no. of PM's to the database
	adoCon.Execute(strSQL)

End Function





'******************************************
'***  	   Unsafe character Strip      ****
'******************************************

'Function to strip non alphanumeric characters email addresses
Private Function characterStrip(ByVal strTextInput)

	'Dimension variable
	Dim intLoopCounter 	'Holds the loop counter

	'Loop through the ASCII characters
	For intLoopCounter = 0 to 31
		strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0)
	Next

	'Loop through the ASCII characters
	For intLoopCounter = 33 to 37
		strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0)
	Next

	'Loop through the ASCII characters
	For intLoopCounter = 39 to 44
		strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0)
	Next

	'Loop through the ASCII characters
	For intLoopCounter = 58 to 65
		strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0)
	Next

	'Loop through the ASCII characters numeric characters
	For intLoopCounter = 91 to 94
		strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0)
	Next

	'Loop through the extended ASCII characters
	For intLoopCounter = 123 to 125
		strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0)
	Next

	'Loop through the extended ASCII characters
	For intLoopCounter = 127 to 255
		strTextInput = Replace(strTextInput, CHR(intLoopCounter), "", 1, -1, 0)
	Next

	'Strip individul ASCII characters left out from above
	strTextInput = Replace(strTextInput, CHR(59), "", 1, -1, 0)
	strTextInput = Replace(strTextInput, CHR(60), "", 1, -1, 0)
	strTextInput = Replace(strTextInput, CHR(62), "", 1, -1, 0)
	strTextInput = Replace(strTextInput, CHR(96), "", 1, -1, 0)


	'Return the string
	characterStrip = strTextInput

End Function




'**********************************************
'***  Format ISO International Date/Time   ****
'**********************************************

'Function to format the present date and time into international formats to prevent systems crashes on foriegn servers
Private Function internationalDateTime(dtmDate)

	Dim strYear
	Dim strMonth
	Dim strDay
	Dim strHour
	Dim strMinute
	Dim strSecound

	strYear = Year(dtmDate)
	strMonth = Month(dtmDate)
	strDay = Day(dtmDate)
	strHour = Hour(dtmDate)
	strMinute = Minute(dtmDate)
	strSecound = Second(dtmDate)

	'Place 0 infront of minutes under 10
	If strMonth < 10 then strMonth = "0" & strMonth
	If strDay < 10 then strDay = "0" & strDay
	If strHour < 10 then strHour = "0" & strHour
	If strMinute < 10 then strMinute = "0" & strMinute
	If strSecound < 10 then strSecound = "0" & strSecound

	'This function returns the ISO internation date and time formats:- yyyy-mm-dd hh:mm:ss
	'Dashes prevent systems that use periods etc. from crashing
	internationalDateTime = strYear & "-" & strMonth & "-" & strDay & " " & strHour & ":" & strMinute& ":" & strSecound
End Function







'*******************************************
'***  		Error Message   	****
'*******************************************

'Function to to dsiplay server error message
Private Function errorMsg(strErrorText, strErrCode, strFileName)
	

	Response.Write("<br /><strong>Server Error in Forum Application</strong>" & _
	"<br />" & strErrorText & _
	"<br />Please contact the forum administrator." & _
	"<br /><br /><strong>Support Error Code:-</strong> err_" & strDatabaseType & "_" & strErrCode & _
	"<br /><strong>File Name:-</strong> " & strFileName)
	
	'If detailed error messaging is enabled, display an error message
	If blnDetailedErrorReporting Then
		Response.Write("<br /><br /><strong>Error details:-</strong>" & _
		"<br />" & Err.Source & _
		"<br />" & Err.Description & "<br /><br />")
	End If
	
	'End Server Response
	Response.Flush
	Response.End

End Function









'******************************************
'***  	     Active Users Array        ****
'******************************************

'Function to populate and update the active users application array
Private Function activeUsers(ByVal strPageName, ByVal strLocation, ByVal strURL, ByVal intFID)


	'Array dimension lookup table
	' 0 = IP
	' 1 = Author ID
	' 2 = Username
	' 3 = Login Time
	' 4 = Last Active Time
	' 5 = OS/Browser
	' 6 = Location
	' 7 = URL
	' 8 = Hides user details (Anonymous)
	' 9 = Forum ID


	'Dimension variables
	Dim strIPAddress 		'Holds the uesrs IP address to keep track of em with
	Dim strOS			'Holds the users OS
	Dim strBrowserUserType		'Holds the users browser type
	Dim blnHideActiveUser 		'Holds if the user wants to be shown in the active users list
	Dim saryActiveUsers		'Holds the active users array
	Dim intArrayPass		'Holds array iteration possition
	Dim blnIPFound			'Set to true if the users IP is found
	Dim intActiveUserArrayPos	'Holds the possition in the array the user is found
	Dim intActiveUsersDblArrayPos	'Holds the array position if the user is found more than once in the array
	Dim strLocationURL		'Holds the built up location URL
	Dim intRemovedEntries		'Holds the number array entries to remove


	'******************************************
	'***   	Initialise  variables		***
	'******************************************

	'Initialise  variables
	blnIPFound = False
	intRemovedEntries = 0

	'Get the users IP address
	strIPAddress = getIP()


	'Build the location URL
	If strLocation <> "" AND strURL <> "" Then
		strLocationURL = "<a href=""" & strURL & """>" & strLocation & "</a>"
	End If

	'Get if the user wants to be shown in the active users list
	If getCookie("sLID", "NS") = "1" OR getSessionItem("NS") = "1" Then
		blnHideActiveUser = 1
	Else
		blnHideActiveUser = 0
	End If


	'******************************************
	'***   	Initialise  array		***
	'******************************************

	'Initialise  the array from the application veriable
	If isArray(Application(strAppPrefix & "saryAppActiveUsersTable")) Then

		'Place the application level active users array into a temporary dynaimic array
		saryActiveUsers = Application(strAppPrefix & "saryAppActiveUsersTable")

	'Else Initialise the an empty array
	Else
		ReDim saryActiveUsers(9,0)
	End If

	'Array dimension lookup table
	' 0 = IP
	' 1 = Author ID
	' 2 = Username
	' 3 = Login Time
	' 4 = Last Active Time
	' 5 = OS/Browser
	' 6 = Location Page Name
	' 7 = URL
	' 8 = Hids user details
	' 9 = Forum ID


	'******************************************
	'***   	Get users array position	***
	'******************************************

	'Iterate through the array to see if the user is already in the array
	For intArrayPass = 1 To UBound(saryActiveUsers, 2)

		'Check the IP address
		If saryActiveUsers(0, intArrayPass) = strIPAddress Then

			intActiveUserArrayPos = intArrayPass
			blnIPFound = True

		'Else check a logged in member is not a double entry
		ElseIf saryActiveUsers(1, intArrayPass) = lngLoggedInUserID AND saryActiveUsers(1, intArrayPass) <> 2 Then

			intActiveUsersDblArrayPos = intArrayPass
		End If
	Next


	'******************************************
	'***   	Update users array position	***
	'******************************************

	'If the user is found in the array update the array position
	If blnIPFound Then

		saryActiveUsers(1, intActiveUserArrayPos) = lngLoggedInUserID
		saryActiveUsers(2, intActiveUserArrayPos) = strLoggedInUsername
		saryActiveUsers(4, intActiveUserArrayPos) = internationalDateTime(Now())
		saryActiveUsers(6, intActiveUserArrayPos) = strPageName
		saryActiveUsers(7, intActiveUserArrayPos) = strLocationURL
		saryActiveUsers(8, intActiveUserArrayPos) = blnHideActiveUser
		saryActiveUsers(9, intActiveUserArrayPos) = intFID


	'******************************************
	'***   	Add new user to array		***
	'******************************************

	'Else the user is not in the array so create a new array psition
	Else
		'Get the uesrs web browser
		strBrowserUserType = BrowserType()

		'Get the OS type
		strOS = OSType()


		'ReDimesion the array
		ReDim Preserve saryActiveUsers(9, UBound(saryActiveUsers, 2) + 1)

		'Update the new array position which will be the last one
		saryActiveUsers(0, UBound(saryActiveUsers, 2)) = strIPAddress
		saryActiveUsers(1, UBound(saryActiveUsers, 2)) = lngLoggedInUserID
		saryActiveUsers(2, UBound(saryActiveUsers, 2)) = strLoggedInUsername
		saryActiveUsers(3, UBound(saryActiveUsers, 2)) = internationalDateTime(Now())
		saryActiveUsers(4, UBound(saryActiveUsers, 2)) = internationalDateTime(Now())
		saryActiveUsers(5, UBound(saryActiveUsers, 2)) = strOS & " " & strBrowserUserType
		saryActiveUsers(6, UBound(saryActiveUsers, 2)) = strPageName
		saryActiveUsers(7, UBound(saryActiveUsers, 2)) = strLocationURL
		saryActiveUsers(8, UBound(saryActiveUsers, 2)) = blnHideActiveUser
		saryActiveUsers(9, UBound(saryActiveUsers, 2)) = intFID
	End If


	'******************************************
	'***   	Remove unactive users		***
	'******************************************

	'Iterate through the array to remove old entires and double entries
	For intArrayPass = 1 To UBound(saryActiveUsers, 2)

		'Check the IP address and last active time less than 20 minutes
		If CDate(saryActiveUsers(4, intArrayPass)) < DateAdd("n", -20, Now()) OR intActiveUsersDblArrayPos = intArrayPass Then

			'Swap this array postion with the last in the array
			saryActiveUsers(0, intArrayPass) = saryActiveUsers(0, UBound(saryActiveUsers, 2) - intRemovedEntries)
			saryActiveUsers(1, intArrayPass) = saryActiveUsers(1, UBound(saryActiveUsers, 2) - intRemovedEntries)
			saryActiveUsers(2, intArrayPass) = saryActiveUsers(2, UBound(saryActiveUsers, 2) - intRemovedEntries)
			saryActiveUsers(3, intArrayPass) = saryActiveUsers(3, UBound(saryActiveUsers, 2) - intRemovedEntries)
			saryActiveUsers(4, intArrayPass) = saryActiveUsers(4, UBound(saryActiveUsers, 2) - intRemovedEntries)
			saryActiveUsers(5, intArrayPass) = saryActiveUsers(5, UBound(saryActiveUsers, 2) - intRemovedEntries)
			saryActiveUsers(6, intArrayPass) = saryActiveUsers(6, UBound(saryActiveUsers, 2) - intRemovedEntries)
			saryActiveUsers(7, intArrayPass) = saryActiveUsers(7, UBound(saryActiveUsers, 2) - intRemovedEntries)
			saryActiveUsers(8, intArrayPass) = saryActiveUsers(8, UBound(saryActiveUsers, 2) - intRemovedEntries)
			saryActiveUsers(9, intArrayPass) = saryActiveUsers(9, UBound(saryActiveUsers, 2) - intRemovedEntries)

			'Increament the number of removed entries
			intRemovedEntries = intRemovedEntries + 1
		End If
	Next

	'Remove old array positions
	If intRemovedEntries > 0 Then ReDim Preserve saryActiveUsers(9, UBound(saryActiveUsers, 2) - intRemovedEntries)



	'******************************************
	'***   Update application level array	***
	'******************************************

	'Update the application level variable holding the active users array

	'Lock the application so that no other user can try and update the application level variable at the same time
	Application.Lock

	'Update the application level variable
	Application(strAppPrefix & "saryAppActiveUsersTable") = saryActiveUsers

	'Unlock the application
	Application.UnLock



	'Return function
	activeUsers = saryActiveUsers
End Function







'******************************************
'***	Sort Active Users List		***
'******************************************

'Sub procedure to sort the array using a Bubble Sort to place highest matches first
Private Sub SortActiveUsersList(ByRef saryActiveUsers)

	'Dimension variables
	Dim intArrayGap 		'Holds the part of the array being sorted
	Dim intIndexPosition		'Holds the Array index position being sorted
	Dim intPassNumber		'Holds the pass number for the sort
	Dim saryTempStringStore(9)	'Array to temparily store the position being sorted

	'Loop round to sort each result found
	For intPassNumber = 1 To UBound(saryActiveUsers, 2)

		'Shortens the number of passes
		For intIndexPosition = 1 To (UBound(saryActiveUsers, 2) - intPassNumber)

			'If the Result being sorted is a less time than the next result in the array then swap them
			If saryActiveUsers(4,intIndexPosition) < saryActiveUsers(4,(intIndexPosition+1)) Then


				'Place the Result being sorted in a temporary array variable
				saryTempStringStore(0) = saryActiveUsers(0, intIndexPosition)
				saryTempStringStore(1) = saryActiveUsers(1, intIndexPosition)
				saryTempStringStore(2) = saryActiveUsers(2, intIndexPosition)
				saryTempStringStore(3) = saryActiveUsers(3, intIndexPosition)
				saryTempStringStore(4) = saryActiveUsers(4, intIndexPosition)
				saryTempStringStore(5) = saryActiveUsers(5, intIndexPosition)
				saryTempStringStore(6) = saryActiveUsers(6, intIndexPosition)
				saryTempStringStore(7) = saryActiveUsers(7, intIndexPosition)