Convert HTML to RTF in VB

Posted on 2009-04-21
Last Modified: 2013-12-20
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.
-------------------------------------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


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 = ""


End Sub

Private Sub Form_Load()

Dim intLoadFonts As Integer

For intLoadFonts = 0 To Screen.FontCount - 1

    cmbFont.AddItem Screen.Fonts(intLoadFonts)


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


        picBold(0).Visible = False

        picBold(1).Visible = True

        txtSend.SelBold = False

    End If


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


        picItalic(0).Visible = False

        picItalic(1).Visible = True

        txtSend.SelItalic = False

    End If


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


        picUnderline(0).Visible = False

        picUnderline(1).Visible = True

        txtSend.SelUnderline = False

    End If


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


        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, "<")


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


Open in new window

Question by:mystami
    LVL 22

    Expert Comment

    See if this helps:

    HTML To RTF Parser - w/Sourcecode

    LVL 1

    Author Comment

    That is one of the others that I have tried.
    LVL 1

    Author Comment

    Still hoping for some help!
    LVL 1

    Accepted Solution

    I was actually able to convert the RTF to HTML then back to RTF and that seems to be working okay doing it the way I was above.  I would really have like to have done it the other way but this is the best solution I have for now.

    Featured Post

    How your wiki can always stay up-to-date

    Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
    - Increase transparency
    - Onboard new hires faster
    - Access from mobile/offline

    Join & Write a Comment

    Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
    This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
    Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
    Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…

    746 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    20 Experts available now in Live!

    Get 1:1 Help Now