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, "&", "&")
tmpRTF = Replace(tmpRTF, "<", "<")
tmpRTF = Replace(tmpRTF, ">", ">")
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
