VB - RichTextBox to HTML

[Static]

been playing around with this:
seems to work ok, but wondering if it could be done faster
1 RichTextBox (RTB1)
1 Webbrowser Control (Default Name: Webbrowser1)
1 command btn (cmdCreate)

Paste Colored * Text into the RTB

(*this is designed to change VB code to HTML for display.. so there is other code that colors it correctly first.... it will not pick up bold/font/etc.. just color...)

Dim txtHTML As String
 
'Convert to HTML Color
Private Function GetHTMLColor(lColor As Long) As String
 
    Dim sColor As String
    Dim sR As String
    Dim sG As String
    Dim sB As String
    
    sColor = Right(String(6, "0") & Hex(lColor), 6)
    
    sR = Mid(sColor, 1, 2)
    sG = Mid(sColor, 3, 2)
    sB = Mid(sColor, 5, 2)
    GetHTMLColor = "#" & sB & sG & sR
 
End Function
 
 
'Code to convert
Private Sub cmdCreate_Click()
    Dim clr As String
    RTB1.SelStart = 0
    clr = GetHTMLColor(RTB1.SelColor)
    txtHTML = "<PRE><font face=" & Chr(34) & "courier new" & Chr(34) & " size=2><font color=" & clr & ">"
    For x = 1 To Len(RTB1.Text)
        RTB1.SelStart = x
        If GetHTMLColor(RTB1.SelColor) <> clr And Mid(RTB1.Text, x, 1) <> " " Then
            clr = GetHTMLColor(RTB1.SelColor)
            txtHTML = txtHTML & "</font><font color=" & clr & ">"
        End If
        Select Case Mid(RTB1.Text, x, 1)
            Case "<"
                txtHTML = txtHTML & "&lt"
            Case ">"
                txtHTML = txtHTML & "&gt"
            Case "&"
                txtHTML = txtHTML & "&amp;"
            Case Else
                txtHTML = txtHTML & Mid(RTB1.Text, x, 1)
        End Select
        
    Next
    txtHTML = txtHTML & "</font></font></PRE>"
    WebBrowser1.Navigate "about:blank"
End Sub
 
 
'To Display it to the user
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    If (pDisp Is WebBrowser1.Application) Then
        WebBrowser1.Document.write txtHTML
    
    End If
End Sub

[iPrank]

Instead of using Sel* properties, if you directly use RTF to get the ColorTable, it will be much faster.

In the following code, I first copied the TextRTF to a RTBTemp.
Then, GetRTFColorTable gets the color table.
ReplaceColor then replaces the RTF color tags with HTML font tags depending on the color table. This process actually changes the .Text to a valid HTML string without destroying other RTF formats.

I'm interested in this topic too.
I hope Speed Gurus will come here and help us make this faster.

Option Explicit
' Add a webbrowser (WebBrowser1), 2 RTBs (RTB1 and RTBTemp)
' and a CommandButton (CmdCreate)
Private Type RGBTRIPLE
    B As Byte
    G As Byte
    R As Byte
End Type
 
Private RTFColorTbl() As RGBTRIPLE ' Stores all colors used in the RTB
Private txtHTML As String
 
