functions_format_post.asp

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

		intFlashHeight = 50
		strFlashLink = ""
		strBuildFlashLink = ""
		strTempFlashMsg = ""

		'Get the Flash BBcode from the message
		lngStartPos = InStr(1, strMessage, "[FLASH", 1)
		lngEndPos = InStr(lngStartPos, strMessage, "[/FLASH]", 1) + 8

		'Make sure the end position is not in error
		If lngEndPos < lngStartPos Then lngEndPos = lngStartPos + 6

		'Get the original Flash BBcode from the message
		strTempFlashMsg = Trim(Mid(strMessage, lngStartPos, lngEndPos-lngStartPos))




		'Get the start and end in the message of the attributes of the Flash file
		lngStartPos = InStr(1, strTempFlashMsg, "[FLASH", 1) + 6
		lngEndPos = InStr(lngStartPos, strTempFlashMsg, "]", 1)

		'Make sure the end position is not in error
		If lngEndPos < lngStartPos Then lngEndPos = lngStartPos

		'If there is something returned get the details (eg. dimensions) of the flash file
		If strTempFlashMsg <> "" Then

			'Place any attributes for the flash file in an array
			saryFlashAttributes = Split(Trim(Mid(strTempFlashMsg, lngStartPos, lngEndPos-lngStartPos)), " ")

			'Get the dimensions of the Flash file
			'Loop through the array of atrributes that are for the falsh file to get the dimentions
			For intAttrbuteLoop = 0 To UBound(saryFlashAttributes)

				'If this is the width attribute then read in the width dimention
				If InStr(1, saryFlashAttributes(intAttrbuteLoop), "WIDTH=", 1) Then

					'Get the width dimention
					strFlashWidth = Replace(saryFlashAttributes(intAttrbuteLoop), "WIDTH=", "", 1, -1, 1)

					'Make sure we are left with a numeric number if so convert to an interger and place in an interger variable
					If isNumeric(strFlashWidth) Then intFlashWidth = CInt(strFlashWidth)
				End If

				'If this is the height attribute then read in the height dimention
				If InStr(1, saryFlashAttributes(intAttrbuteLoop), "HEIGHT=", 1) Then

					'Get the height dimention
					strFlashHeight = Replace(saryFlashAttributes(intAttrbuteLoop), "HEIGHT=", "", 1, -1, 1)

					'Make sure we are left with a numeric number if so convert to an interger and place in an interger variable
					If isNumeric(strFlashHeight) Then intFlashHeight = CInt(strFlashHeight)
				End If
			Next



			'Get the link to the flash file
			lngStartPos = InStr(1, strTempFlashMsg, "]", 1) + 1
			lngEndPos = InStr(lngStartPos, strTempFlashMsg, "[/FLASH]", 1)

			'Make sure the end position is not in error
			If lngEndPos < lngStartPos Then lngEndPos = lngStartPos + 8

			'Read in the code to be converted into a hyperlink from the message
			strFlashLink = Trim(Mid(strTempFlashMsg, lngStartPos, (lngEndPos - lngStartPos)))


			'Build the HTML for the displying of the flash file
			If strFlashLink <> "" Then
				strBuildFlashLink = "<embed src=""" & strFlashLink & """"
				strBuildFlashLink = strBuildFlashLink & " quality=high width=" & intFlashWidth & " height=" & intFlashHeight & " type=""application/x-shockwave-flash"" pluginspage=""http://www.macromedia.com/shockwave/download/index.cgi?P1_Prod_Version=ShockwaveFlash""></embed>"
			End If
		End If



		'Replace the flash codes in the message with the new formated flash link
		If strBuildFlashLink <> "" Then
			strMessage = Replace(strMessage, strTempFlashMsg, strBuildFlashLink, 1, -1, 1)
		Else
			strMessage = Replace(strMessage, strTempFlashMsg, Replace(strTempFlashMsg, "[", "&#91;", 1, -1, 1), 1, -1, 1)
		End If
	Loop

	'Return the function
	formatFlash = strMessage

End Function






'******************************************
'***   	  YouTube Support		***
'******************************************

'This function formats YouTube
Function formatYouTube(ByVal strMessage)


	'Declare variables
	Dim strYouTubeLink		'Hold the You Tube Link
	Dim lngStartPos			'Holds search start postions
	Dim lngEndPos			'Holds end start postions
	Dim strBuildYouTube		'Holds the built coded message
	Dim strOriginalYouTube	'Holds the code block in original format

	'Loop through all the BB codes in the message and convert to a link to the YouTube movie
	Do While InStr(1, strMessage, "[TUBE]", 1) > 0 AND InStr(1, strMessage, "[/TUBE]", 1) > 0
	
		'Get the start and end of the YouTube BBcode
		lngStartPos = InStr(1, strMessage, "[TUBE]", 1) + 6
		lngEndPos = InStr(lngStartPos, strMessage, "[/TUBE]", 1)

		'Make sure the end position is not in error
		If lngEndPos < lngStartPos Then lngEndPos = lngStartPos + 6

		'If there is a YouTube link then process
		If lngEndPos > lngStartPos Then

			'Get the YouTube link
			strYouTubeLink = Trim(Mid(strMessage, lngStartPos, lngEndPos-lngStartPos))
			
			'See if the YouTube link contains the whole URL or just the file name
			If InStr(1, strYouTubeLink, "http://", 1) = 0 Then strYouTubeLink = "http://www.youtube.com/v/" & strYouTubeLink
			
			'Insert youTube movie
			strBuildYouTube = "<object width=""425"" height=""350""><param name=""movie"" value=""" & strYouTubeLink & """></param><param name=""wmode"" value=""transparent""></param><embed src=""" & strYouTubeLink & """ type=""application/x-shockwave-flash"" wmode=""transparent"" width=""425"" height=""350""></embed></object>"
		End If

		
		'Get the start and end position in the start and end position in the message of the BBcode YouTube
		lngStartPos = InStr(1, strMessage, "[TUBE]", 1)
		lngEndPos = InStr(lngStartPos, strMessage, "[/TUBE]", 1) + 7

		'Make sure the end position is not in error
		If lngEndPos < lngStartPos Then lngEndPos = lngStartPos + 6

		'Get the original code to be replaced in the message
		strOriginalYouTube = Trim(Mid(strMessage, lngStartPos, lngEndPos-lngStartPos))

		'Replace the code codes in the message with the new formated code block
		If strBuildYouTube <> "" Then
			strMessage = Replace(strMessage, strOriginalYouTube, strBuildYouTube, 1, -1, 1)
		Else
			strMessage = Replace(strMessage, strOriginalYouTube, Replace(strOriginalYouTube, "[", "&#91;", 1, -1, 1), 1, -1, 1)
		End If
	Loop

	'Return the function
	formatYouTube = strMessage

End Function







'******************************************
'***        Display edit author		***
'******************************************

'This function formats XML into the name of the author and edit date and time if a message has been edited
'XML is used so that the date can be stored as a double npresion number so that it can display the local edit time to the message reader
Function editedXMLParser(ByVal strMessage)

		'Declare variables
		Dim strEditedAuthor 	'Holds the name of the author who is editing the post
		Dim dtmEditedDate   	'Holds the date the post was edited
		Dim lngStartPos		'Holds search start postions
		Dim lngEndPos		'Holds end start postions


		'Get the start and end in the message of the author who edit the post
		lngStartPos = InStr(1, strMessage, "<editID>", 1) + 8
		lngEndPos = InStr(1, strMessage, "</editID>", 1)
		If lngEndPos < lngStartPos Then lngEndPos = lngStartPos
		

		'If there is something returned get the authors name
		strEditedAuthor = Trim(Mid(strMessage, lngStartPos, lngEndPos-lngStartPos))

		'Get the start and end in the message of the date the message was edited
		lngStartPos = InStr(1, strMessage, "<editDate>", 1) + 10
		lngEndPos = InStr(1, strMessage, "</editDate>", 1)
		If lngEndPos < lngStartPos Then lngEndPos = lngStartPos

		'If there is something returned get the date the message was edited
		dtmEditedDate = Trim(Mid(strMessage, lngStartPos, lngEndPos-lngStartPos))


		'Get the start and end position in the string of the XML to remove
		lngStartPos = InStr(1, strMessage, "<edited>", 1)
		lngEndPos = InStr(1, strMessage, "</edited>", 1) + 9
		If lngEndPos < lngStartPos Then lngEndPos = lngStartPos

		'If there is something returned strip the XML from the message
		strMessage = Replace(strMessage, Trim(Mid(strMessage, lngStartPos, lngEndPos-lngStartPos)), "", 1, -1, 1)


		'Place the name of the person who edited the post
		If strEditedAuthor <> "" Then
			'If there is a date and time display the author date and time the post was edited
			If IsDate(dtmEditedDate) Then
				dtmEditedDate = CDate(dtmEditedDate)
				editedXMLParser = strMessage & "<span style=""font-size:10px""><br /><br />" & strTxtEditBy & " " & strEditedAuthor & " - " & DateFormat(dtmEditedDate) & " " & strTxtAt & " " & TimeFormat(dtmEditedDate) & "</span>"
			'Just display the author name who edited the post
			Else
				editedXMLParser = strMessage & "<span style=""font-size:10px""><br /><br />" & strTxtEditBy & " " & strEditedAuthor & "</span>"
			End If
		End If
End Function





'******************************************
'***    Convert Post to Text Function	***
'******************************************

'Function to romove icons and colurs to just leave plain text
Function ConvertToText(ByVal strMessage)

	Dim strTempMessage	'Temporary word hold for e-mail and url words
	Dim strMessageLink	'Holds the new mesage link that needs converting back into code
	Dim lngStartPos		'Holds the start position for a link
	Dim lngEndPos		'Holds the end position for a word
	Dim intLoop		'Loop counter

	'Remove hyperlinks
	strMessage = Replace(strMessage, " target=""_blank""", "", 1, -1, 1)
	
	
	'Loop through the message till all or any hyperlinks are turned into back into froum codes
	Do While InStr(1, strMessage, "<a href=""", 1) > 0 AND InStr(1, strMessage, "</a>", 1) > 0
						    	
		'Find the start position in the message of the HTML hyperlink
		lngStartPos = InStr(1, strMessage, "<a href=""", 1)
																	
		'Find the position in the message for the </a> closing code
		lngEndPos = InStr(lngStartPos, strMessage, "</a>", 1) + 4
		
		'Make sure the end position is not in error
		If lngEndPos - lngStartPos =< 9 Then lngEndPos = lngStartPos + 9
						
		'Read in the code to be converted back into forum codes from the message
		strMessageLink = Trim(Mid(strMessage, lngStartPos, (lngEndPos - lngStartPos)))	
		
		'Place the message link into the tempoary message variable
		strTempMessage = strMessageLink
		
		'Format the HTML hyperlink back into forum codes
		If InStr(1, strTempMessage, "src=""", 1) Then
			strTempMessage = Replace(strTempMessage, "<a href=""", " ", 1, -1, 1)
			strTempMessage = Replace(strTempMessage, "</a>", " ", 1, -1, 1)
		Else
			strTempMessage = Replace(strTempMessage, "<a href=""", " <font color='#0000FF'>", 1, -1, 1)
			strTempMessage = Replace(strTempMessage, "</a>", " ", 1, -1, 1)
			strTempMessage = Replace(strTempMessage, """>", "</font> - ", 1, -1, 1)
		End If
		
		'Place the new fromatted codes into the message string body
		strMessage = Replace(strMessage, strMessageLink, strTempMessage, 1, -1, 1)		
	Loop
	
	'Get any that may slip through (don't look as good but still has the same effect)
	strMessage = Replace(strMessage, "<a href= """, "", 1, -1, 1)
	strMessage = Replace(strMessage, "<a href='", "", 1, -1, 1)
	strMessage = Replace(strMessage, "</a>", "", 1, -1, 1)

	'Return the message with the icons and text colours removed
	ConvertToText = strMessage

