'Convert Tags: 

Option Public
Option Explicit


Sub Initialize
	'** This is a sample agent that demonstrates a method for parsing
	'** the HTML tags in a String and converting the undesireable ones
	'** to plain HTML text (i.e. -- "<" becomes &lt; and ">" becomes &gt;)
	'** version 1.1
	'** Julian Robichaux -- http://www.nsftools.com
	
	Dim testString As String
	testString = "This is a <b>test</b> of the <i>new</i> <div>function</div>. " & Chr(13) & Chr(10) &  _
	"It should also handle <a hReF=""http://blah"">http://links</A>http://links" & _
	" blah <> blah hTtP://something" & Chr(0) & Chr(0) & "> < and http://qwerty/blah?asdf (http://blah)."
	
	Print ConvertTags(testString)
End Sub

Function ConvertTags (comment As String) As String
	'** This function converts all angle brackets ("<>") in a String to their
	'** &lt; and &gt; equivalents, with the exception of a custom subset of
	'** tags that are allowed (like <b> or <i>). The modified String is returned.
	Dim lastPos As Integer, startPos As Integer, endPos As Integer
	Dim tagString As String
	Dim newString As String
	
	lastPos = 1
	startPos = Instr(comment, "<")
	
	Do While (startPos > 0)
		'** get everything between the last end tag and the current start tag
		'** and add it to our newString, replacing any "orphan" > characters
		newString = newString & ReplaceSubstring(Mid$(comment, lastPos, startPos - lastPos), ">", "&gt;")
		
		endPos = Instr(startPos, comment, ">")
		If (endPos > 0) Then
			'** store the text between the < and the > in a variable, for easy access
			tagString = Mid$(comment, startPos + 1, endPos - startPos - 1)
			
			Select Case Trim$(Lcase$(tagString))
			Case "/a", "b", "/b", "i", "/i", "u", "/u", "p", "br", "pre", "/pre", "blockquote", "/blockquote" :
				'** these are the allowable tags. Don't forget to add the closing tag
				'** for each opening tag (i.e. -- use "b" and "/b" on your list), and make
				'** sure "/a" is on the list if you're allowing <a href=...> tags below
				newString = newString & "<" & Trim$(tagString) & ">"
			Case Else :
				'** if it's not an allowable tag, replace the < and > with
				'** &lt; and &gt; (we can check for tags with attributes
				'** here too, like <a href=...>)
				If (Left$(Trim$(Lcase$(tagString)), 7) = "a href=") Then
					'** allow <a href=...> tags -- you may also want to include your own
					'** custom routine here to check for "rogue" <a href=...> tags, like
					'** ones that contain href="javascript..." or onClick="..." (or you could
					'** just disallow <a href=...> tags completely, and just let the end of
					'** this routine do the auto-conversion of http:// links for you)
					newString = newString & "<" & Trim$(tagString) & ">"
				Else
					newString = newString & "&lt;" & tagString & "&gt;"
				End If
			End Select
		Else
			'** if we have a < without a >, then we've got an "orphan" < character,
			'** in which case we can just convert all the remaining < characters to &lt;
			newString = newString & ReplaceSubstring(Mid$(comment, startPos), "<", "&lt;")
			endPos = Len(comment)
		End If
		
		lastPos = endPos + 1
		startPos = Instr(lastPos - 1, comment, "<")
	Loop
	
	'** convert any "orphan" > characters at the end of the string
	If (lastPos <= Len(comment)) Then
		newString = newString & ReplaceSubstring(Mid$(comment, lastPos), ">", "&gt;")
	End If
	
	'** convert http:// references to links (if they're not inside a tag)
	Dim hrefStartPos As Integer, hrefEndPos As Integer
	Dim hrefEndChars As String, hrefString As String
	hrefEndChars = " " & Chr(0) & Chr(9) & Chr(10) & Chr(13)
	hrefStartPos = Instr(1, newString, "http://", 5)
	
	Do While (hrefStartPos > 0)
		startPos = Instr(hrefStartPos, newString, "<")
		endPos = Instr(hrefStartPos, newString, ">")
		
		If (endPos = 0) Or ((endPos > startPos) And (startPos > 0)) Then
			'** if we're not inside a <tag>, then convert the link
			hrefEndPos = hrefStartPos + 7
			
			'** find the end of the http:// reference
			Do While (hrefEndPos <= Len(newString))
				If (Instr(hrefEndChars, Mid$(newString, hrefEndPos, 1)) > 0) Then
					Exit Do
				End If
				hrefEndPos = hrefEndPos + 1
			Loop
			
			'** make sure that the character at the end of the http:// reference
			'** isn't really some punctuation that's probably not part of the URL
			'** (these characters aren't strictly illegal, but we're making some
			'** educated guesses based on common URL and sentence structure)
			Do While (hrefEndPos > hrefStartPos)
				If (Instr(".,?!&:-()[]<>{}'""", Mid$(newString, hrefEndPos - 1, 1)) = 0) Then
					Exit Do
				End If
				hrefEndPos = hrefEndPos - 1
			Loop
			
			hrefString = Mid$(newString, hrefStartPos, hrefEndPos - hrefStartPos)
			newString = Left$(newString, hrefStartPos - 1) & "<a href=""" & hrefString & """>" & _
			hrefString & "</a>" & Mid$(newString, hrefStartPos + Len(hrefString))
			
			hrefEndPos = hrefEndPos + Len("<a href='" & hrefString & "'></a>")
		Elseif (endPos < startPos) And (endPos > 0) Then
			'** if we're inside a tag, assume it's an <a href> tag, and skip
			'** to the closing </a> tag (so we don't accidentally double-link
			'** something like <a href="http://blah">http://blah</a>)
			hrefEndPos = Instr(endPos, newString, "</a>", 5)
			If (hrefEndPos = 0) Then
				hrefEndPos = Len(newString)
			End If
		Else
			hrefEndPos = endPos
		End If
		
		hrefStartPos = Instr(hrefEndPos, newString, "http://", 5)
	Loop
	
	'** handle linefeeds by replacing double ones with <p> and single ones with <br>
	'** (if the resulting String is going to end up in a text field, you might want to use
	'** Chr(0) as your linefeed, although you could easily use ReplaceSubstring to
	'** convert Chr(13) & Chr(10) to Chr(0) after this function runs)
	Dim linefeed As String
	linefeed = Chr(13) & Chr(10)
	newString = ReplaceSubstring(newString, Chr(13) & Chr(10), Chr(0))
	newString = ReplaceSubstring(newString, Chr(13), Chr(0))
	newString = ReplaceSubstring(newString, Chr(10), Chr(0))
	newString = ReplaceSubstring(newString, Chr(0) & Chr(0), "<p>" & linefeed)
	newString = ReplaceSubstring(newString, Chr(0), "<br>" & linefeed)
	
	ConvertTags = newString
End Function

Function ReplaceSubstring (Byval fullString As String, oldString As String, newString As String) As String
	Dim pos As Integer
	
	pos = Instr(fullString, oldString)
	Do While pos > 0
		fullString = Left$(fullString, pos - 1) & newString & Mid$(fullString, pos + Len(oldString))
		pos = Instr(pos + Len(newString), fullString, oldString)
	Loop
	
	ReplaceSubstring = fullString
End Function