functions_common.asp

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

				saryTempStringStore(8) = saryActiveUsers(8, intIndexPosition)
				saryTempStringStore(9) = saryActiveUsers(9, intIndexPosition)


				'*** Do the array position swap ***

				'Move the next Result with a higher match rate into the present array location
				saryActiveUsers(0, intIndexPosition) = saryActiveUsers(0, (intIndexPosition+1))
				saryActiveUsers(1, intIndexPosition) = saryActiveUsers(1, (intIndexPosition+1))
				saryActiveUsers(2, intIndexPosition) = saryActiveUsers(2, (intIndexPosition+1))
				saryActiveUsers(3, intIndexPosition) = saryActiveUsers(3, (intIndexPosition+1))
				saryActiveUsers(4, intIndexPosition) = saryActiveUsers(4, (intIndexPosition+1))
				saryActiveUsers(5, intIndexPosition) = saryActiveUsers(5, (intIndexPosition+1))
				saryActiveUsers(6, intIndexPosition) = saryActiveUsers(6, (intIndexPosition+1))
				saryActiveUsers(7, intIndexPosition) = saryActiveUsers(7, (intIndexPosition+1))
				saryActiveUsers(8, intIndexPosition) = saryActiveUsers(8, (intIndexPosition+1))
				saryActiveUsers(9, intIndexPosition) = saryActiveUsers(9, (intIndexPosition+1))

				'Move the Result from the teporary holding variable into the next array position
				saryActiveUsers(0, (intIndexPosition+1)) = saryTempStringStore(0)
				saryActiveUsers(1, (intIndexPosition+1)) = saryTempStringStore(1)
				saryActiveUsers(2, (intIndexPosition+1)) = saryTempStringStore(2)
				saryActiveUsers(3, (intIndexPosition+1)) = saryTempStringStore(3)
				saryActiveUsers(4, (intIndexPosition+1)) = saryTempStringStore(4)
				saryActiveUsers(5, (intIndexPosition+1)) = saryTempStringStore(5)
				saryActiveUsers(6, (intIndexPosition+1)) = saryTempStringStore(6)
				saryActiveUsers(7, (intIndexPosition+1)) = saryTempStringStore(7)
				saryActiveUsers(8, (intIndexPosition+1)) = saryTempStringStore(8)
				saryActiveUsers(9, (intIndexPosition+1)) = saryTempStringStore(9)
			End If
		Next
	Next
End Sub







'******************************************
'***	No. Active Users Viewing Forum	***
'******************************************

'function to get the number of users viewing a forum
Private Function viewingForum(ByVal intForumID)

	'Dimension variables
	Dim intIndexPosition	'Loop position
	Dim intViewing		'No. viewing	
	
	'Intiliase variables
	intViewing = 0

	'Check to make sure that we are dealing with an array before using UBound to prevent errors
	If isArray(saryActiveUsers) Then
		'Loop round to sort each result found
		For intIndexPosition = 1 To UBound(saryActiveUsers, 2)
			
			'If Forum ID'match increment by 1
			If saryActiveUsers(9, intIndexPosition) = intForumID Then intViewing = intViewing + 1
		Next
	End If

	'Return the numnber of users viewing forum
	viewingForum = intViewing
End Function







'******************************************
'***  	Function to trim strings	***
'******************************************