End Function





'******************************************
'***     Search Word Highlighter	***
'******************************************

'Function to highlight search words if coming from search page
Private Function searchHighlighter(ByVal strMessage, ByVal sarySearchWord)

	Dim intHighlightLoopCounter	'Loop counter to loop through words and hightlight them
	Dim strTempMessage		'Temporary message store
	Dim lngMessagePosition		'Holds the message position
	Dim intHTMLTagLength		'Holds the length of the HTML tags
	Dim intSearchWordLength		'Holds the length of teh search word
	Dim blnTempUpdate		'Set to true if the temp message variable is updated


	'Loop through each character in the post message
	For lngMessagePosition = 1 to Len(strMessage)

		'Initilise for each pass
		blnTempUpdate = False

		'If an HTML tag is found then move to the end of it so that no words in the HTML are highlighted
		If Mid(strMessage, lngMessagePosition, 1) = "<" Then

			'Get the length of the HTML tag
			intHTMLTagLength = (InStr(lngMessagePosition, strMessage, ">", 1) - lngMessagePosition)

			'Place the HTML tag back into the tempary message store
			strTempMessage = strTempMessage & Mid(strMessage, lngMessagePosition, intHTMLTagLength)

			'Add the length of the HTML tag to the post message position variable
			lngMessagePosition = lngMessagePosition + intHTMLTagLength
		End If

		'Loop through the search words to see if they are in the message post
		For intHighlightLoopCounter = 0 to UBound(sarySearchWord)

			'If there is a search word in the array position check it
			If sarySearchWord(intHighlightLoopCounter) <> "" Then

				'Get the length of the search word
				intSearchWordLength = Len(sarySearchWord(intHighlightLoopCounter))

				'If the next XX characters are the same as the search word then highlight them
				If LCase(Mid(strMessage, lngMessagePosition, intSearchWordLength)) = LCase(sarySearchWord(intHighlightLoopCounter)) Then

					'Highlight the search word
					strTempMessage = strTempMessage & "<span class=""highlight"">" & Mid(strMessage, lngMessagePosition, intSearchWordLength) & "</span>"

					'Add the length of the replaced search word to the post message position variable
					lngMessagePosition = lngMessagePosition + intSearchWordLength - 1

					'Set the changed boolean to true
					blnTempUpdate = True
				End If
			End If
		Next

		'If a search word is not highlighted then add the character from the post message being checked to the temp variable
		If blnTempUpdate = False Then
			strTempMessage = strTempMessage & Mid(strMessage, lngMessagePosition, 1)
		End If
	Next

	'Return the function
	searchHighlighter = strTempMessage
End Function
%>