RTF to HTML

August 29, 2012:
Someone at work was looking for a way to convert rich-text in an Excel cell into HTML. After some google failed to turn up anything useful I managed to hack together enough VBA to get it working. This crappy code will take RTF in a cell and output the HTML code for the rich-text in the next cell. Currently supports:

bold
italic
underline
bullet points

Use at your own risk. :)

Sub RTF_to_HTML()

Dim bold As Boolean
bold = False
Dim italic As Boolean
italic = False
Dim underline As Boolean
underline = False
Dim inList As Boolean
inList = False

Dim newStr As String
For i = 1 To ActiveCell.Characters.Count

    If True = ActiveCell.Characters(i, 1).Font.bold Then
        If (False = bold) Then
            bold = True
            newStr = newStr + "<b>"
        End If
    Else
        If (True = bold) Then
            bold = False
            newStr = newStr + "</b>"
        End If
    End If
    
    If True = ActiveCell.Characters(i, 1).Font.italic Then
        If (False = italic) Then
            italic = True
            newStr = newStr + "<i>"
        End If
    Else
        If (True = italic) Then
            italic = False
            newStr = newStr + "</i>"
        End If
    End If
    
    If True = ActiveCell.Characters(i, 1).Font.underline Then
        If (False = underline) Then
            underline = True
            newStr = newStr + "<u>"
        End If
    Else
        If (True = underline) Then
            underline = False
            newStr = newStr + "</u>"
        End If
    End If
            
    If (ActiveCell.Characters(i, 1).Text = Chr(10)) Then
        newStr = newStr + "<br>"
        
        If (True = inList) Then
          newStr = newStr + "</li>"
          If (ActiveCell.Characters(i + 1, 1).Text <> Chr(149)) Then
            Rem Not a bullet point -- the list ended
            inList = False
            newStr = newStr + "</ul>"
          End If
        End If
    End If
    
    newStr = newStr + ActiveCell.Characters(i, 1).Text
    
    If (ActiveCell.Characters(i, 1).Text = Chr(149)) Then
        Rem Strip out the bullet-point that we just added above
        newStr = Left(newStr, Len(newStr) - 1)
        
        If (False = inList) Then
            inList = True
            newStr = newStr + "<ul>"
        End If
        newStr = newStr + "<li>"
    End If
    
Next i

If (True = bold) Then
    newStr = newStr + "</b>"
End If
If (True = italic) Then
    newStr = newStr + "</i>"
End If
If (True = underline) Then
    newStr = newStr + "</u>"
End If
If (True = inList) Then
    newStr = newStr + "</li></ul>"
End If
   
Rem Put the new string on the cell to the right
ActiveCell.Offset(0, 1).Value = newStr

End Sub

RTF to HTML

Copyright © 1999-2013 Morgan "Buddy" Betts