'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
This LotusScript was converted to HTML using the ls2html routine,
provided by Julian Robichaux at nsftools.com.