convertTags

[oguruma]

Code : Tout sélectionner

'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




[Michael DELIQUE]

Une autre version

Code : Tout sélectionner

Function HTMLTagConvert(wChaine As String, wnbConserveBalise As Boolean) As String
   
    On Error Goto ErreurHandle
   
        'remplace les balise pouvant être conserver sans risque
    If wnbConserveBalise = True Then
        HTMLTagConvert  = Replace(HTMLTagConvert ,"<B>","[#B#]",,,1)
        HTMLTagConvert  = Replace(HTMLTagConvert ,"</B>","[#/B#]",,,1)
        HTMLTagConvert  = Replace(HTMLTagConvert ,"<I>","[#I#]",,,1)
        HTMLTagConvert  = Replace(HTMLTagConvert ,"</I>","[#/I#]",,,1)
        HTMLTagConvert  = Replace(HTMLTagConvert ,"<U>","[#U#]",,,1)
        HTMLTagConvert  = Replace(HTMLTagConvert ,"</U>","[#/U#]",,,1)
        HTMLTagConvert  = Replace(HTMLTagConvert ,"<BR>","[#BR#]",,,1)
    End If
   
    'convertit les < > / \ pour désactiver le HTML du code source, il sera toujours afficher comme telle par le navigateur mais plus interpréter comme du html mais comme une chaine de caratctere
   
    If Instr(HTMLTagConvert ,"<") > 0 Then
        HTMLTagConvert = Replace(HTMLTagConvert,"<","&lt;")
    End If   
   
    If Instr(HTMLTagConvert ,">") > 0 Then
        HTMLTagConvert = Replace(HTMLTagConvert,">","&gt;")
    End If   
   
    'le remplacement des / \ désactive les urls (pour les urls complexe) et chemin d'accès
    If Instr(HTMLTagConvert ,"/") > 0 Then
        HTMLTagConvert = Replace(HTMLTagConvert,"/","/")
    End If   
   
    If Instr(HTMLTagConvert ,"\") > 0 Then
        HTMLTagConvert = Replace(HTMLTagConvert,"\","\")
    End If   
   
    'remet les balises conservés
    If wnbConserveBalise = True Then
        HTMLTagConvert  = Replace(HTMLTagConvert ,"[#B#]","<B>",,,1)
        HTMLTagConvert  = Replace(HTMLTagConvert ,"[#/B#]","</B>",,,1)
        HTMLTagConvert  = Replace(HTMLTagConvert ,"[#I#]","<I>",,,1)
        HTMLTagConvert  = Replace(HTMLTagConvert ,"[#/I#]","</I>",,,1)
        HTMLTagConvert  = Replace(HTMLTagConvert ,"[#U#]","<U>",,,1)
        HTMLTagConvert  = Replace(HTMLTagConvert ,"[#U#]","</U>",,,1)
        HTMLTagConvert  = Replace(HTMLTagConvert ,"[#BR#]","<BR>",,,1)
    End If
   
    Exit Function
ErreurHandle:
    Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
    HTMLTagConvert = ""
    Exit Function

[Bidouille]

@Ogurama

Je ne connaisais pas ce site ... il est super

http://www.nsftools.com/

Merci

[Michael DELIQUE]

c'est un grand classique...