mystami
asked on
Convert HTML to RTF in VB
I found some code that was very helpful in accomplishing what I want, which is converting HTML to RTF. I have seen several examples, but none of them work or work like I would like. I have slightly modified the original to speed it up.
The code works perfect when using it to convert just standard text, but when you attempt to use a richtextbox with formatting and have html in it then it doesn't work.
So instead of just setting .SelBold or .SelFontName, etc. I would like to have the code actually convert the HTML into RTF coding. Below is the code from the form and module that I'm testing with. If you'd like I can provide a link to download the project.
I would greatly appreciate someone showing me how to change this code to what's going to work for me.
The code works perfect when using it to convert just standard text, but when you attempt to use a richtextbox with formatting and have html in it then it doesn't work.
So instead of just setting .SelBold or .SelFontName, etc. I would like to have the code actually convert the HTML into RTF coding. Below is the code from the form and module that I'm testing with. If you'd like I can provide a link to download the project.
I would greatly appreciate someone showing me how to change this code to what's going to work for me.
-------------------------------------Form 1-----------------------------------------
Option Explicit
Private Const IDC_HAND = 32649&
Private Const IDC_ARROW = 32512&
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Sub cmbFont_Change()
On Error Resume Next
txtSend.SelFontName = cmbFont.Text
txtSend.SetFocus
End Sub
Private Sub cmdSend_Click()
If txtSend.Text = "" Then Exit Sub
Dim lngSpot As Long
lngSpot = Len(txtChat.Text)
With txtChat
.SelStart = Len(.Text)
.SelLength = 0
.SelBold = True
.SelColor = vbBlue
.SelFontSize = "10"
.SelFontName = "Arial"
.SelText = "mystami: " & vbTab
.SelStart = lngSpot
.SelLength = Len(.Text) - lngSpot
.SelHangingIndent = 1400
.SelStart = Len(.Text)
.SelLength = 0
.SelBold = False
.SelColor = vbBlack
End With
'Here I would like to be able to Call HTMLtoRTF(txtSend.TextRTF)
'so any custom formatting would be sent, but it does not work
'wit the way the HTML is converted to RTF
Call HTMLtoRTF(txtSend.Text)
txtChat.SelStart = Len(txtChat.Text)
txtChat.SelLength = 0
txtChat.SelText = vbCrLf
txtSend.Text = ""
txtSend.SetFocus
End Sub
Private Sub Form_Load()
Dim intLoadFonts As Integer
For intLoadFonts = 0 To Screen.FontCount - 1
cmbFont.AddItem Screen.Fonts(intLoadFonts)
Next
cmbFont.Text = "Arial"
txtSend.TabIndex = 0
End Sub
Private Sub txtSend_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then cmdSend_Click
End Sub
Private Sub picBold_Click(Index As Integer)
If Index = 1 Then
picBold(0).Visible = True
picBold(1).Visible = False
txtSend.SelBold = True
Else
picBold(0).Visible = False
picBold(1).Visible = True
txtSend.SelBold = False
End If
txtSend.SetFocus
End Sub
Private Sub picBold_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SetCursor LoadCursor(0, IDC_HAND)
End Sub
Private Sub picItalic_Click(Index As Integer)
If Index = 1 Then
picItalic(0).Visible = True
picItalic(1).Visible = False
txtSend.SelItalic = True
Else
picItalic(0).Visible = False
picItalic(1).Visible = True
txtSend.SelItalic = False
End If
txtSend.SetFocus
End Sub
Private Sub picItalic_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SetCursor LoadCursor(0, IDC_HAND)
End Sub
Private Sub picUnderline_Click(Index As Integer)
If Index = 1 Then
picUnderline(0).Visible = True
picUnderline(1).Visible = False
txtSend.SelUnderline = True
Else
picUnderline(0).Visible = False
picUnderline(1).Visible = True
txtSend.SelUnderline = False
End If
txtSend.SetFocus
End Sub
Private Sub picUnderline_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SetCursor LoadCursor(0, IDC_HAND)
End Sub
--------------------------------------------------------------------------------------
------------------------------------Module 1---------------------------------------
Option Explicit
Public Sub HTMLtoRTF(HTML As String)
Dim Buf As String
Dim char As String
Dim Bumf As String
Dim a As Integer
Dim i As Integer
Dim strString As String
Bumf = HTML
'We set some defaults for the richedit
'Bumf = "</b></i></u><font face=""Arial"" size=""10"">" & Bumf
'vbCrLf' can reset the tags so lets remove them
Bumf = Replace(Bumf, vbCrLf, "")
'Put any text that come sbefore the first tag into the string
If Left(Bumf, 1) <> "<" Then
If InStr(1, Bumf, "<") = 0 Then
frmChat.txtChat.SelText = Bumf
Else
frmChat.txtChat.SelText = Left(Bumf, (InStr(1, Bumf, "<") - 1))
End If
End If
i = InStr(1, Bumf, "<")
'Now we go through the string
Do While i <> 0
char = Mid(Bumf, i, 1)
'If the character is a < then we have a tag
If char = "<" Then
'So, using that as a start point we look for the clsoing bracket tag
a = InStr(i, Bumf, ">")
'We get all the text that comes after the > until the end of the string
Buf = Mid(Bumf, a + 1, Len(Bumf) - a)
'But if there's a < in there then there's another tag so we just want the text between the tags.
If InStr(1, Buf, "<") Then Buf = Left(Buf, InStr(1, Buf, "<") - 1)
'Now we get the tag by retrieving the text between the brackets and making it lowercase.
Call Tags(Mid(Bumf, i + 1, a - (i + 1)), Buf)
End If
i = InStr(i + 1, Bumf, "<")
Loop
End Sub
Public Sub Tags(Tag As String, Data As String)
Dim a As Integer
'If they want to alter the font then pass the info to the font sub routine
If Left(LCase(Tag), 5) = "font " Then Call FontTags(Tag, Data): Exit Sub
'If the tag contains a start bracket then disregard it as a tag
'and class it as normal text
If InStr(1, Tag, "<") Then
a = InStr(1, Tag, "<") - 1
frmChat.txtChat.SelText = "<" & Left(Tag, a)
Exit Sub
End If
'Now lets go thru all the fonts we have decided to handle
Select Case LCase(Tag)
Case "b"
'Tags = "\b "
frmChat.txtChat.SelBold = True
frmChat.txtChat.SelText = Data
Case "/b"
'Tags = "\b0"
frmChat.txtChat.SelBold = False
frmChat.txtChat.SelText = Data
Case "i"
'Tags = "\i "
frmChat.txtChat.SelItalic = True
frmChat.txtChat.SelText = Data
Case "/i"
'Tags = "\i0"
frmChat.txtChat.SelItalic = False
frmChat.txtChat.SelText = Data
Case "u"
'Tags = "\ul "
frmChat.txtChat.SelUnderline = True
frmChat.txtChat.SelText = Data
Case "/u"
'Tags = "\ulnone"
frmChat.txtChat.SelUnderline = False
frmChat.txtChat.SelText = Data
Case "s"
'Tags = "\strike "
frmChat.txtChat.SelStrikeThru = True
frmChat.txtChat.SelText = Data
Case "/s"
'Tags = "\strike0"
frmChat.txtChat.SelStrikeThru = False
frmChat.txtChat.SelText = Data
'IF you know HTML then you know this is a break tag
'it's used to start a new line
Case "br", "/font"
frmChat.txtChat.SelText = Data
'If there are any unrecognised tags just post it's text using the current sel settings.
Case Else
frmChat.txtChat.SelText = "<" & Tag & ">" & Data
End Select
End Sub
Private Sub FontTags(Tag As String, Data As String)
Dim a As Integer
Dim Tag2 As String
Dim Tag3 As String
Dim strString As String
'MsgBox Tag & ": " & Data
'We know the tag is a font styling tag so we can remove the font bit
Tag = Right(Tag, Len(Tag) - 5)
'First lets deal with font face tags.
'The string for the name must be in ""'s
If InStr(1, LCase(Tag), "face=") Then
Tag2 = Right(Tag, Len(Tag) - (InStr(1, LCase(Tag), "face=") + 5))
Tag2 = Left(Tag2, InStr(1, Tag2, Chr(34)) - 1)
'strString = "{\fonttbl{\f" & "0" & "\fnil\fcharset0 " & Trim(Tag2) & ";}"
'MsgBox "strString: " & strString
'strString = Trim(Tag2)
frmChat.txtChat.SelFontName = Trim(Tag2)
End If
If InStr(1, LCase(Tag), "color=") Then
Tag2 = Right(Tag, Len(Tag) - (InStr(1, LCase(Tag), "color=") + 6))
On Error Resume Next
Tag2 = Left(Tag2, InStr(1, Tag2, Chr(34)) - 1)
frmChat.txtChat.SelColor = HexToDecimal(Trim(Tag2))
End If
'Now lets see if they want to change the fonts size
If InStr(1, LCase(Tag), "size=") Then
Tag2 = Right(Tag, Len(Tag) - (InStr(1, LCase(Tag), "size=") + 5))
Tag2 = Left(Tag2, InStr(1, Tag2, Chr(34)) - 1)
If Val(Tag2) > 0 Then frmChat.txtChat.SelFontSize = Val(Tag2)
End If
'Now we've set any font face and size requests we can post the string
'rchHTML.SelText = Data
frmChat.txtChat.SelText = Data
End Sub
Function HexToDecimal(ByVal strHex As String) As Long
'this function converts any hexidecimal color value
'(e.g. "0000FF" = Blue) to decimal color value.
Dim lngDecimal As Long, strCharHex As String, lngColor As Long
Dim lngChar As Long
If Left$(strHex$, 1) = "#" Then strHex$ = Right$(strHex$, 6)
strHex$ = Right$(strHex$, 2) & Mid$(strHex$, 3, 2) & Left$(strHex$, 2)
For lngChar& = Len(strHex$) To 1 Step -1
strCharHex$ = Mid$(UCase$(strHex$), lngChar&, 1)
Select Case strCharHex$
Case 0 To 9
lngDecimal& = CLng(strCharHex$)
Case Else 'A,B,C,D,E,F
lngDecimal& = CLng(Chr$((Asc(strCharHex$) - 17))) + 10
End Select
lngColor& = lngColor& + lngDecimal& * 16 ^ (Len(strHex$) - lngChar&)
Next lngChar&
HexToDecimal = lngColor&
End Function
--------------------------------------------------------------------------------------
ASKER
That is one of the others that I have tried.
ASKER
Still hoping for some help!
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
HTML To RTF Parser - w/Sourcecode
http://www.freevbcode.com/ShowCode.asp?ID=3250