'=============================================================
'=============================================================
' [hl][b]Gets Colors from RTF Color Table[/b][/hl]
Private Function GetRTFColorTable(strRTF As String) As RGBTRIPLE()
  Dim lngColorTblStart As Long
  Dim lngColorTblEnd As Long
  Dim strColorTable As String
  Dim strTmpColor As String
  Dim strColorString As String
  Dim lPos As Long
  Dim lPos2 As Long
  Dim lOldPos As Long
  Dim lOldPos2 As Long
  '
  Erase RTFColorTbl
  ReDim RTFColorTbl(0) ' First color is Black (not in colortable)
  RTFColorTbl(0).R = 0
  RTFColorTbl(0).G = 0
  RTFColorTbl(0).B = 0
  '
  lngColorTblStart = InStr(strRTF, "{\colortbl ;")
  lngColorTblEnd = InStr(lngColorTblStart + 12, strRTF, "}")
  strColorTable = Mid$(strRTF, lngColorTblStart + 12, _
     lngColorTblEnd - lngColorTblStart - 12)
  '
  lOldPos = 1
 
  Do
    lPos = InStr(lOldPos, strColorTable, ";")
 
    If lPos > 0 Then
      ReDim Preserve RTFColorTbl(UBound(RTFColorTbl) + 1)
      strColorString = Mid$(strColorTable, lOldPos, lPos - lOldPos)
      lOldPos = lPos + 1
      '
      'Get R ==>
      lOldPos2 = 5
      lPos2 = InStr(lOldPos2, strColorString, "\")
      strTmpColor = Mid$(strColorString, lOldPos2, lPos2 - lOldPos2)
      RTFColorTbl(UBound(RTFColorTbl)).R = CByte(strTmpColor)
      '
      'Get G ==>
      lOldPos2 = lPos2 + 6
      lPos2 = InStr(lOldPos2, strColorString, "\")
      strTmpColor = Mid$(strColorString, lOldPos2, lPos2 - lOldPos2)
      RTFColorTbl(UBound(RTFColorTbl)).G = CByte(strTmpColor)
      '
      'Get B ==>
      lOldPos2 = lPos2 + 5
      strTmpColor = Mid$(strColorString, lOldPos2, _
         Len(strColorString) - lOldPos2 + 1)
      RTFColorTbl(UBound(RTFColorTbl)).B = CByte(strTmpColor)
    Else
      Exit Do
    End If
 
  Loop
 
End Function
 
'=============================================================
Private Function ReplaceColor(strRTF As String) As String
  Dim i As Long
 
  For i = 1 To UBound(RTFColorTbl)
    strRTF = Replace(strRTF, "\cf" & i & " ", "<font color=" & _
       GetHTMLColor(RTFColorTbl(i)) & ">")
    strRTF = Replace(strRTF, "\cf" & i, "<font color=" & _
       GetHTMLColor(RTFColorTbl(i)) & ">")
  Next
 
  strRTF = Replace(strRTF, "\cf0 ", "</font>")
  strRTF = Replace(strRTF, "\cf0", "</font>")
  ReplaceColor = strRTF
  ' Now the .Text is the string we need
End Function
 
'=============================================================
Private Function GetHTMLColor(lColor As RGBTRIPLE) As String
  Dim sColor As String
  Dim sR As String
  Dim sG As String
  Dim sB As String
  sColor = Right$(String$(6, "0") & _
     Hex$(RGB(lColor.R, lColor.G, lColor.B)), 6)
  sR = Mid$(sColor, 1, 2)
  sG = Mid$(sColor, 3, 2)
  sB = Mid$(sColor, 5, 2)
  GetHTMLColor = "#" & sB & sG & sR
End Function
 
'=============================================================
Private Sub cmdCreate_Click()
  Dim tmpRTF As String
  RTBTemp.TextRTF = RTB1.TextRTF 'copy to
  GetRTFColorTable RTBTemp.TextRTF
  '
  txtHTML = "<HTML><BODY><PRE><font face=" & Chr$(34) & _
     "courier new" & Chr$(34) & " size=2>"
  '
  ' May need more check here ==>
  tmpRTF = Replace(RTBTemp.TextRTF, "\\", Chr$(27)) 'remove \\ RTF escape sequence
  tmpRTF = Replace(tmpRTF, "&", "&amp;")
  tmpRTF = Replace(tmpRTF, "<", "&lt")
  tmpRTF = Replace(tmpRTF, ">", "&gt")
  tmpRTF = ReplaceColor(tmpRTF)
  RTBTemp.TextRTF = Replace(tmpRTF, Chr$(27), "\\") 'restore \\ RTF escape sequence
  '
  txtHTML = txtHTML & RTBTemp.Text
  txtHTML = txtHTML & "</font></PRE></BODY></HTML>"
  '
  WebBrowser1.Navigate "about:blank"
End Sub
 
'=============================================================
Private Sub Form_Load()
  WebBrowser1.Navigate2 "about:blank"
End Sub
 
'=============================================================
'To Display it to the user
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, _
     URL As Variant)
 
  If (pDisp Is WebBrowser1.Application) Then
    WebBrowser1.Document.write txtHTML
  End If
 
End Sub

[Static]

speed? yes very fast 80ms compared to mine 1953ms

but.. your code does not work properly...

code that went in:

txtHTML = txtHTML & "</font></font></PRE>"
code that came out
txtHTML = txtHTML & "&lt/font&gt&lt/font&gt&lt/PRE&gt"


heres why:

txtHTML = txtHTML &amp; <font color=#010101>"&amp;lt/font&amp;gt&amp;lt/font&amp;gt&amp;lt/PRE&amp;gt<font color=#000000>"

its replacing < with &lt but then replacing & with &amp....

[si_the_geek]

just change the order of the calls to Replace

[Static]

http://www.vbforums.com/

uh.. yeah. I knew that. http://www.vbforums.com/

(I must be a bit tired.. lol! a few too many wobbly pops last night)

[iPrank]

First, why your smilies are not working ?

Second, I didn't tested it with special characters.

Third, if your .Text has a \cfX in it, then, inside TextRTF it will be represented as \\cfX. ( X is a number.)
( \,},{ are special characters in rtf - they are escaped with a \.). In that case we need to add more testing.
Edit: Please see post#9

Fourth, Is operation on byte-array is faster than string operations ? (With respect to the functions I used)

[Static]

the savings of time with the byte array would be SO minimal I dont think it would matter.

I have NO clue why my smiles arent working!???

[Static]

ok they work elsewhere.. maybe they are disabled in the CodeItBetter

[iPrank]

Code updated. Again.

For problem with \\ escape sequence, I've added those Replaces with Chr$(27). As the Escape charecter can't stay inside a valid RTF string, I've used it to place bookmarks for \\.

Any better idea ?

[Raedwulf]

the savings of time with the byte array would be SO minimal I dont think it would matter.

Well, integer array would be more appropriate. Time savings would be around 50% or so...at a rough estimate.

but I guess at 80ms, unless you need it realtime, that will do

[Nitesh]

Guys how would I go about detecting bold,italic etc

[iPrank]

You'll need to replace the rtf tage with HTML tags.
In my code, (before tmpRTF = ReplaceColor(tmpRTF) line), replace these in tmpRTF,

\b with <b>
\b0 with </b>

\i with <i>
\i0 with </i>

\u with <u>
\u0 with </u>

Note: My own code in post#2 is giving me error. You may need to debug it.

[Nitesh]

Thanks for the reply iPrank ,

Yeah, I get type mismatches on these lines:

RTFColorTbl(UBound(RTFColorTbl)).R = CByte(strTmpColor)

I have no idea how to fix it. Please help.

I will try the code to change tags. Thanks again