'Function to chop down the length of a string and add '...'
Private Function TrimString(strInputString, intStringLength)

	Dim intTrimLentgh

	'Trim the string down
	strInputString = Trim(strInputString) & " "

	'If the length of the text is longer than the max then cut it and place '...' at the end
	If CLng(Len(strInputString)) > intStringLength Then
		
		'Get the part in the string to trim it from
		intTrimLentgh = InStr(intStringLength, strInputString, " ", vbTextCompare)
		
		'If intTrimLentgh = 0 then set it to the default passed to the function (Error handling, should never be used)
		If intTrimLentgh = 0 Then intTrimLentgh = intStringLength
		
		'Trim the number of characters down to the required amount, but try not to chop words in half
		strInputString = Mid(strInputString, 1, intTrimLentgh)

		'Make sure the user hasn't entered a long line of text with no break (most words won't be over 30 chars
		If CLng(Len(strInputString)) => intStringLength + 30 Then
			strInputString = Mid(Trim(strInputString), 1, intStringLength)
		End If

		'Place '...' at the end
		 strInputString = Trim(strInputString) & "..."
	End If

	'Return string
	TrimString = strInputString
End Function







'******************************************
'***  	Function to get unread posts	***
'******************************************

'Function to get any unread posts for the unread post notification
Private Function UnreadPosts()

	'Array positions
	'0 = Thread_ID
	'1 = Topic_ID
	'2 = Forum_ID
	'3 = Read 1/0
	
	Dim dtmUnReadPostLastVisitDate
	Dim sarryTmp2UnReadPosts	'Array holding the orrgial session array
	Dim sarryTmp1UnReadPosts 	'Temporary store for unread posts array
	Dim intUnReadPostArrayPass1	'Loop
	Dim intUnReadPostArrayPass2	'Loop
	
	
	'Initliae variables
	dtmUnReadPostLastVisitDate = dtmLastVisitDate
	
	

	'See if the unread posts array exists at application level
	If isArray(Application("sarryUnReadPosts" & strSessionID)) Then  
		sarryTmp2UnReadPosts = Application("sarryUnReadPosts" & strSessionID)
	'See if a session array already esists for this user, if so read it in
	ElseIf isArray(Session("sarryUnReadPosts")) Then 
		sarryTmp2UnReadPosts = Session("sarryUnReadPosts")
	End If
	
	
	
		
	'Read in and clean up the last visit date, need to make it compatble with different database systems and locals
	dtmUnReadPostLastVisitDate = internationalDateTime(dtmUnReadPostLastVisitDate)
	
	'If SQL server remove dash (-) from the ISO international date to make SQL Server safe
	If strDatabaseType = "SQLServer" Then dtmUnReadPostLastVisitDate = Replace(dtmUnReadPostLastVisitDate, "-", "", 1, -1, 1)
	
	'If Access use # around date
	If strDatabaseType = "Access" Then
		dtmUnReadPostLastVisitDate = "#" & dtmUnReadPostLastVisitDate & "#"
	
	'SQL server and mySQL place ' around date
	Else
		dtmUnReadPostLastVisitDate = "'" & dtmUnReadPostLastVisitDate & "'"
	End If
	

	'Intilise SQL to get unread posts from database 
	'(limit set to 200 unread posts as anymore would effect performance and how many people will want to know about 200+ unread posts? although someone will still complain)
	'1 As Unread is added to the select statement to make a dummy field in the recordset which can be used for storing if the post is read
	strSQL = "" & _
	"SELECT "
	If strDatabaseType = "SQLServer" OR strDatabaseType = "Access" Then
		strSQL = strSQL & " TOP 200 "
	End If
	strSQL = strSQL & _
	strDbTable & "Thread.Thread_ID, " & strDbTable & "Topic.Topic_ID, " & strDbTable & "Topic.Forum_ID, 1 As Unread " & _
	"FROM " & strDbTable & "Topic" & strDBNoLock & ", " & strDbTable & "Thread" & strDBNoLock & " " &_
	"WHERE " & strDbTable & "Topic.Topic_ID=" & strDbTable & "Thread.Topic_ID " & _
		"AND " & strDbTable & "Thread.Message_date > " & dtmUnReadPostLastVisitDate & " "
		'Only get hidden posts if this is the admin or moderator
		If blnModerator = false AND blnAdmin = false Then
			strSQL = strSQL & _
			"AND " & strDbTable & "Topic.Hide = " & strDBFalse & " " & _
			"AND " & strDbTable & "Thread.Hide = " & strDBFalse & " "
		End If
	strSQL = strSQL & _
	"ORDER BY " & strDbTable & "Thread.Thread_ID ASC"
	
	'mySQL limit operator
	If strDatabaseType = "mySQL" Then
		strSQL = strSQL & " LIMIT 200"
	End If
	strSQL = strSQL & ";"
	
	
	'Set error trapping
	On Error Resume Next
	
	'Query the database
	rsCommon.Open strSQL, adoCon
	
	'If an error has occurred write an error to the page
	If Err.Number <> 0 Then	Call errorMsg("An error has occurred while executing SQL query on database.", "UnreadPosts()", "functions_common.asp")
	
	'Disable error trapping
	On Error goto 0
	
	'If there are records returned add them to the end of the array
	If NOT rsCommon.EOF Then

		'Array positions
		'0 = Thread_ID
		'1 = Topic_ID
		'2 = Forum_ID
		'3 = UnRead 1/0

		'Read in the recordset into the array
		sarryTmp1UnReadPosts = rsCommon.GetRows()
				
		
		'Loop through the original array (if exists) and mark any posts down as being read which have been read
		If isArray(sarryTmp2UnReadPosts) Then
			
			'Loop through new array
			For intUnReadPostArrayPass1 = 0 to UBound(sarryTmp1UnReadPosts,2)
			
				'Loop through original array looking for match
				For intUnReadPostArrayPass2 = 0 to UBound(sarryTmp2UnReadPosts,2)
				
					'If match found 
					If CLng(sarryTmp1UnReadPosts(0,intUnReadPostArrayPass1)) = CLng(sarryTmp2UnReadPosts(0,intUnReadPostArrayPass2)) Then

						'If marked as read, also mark as read in new array
						If sarryTmp2UnReadPosts(3,intUnReadPostArrayPass2) = "0" Then sarryTmp1UnReadPosts(3,intUnReadPostArrayPass1) = "0"
					
						'Exit Loop
						Exit For
					End If
				Next
			Next				
		End If				

		
		
		'Place the array into the web servers application memory pool if the user has a session ID
		If strSessionID <> "" Then
			Application.Lock
			Application("sarryUnReadPosts" & strSessionID) = sarryTmp1UnReadPosts
			Application("sarryUnReadPosts2" & strSessionID) = strSessionID
			Application.UnLock
		'Else the user doesn't have a session ID so use the session instead
		Else
			Session("sarryUnReadPosts") = sarryTmp1UnReadPosts
		End If
	End If
	
	'Close RS
	rsCommon.Close
	
	'Set a variable with the time and date now, so we know when this was last checked
	Session("dtmUnReadPostCheck") = internationalDateTime(Now())
	
	
	'Read in the unread posts array	
	'Read in array if at application level
	If isArray(Application("sarryUnReadPosts" & strSessionID)) Then  
		sarryUnReadPosts = Application("sarryUnReadPosts" & strSessionID)
	'Read in if at sesison level
	ElseIf isArray(Session("sarryUnReadPosts")) Then 
		sarryUnReadPosts = Session("sarryUnReadPosts")
	
	End If
End Function






'******************************************
'***  	Cookie Management	 	***
'******************************************

'Functions and subs for handling cookies

'Set Cookie
Sub setCookie(strCookieName, strCookieKey, strValue, blnStore)
    	'Write Cookie
	Response.Cookies(strCookiePrefix & strCookieName)(strCookieKey) = strValue
	Response.Cookies(strCookiePrefix & strCookieName).Path = strCookiePath
	If blnStore Then
		Response.Cookies(strCookiePrefix & strCookieName).Expires = DateAdd("yyyy", 1, Now())
	End If
End Sub


'Get Cookie
Function getCookie(strCookieName, strCookieKey)  
	'Read in the cookie
	getCookie = Request.Cookies(strCookiePrefix & strCookieName)(strCookieKey)
End Function


'Clear Cookie
Sub clearCookie()  
	'Clear the cookie
	Response.Cookies(strCookiePrefix & "sID") = ""
	Response.Cookies(strCookiePrefix & "sID").Path = strCookiePath
	Response.Cookies(strCookiePrefix & "sLID") = ""
	Response.Cookies(strCookiePrefix & "sLID").Path = strCookiePath
	Response.Cookies(strCookiePrefix & "lVisit") = ""
	Response.Cookies(strCookiePrefix & "lVisit").Path = strCookiePath
	Response.Cookies(strCookiePrefix & "fID") = ""
	Response.Cookies(strCookiePrefix & "fID").Path = strCookiePath
	'This one stops user voting in polls so doesn't really want to be cleared
	'Response.Cookies(strCookiePrefix & "pID") = ""
	'Response.Cookies(strCookiePrefix & "pID").Path = strCookiePath
	
End Sub





'******************************************
'***  	Convertion Functions	 	***
'******************************************

'CInt Handling Integers to 32,768
Private Function IntC(strExpression) 

	'Set error trapping
	On Error Resume Next
	
	'Converts the string data to an Integer Number
	IntC = CInt(strExpression)
	
	'If an error has occurred write an error to the page
	If Err.Number <> 0 Then	Call errorMsg("Number handling error; The data being converted is not within range; -32,768 to 32,768.", "IntC()", "functions_common.asp")
	
	'Disable error trapping
	On Error goto 0

End Function


'CLng Handling Integers to 2,147,483,648
Private Function LngC(strExpression) 

	'Set error trapping
	On Error Resume Next
	
	'Converts the string data to an Integer Number
	LngC = CLng(strExpression)
	
	'If an error has occurred write an error to the page
	If Err.Number <> 0 Then	Call errorMsg("Number handling error; The data being converted is not within range; -2,147,483,648 to 2,147,483,648.", "LngC()", "functions_common.asp")
	
	'Disable error trapping
	On Error goto 0

End Function


'CDbl Handling Floating Point Numbers
Private Function DblC(strExpression) 

	'Set error trapping
	On Error Resume Next
	
	'Converts the string data to an Integer Number
	DblC = CDbl(strExpression)
	
	'If an error has occurred write an error to the page
	If Err.Number <> 0 Then	Call errorMsg("Number handling error; The data being converted is not a valid Floating Point Number.", "DblC()", "functions_common.asp")
	
	'Disable error trapping
	On Error goto 0

End Function


'CBool Handling True and False
Private Function BoolC(strExpression) 

	'Set error trapping
	On Error Resume Next
	
	'Converts the string data to an Integer Number
	BoolC = CBool(strExpression)
	
	'If an error has occurred write an error to the page
	If Err.Number <> 0 Then	Call errorMsg("Expression handling error; The data being converted is not a valid Boolean Subtype.", "BoolC()", "functions_common.asp")
	
	'Disable error trapping
	On Error goto 0

End F