RichTextBox HTML Viewer

RichTextBox HTML Color Viewer in Visual Basic®

	by Rick Meyer Home Integrating with IE 5

This project demonstrates how to display colored text in a RichTextBox. It displays HTML files with colored tags to give better and quicker visual recognition. Additionally, certain tags are ensured to be at the "Beginning of Line." This has the effect of unjumbling HTML text that has no line breaks.

In developing this demo, more work was done deciding on acceptable color assignments for tags than writing the program. Resultantly, you may customize the tag colors as desired. In the Form_Load Sub it is a simple matter of moving a line of code.

Since the program was crafted with constants, it is easy to add your own colors. Also you may a easily add or delete tags from the array which forces them as "Beginning of Line."

For convenience an INI file is created in the App.Path that stores Form size and location (you may resize the Viewer). Also stored is the last directory visited and the last file viewed. Subsequent program restarts will restore all these.

A simple API is used to display the HTML being viewed in your default browser by pressing the command button. If you are browsing online, an interesting offshoot of this is to pinpoint the temp.htm file in the Temporary Internet Files directory.

Instructions for Building this Project:

1. Start a new standard exe
2. On Form1 put a RichTextBox named RichTextBox1
3. Set the RichTextBox1.ScrollBars property to Vertical
4. On Form1 put a Drive ListBox named Drive1
5. On Form1 put a Directory ListBox named Dir1
6. On Form1 put a File ListBox named File1
7. On Form1 put a Command Button named Command1

There is no need to position or size the above controls
on the form since that is all done in the Form_Load.

To find the RichTextBox Control click on the VB Menu->Project->Components and select Microsoft Rich TextBox Control. After you click OK the RichTextBox Control will appear in the toolbar usually on the left of the VB IDE (Integrated Development Environment).

Now you are ready for the code. Select all of the following code (by clicking on the word 'Option' three times) and copy it to the clipboard [Ctrl][Insert]. Then paste it into the code window of Form1 with [Shift][Insert].

Variable Key
% As Integer
& As Long
! As Single
# As Double
$ As String

Operation Instructions:

1. Press F5
2. Navigate to a directory
3. Click on a file
4. Click the Command Button to view the HTML in your default browser.

Option Explicit

'=========================================================
'                  Declarations
'=========================================================
Const MAX = 20, MAXSTART = 80
Const vbSpace = " ", vbSlash = "\"
Const vbDash = "-", vbExclam = "!"

Const vbOpenTag = "<", vbCloseTag = ">", vbEndTag = "/"
Const begCom = vbOpenTag & vbExclam & vbDash & vbDash
Const endCom = vbDash & vbDash & vbCloseTag

Private Enum Colors
    BLACK
    RED
    BRICK
    BROWN
    GREEN
    PURPLE
    FUCHSIA
    ORANGE
    GREY
    PINK
    BLUE
End Enum

Const DEFAULT = GREY

Private Declare Function ShellExecute _
    Lib "shell32.dll" Alias "ShellExecuteA" ( _
        ByVal hwnd As Long, _
        ByVal lpOperation As String, _
        ByVal lpFile As String, _
        ByVal lpParameters As String, _
        ByVal lpDirectory As String, _
        ByVal nShowCmd As Long) As Long

Dim colorWords$(MAX, BLUE)
Dim startWords$(MAXSTART)
Dim rgbColor&(BLUE)
Dim theText$, iniFile$, fName$
Dim FmLt!, FmTp!, FmWd!, FmHt!

'=========================================================
'             Initialization Procedures
'=========================================================
Private Sub Form_Load()
    'Made these vars to easily switch colors
    Dim x%, c%
    
'=========================================================
'              The Tags Colors
'=========================================================
    'Red Words (type in lower case)
    c = RED
        x = 0: colorWords(x, c) = "a"
    x = x + 1: colorWords(x, c) = "head"
    
    'Green Words
    c = GREEN
        x = 0: colorWords(x, c) = "address"
    x = x + 1: colorWords(x, c) = "caption"
    x = x + 1: colorWords(x, c) = "embed"
    x = x + 1: colorWords(x, c) = "hr"
    x = x + 1: colorWords(x, c) = "img"
    x = x + 1: colorWords(x, c) = "meta"
    x = x + 1: colorWords(x, c) = "noembed"
    x = x + 1: colorWords(x, c) = "noframes"
    x = x + 1: colorWords(x, c) = "plaintext"

    'Blue Words
    c = BLUE
        x = 0: colorWords(x, c) = "applet"
    x = x + 1: colorWords(x, c) = "frame"
    x = x + 1: colorWords(x, c) = "layer"
    x = x + 1: colorWords(x, c) = "multicol"
    x = x + 1: colorWords(x, c) = "object"
    x = x + 1: colorWords(x, c) = "table"
    x = x + 1: colorWords(x, c) = "title"
    x = x + 1: colorWords(x, c) = "span"
    x = x + 1: colorWords(x, c) = "xmp"
    
    'BRICK Words
    c = BRICK
        x = 0: colorWords(x, c) = "area"
    x = x + 1: colorWords(x, c) = "blockquote"
    x = x + 1: colorWords(x, c) = "ilayer"
    x = x + 1: colorWords(x, c) = "input"
    x = x + 1: colorWords(x, c) = "isindex"
    x = x + 1: colorWords(x, c) = "keygen"
    x = x + 1: colorWords(x, c) = "link"
    x = x + 1: colorWords(x, c) = "param"
    x = x + 1: colorWords(x, c) = "pre"
    x = x + 1: colorWords(x, c) = "select"
    x = x + 1: colorWords(x, c) = "style"
    x = x + 1: colorWords(x, c) = "textarea"

    'Brown Words
    c = BROWN
        x = 0: colorWords(x, c) = "dt"
    x = x + 1: colorWords(x, c) = "li"
    x = x + 1: colorWords(x, c) = "td"
    x = x + 1: colorWords(x, c) = "th"
    
    'Fuchsia Words
    c = FUCHSIA
        x = 0: colorWords(x, c) = "dir"
    x = x + 1: colorWords(x, c) = "dl"
    x = x + 1: colorWords(x, c) = "html"
    x = x + 1: colorWords(x, c) = "menu"
    x = x + 1: colorWords(x, c) = "ol"
    x = x + 1: colorWords(x, c) = "tr"
    x = x + 1: colorWords(x, c) = "ul"

    'Orange Words
    c = ORANGE
        x = 0: colorWords(x, c) = "body"
    x = x + 1: colorWords(x, c) = "tbody"
    x = x + 1: colorWords(x, c) = "frameset"

    'Pink Words
    c = PINK
        x = 0: colorWords(x, c) = "dd"
    x = x + 1: colorWords(x, c) = "div"
    x = x + 1: colorWords(x, c) = "form"
    x = x + 1: colorWords(x, c) = "iframe"
    x = x + 1: colorWords(x, c) = "map"

    'Purple Words
    c = PURPLE
        x = 0: colorWords(x, c) = "base"
    x = x + 1: colorWords(x, c) = "basefont"
    x = x + 1: colorWords(x, c) = "cite"
    x = x + 1: colorWords(x, c) = "code"
    x = x + 1: colorWords(x, c) = "kbd"
    x = x + 1: colorWords(x, c) = "option"
    x = x + 1: colorWords(x, c) = "noscript"
    x = x + 1: colorWords(x, c) = "script"
    x = x + 1: colorWords(x, c) = "server"
    x = x + 1: colorWords(x, c) = "var"
    
    'Gray Words (DEFAULT color) for all other tags
    'b
    'big
    'blink
    'br
    'center
    'em
    'font
    'h1    'to h
    'i
    'nobr
    'p
    's
    'small
    'spacer
    'strike
    'strong
    'sub
    'sup
    'tt
    'u
    'wbr

'=========================================================
'         The Tags that Force a Line Start
'=========================================================
        x = 0: startWords(x) = "address"
    x = x + 1: startWords(x) = "applet"
    x = x + 1: startWords(x) = "area"
    x = x + 1: startWords(x) = "base"
    x = x + 1: startWords(x) = "basefont"
    x = x + 1: startWords(x) = "blockquote"
    x = x + 1: startWords(x) = "body"
    x = x + 1: startWords(x) = "caption"
    x = x + 1: startWords(x) = "cite"
    x = x + 1: startWords(x) = "code"
    x = x + 1: startWords(x) = "dd"
    x = x + 1: startWords(x) = "dir"
    x = x + 1: startWords(x) = "div"
    x = x + 1: startWords(x) = "dl"
    x = x + 1: startWords(x) = "dt"
    x = x + 1: startWords(x) = "embed"
    x = x + 1: startWords(x) = "form"
    x = x + 1: startWords(x) = "frame"
    x = x + 1: startWords(x) = "frameset"
    x = x + 1: startWords(x) = "head"
    x = x + 1: startWords(x) = "hr"
    x = x + 1: startWords(x) = "html"
    x = x + 1: startWords(x) = "ilayer"
    x = x + 1: startWords(x) = "input"
    x = x + 1: startWords(x) = "isindex"
    x = x + 1: startWords(x) = "keygen"
    x = x + 1: startWords(x) = "layer"
    x = x + 1: startWords(x) = "li"
    x = x + 1: startWords(x) = "link"
    x = x + 1: startWords(x) = "map"
    x = x + 1: startWords(x) = "meta"
    x = x + 1: startWords(x) = "menu"
    x = x + 1: startWords(x) = "multicol"
    x = x + 1: startWords(x) = "noembed"
    x = x + 1: startWords(x) = "noscript"
    x = x + 1: startWords(x) = "object"
    x = x + 1: startWords(x) = "ol"
    x = x + 1: startWords(x) = "option"
    x = x + 1: startWords(x) = "p"
    x = x + 1: startWords(x) = "param"
    x = x + 1: startWords(x) = "plaintext"
    x = x + 1: startWords(x) = "pre"
    x = x + 1: startWords(x) = "script"
    x = x + 1: startWords(x) = "select"
    x = x + 1: startWords(x) = "server"
    x = x + 1: startWords(x) = "spacer"
    x = x + 1: startWords(x) = "span"
    x = x + 1: startWords(x) = "style"
    x = x + 1: startWords(x) = "table"
    x = x + 1: startWords(x) = "textarea"
    x = x + 1: startWords(x) = "title"
    x = x + 1: startWords(x) = "td"
    x = x + 1: startWords(x) = "th"
    x = x + 1: startWords(x) = "tr"
    x = x + 1: startWords(x) = "ul"
    x = x + 1: startWords(x) = "wbr"
    x = x + 1: startWords(x) = "/body"
    x = x + 1: startWords(x) = "/dir"
    x = x + 1: startWords(x) = "/dl"
    x = x + 1: startWords(x) = "/form"
    x = x + 1: startWords(x) = "/frameset"
    x = x + 1: startWords(x) = "/head"
    x = x + 1: startWords(x) = "/html"
    x = x + 1: startWords(x) = "/menu"
    x = x + 1: startWords(x) = "/ol"
    x = x + 1: startWords(x) = "/pre"
    x = x + 1: startWords(x) = "/table"
    x = x + 1: startWords(x) = "/tr"
    x = x + 1: startWords(x) = "/ul"

    'Set the colorcodes
    rgbColor(BLACK) = vbBlack
    rgbColor(RED) = vbRed
    rgbColor(BRICK) = RGB(178, 34, 34)
    rgbColor(BROWN) = RGB(210, 105, 30)
    rgbColor(GREEN) = RGB(34, 139, 34)
    rgbColor(PURPLE) = RGB(153, 50, 204)
    rgbColor(FUCHSIA) = RGB(255, 0, 255)
    rgbColor(ORANGE) = RGB(255, 140, 0)
    rgbColor(GREY) = RGB(119, 136, 153)
    rgbColor(PINK) = RGB(255, 20, 147)
    rgbColor(BLUE) = vbBlue
    
    
    Caption = "RichTextBox HTML Color Viewer"
    RichTextBox1.Text = vbNullString
    'RichTextBox1.Font.Size = 10
    Command1.Caption = "Open In Browser"
    Command1.Enabled = False
    File1.Pattern = "*.htm;*.html"
    
    
    DoEvents
    FmLt = 1000: FmTp = 100: FmWd = 10000: FmHt = 8000
    
    'Load the INI info
    iniFile = App.Path & vbSlash & App.EXEName & ".ini"
    If Dir$(iniFile) <> vbNullString Then
        x = FreeFile
        On Error Resume Next
        Open iniFile For Input As x
        Input #x, FmLt, FmTp, FmWd, FmHt
        Input #x, fName
        Close x
        DoEvents
    End If
        
    'Override INI with command line parameter
    Dim tmp1$
    tmp1 = Command$
    If tmp1 <> vbNullString Then fName = tmp1
    
    If fName <> vbNullString Then
    If Dir$(fName) <> vbNullString Then
        tmp1 = GetPath(fName)
        Dir1.Path = tmp1
        Drive1.Drive = tmp1
            
        tmp1 = GetName(fName)
        For x = 0 To File1.ListCount - 1
            If LCase$(File1.List(x)) = tmp1 Then
                File1.Selected(x) = True
                File1.TopIndex = x
                Exit For
            End If
        Next
            
        DisplayTheFile
    End If
    End If
    
    Move FmLt, FmTp, FmWd, FmHt
End Sub

Private Sub Form_Resize()
    Const DirWd! = 2300     'Controls DirList width
    Const DriveHeight! = 315, CommandHeight! = 300
    
    If WindowState = vbMinimized Then Exit Sub
        
    'Keep a minimum Form size
    Const Fm1Ht! = 5000, Fm1Wd! = 7200
    If Width < Fm1Wd Then Width = Fm1Wd: Exit Sub
    If Height < Fm1Ht Then Height = Fm1Ht: Exit Sub
    
    FmLt = Left
    FmTp = Top
    FmWd = Width
    FmHt = Height
    
    Dim tp!, wd!, ht!
    
    wd = ScaleWidth - DirWd
    RichTextBox1.Move 0, 0, wd, ScaleHeight
    
    Command1.Move wd, 0, DirWd, CommandHeight
    
    ht = ScaleHeight * 0.55
    File1.Move wd, CommandHeight, DirWd, ht
    
    tp = File1.Top + File1.Height
    ht = ScaleHeight - DriveHeight - tp
    Dir1.Move wd, tp, DirWd, ht
    
    tp = Dir1.Top + Dir1.Height
    Drive1.Move wd, tp, DirWd
End Sub

'=========================================================
'  Procedures for making a Tag "Beginning of Line"
'=========================================================
Private Sub InsertCrLf()
    Dim start&

    start = 3   'It is the first line if <=3
    Do
        DoEvents
        start = InStr(start + 1, theText, vbOpenTag)
        If start = 0 Then Exit Do
        
        If CheckForCrLf(start - 1) Then
            If CheckIfStartWord(start + 1) Then
                start = start - 1
                theText = Left$(theText, start) & _
                    vbCrLf & _
                    Right$(theText, Len(theText) - start)
                
                start = start + 3
            End If
        End If
    Loop
    
    RichTextBox1.Text = theText
End Sub

'Check if there already is a line feed
Private Function CheckForCrLf(ByVal start&) As Boolean
    For start = start To 1 Step -1
        Select Case Mid$(theText, start, 1)
            Case vbSpace, vbTab
            Case vbLf, vbCr
                Exit For
            Case Else
                CheckForCrLf = True
                Exit For
        End Select
    Next
End Function

Private Function CheckIfStartWord(ByVal start&) As Boolean
    Dim j%, endWord&, wd$
            
    For endWord = start To Len(theText)
        Select Case Mid$(theText, endWord, 1)
            Case vbSpace, vbOpenTag, vbCloseTag
                Exit For
        End Select
    Next
            
    If endWord > start Then
        wd = LCase$(Mid$(theText, start, endWord - start))
        
        For j = 0 To MAXSTART
            Select Case startWords(j)
                Case wd
                    CheckIfStartWord = True
                    Exit For
                Case vbNullString
                    Exit For
            End Select
        Next
    End If
End Function

'=========================================================
'                 Coloring Procedures
'=========================================================
Private Sub DoColoring()
    Dim start&, endTag&, clr As Colors
    
    With RichTextBox1
        .SelStart = 0
        .SelLength = Len(theText)
        .SelBold = True
        .SelColor = rgbColor(BLACK)
        .SelLength = 0
    End With

    ShowCaption -1

    Do
        DoEvents
        start = InStr(start + 1, theText, vbOpenTag)
        If start = 0 Then Exit Do
        
        If InStr(start, theText, begCom) = start Then
            endTag = InStr(start + 1, theText, endCom) + 2
            clr = DEFAULT
        Else
            endTag = InStr(start + 1, theText, vbCloseTag)
            clr = CheckColor(start + 1)
        End If
        
        If endTag = 0 Then endTag = Len(theText)
        ColorTag start, endTag - start + 1, clr
        start = endTag
    Loop

    Caption = Caption & " - " & fName
End Sub

Private Function CheckColor(ByVal start&) As Colors
    Dim j%, endWord&, wd$
    
    If Mid$(theText, start, 1) = vbEndTag Then
        start = start + 1
    End If
            
    For endWord = start To Len(theText)
        Select Case Mid$(theText, endWord, 1)
            Case vbSpace, vbOpenTag, vbCloseTag, vbCr, vbLf
                Exit For
        End Select
    Next
            
    If endWord > start Then
        wd = LCase$(Mid$(theText, start, endWord - start))
        If wd = "title" Then ShowCaption start
        CheckColor = SetColor(wd)
    End If
End Function

Private Function SetColor(ByVal wd$) As Colors
    Dim j%, clr%, found As Boolean
    
    For clr = RED To BLUE
        For j = 0 To MAX
            Select Case colorWords(j, clr)
                Case wd
                    found = True
                    Exit For
                Case vbNullString
                    Exit For
            End Select
        Next

        If found Then Exit For
    Next

    SetColor = IIf(found, clr, DEFAULT)
End Function

Private Sub ColorTag(begin&, lgth&, clr As Colors)
    With RichTextBox1
        .SelStart = begin - 1
        .SelLength = lgth
        .SelColor = rgbColor(clr)
        .SelLength = 0
    End With
End Sub

Private Sub ShowCaption(ByVal num&)
    Static cnt%, start&
    
    If num < 0 Then cnt = 3
    
    cnt = cnt - 1
    
    Select Case cnt
      Case 2
        Caption = vbNullString
      Case 1
        start = InStr(num, theText, vbCloseTag) + 1
        If start < 8 Then cnt = 2
      Case 0
        num = num - 2
        If num > start Then _
        Caption = MyTrim(Mid$(theText, start, num - start))
    End Select
End Sub

'=========================================================
'       Miscellaneous String Handling Functions
'=========================================================
'The intrinsic Trim$ Function
'  does NOT strip all Chars <= Asc(32)
Private Function MyTrim$(ByVal s$)
    Dim j%, k%, l%
    
    l = Len(s)
    For j = 1 To l
        If Asc(Mid$(s, j, 1)) > 32 Then Exit For
    Next
    For k = l To 1 Step -1
        If Asc(Mid$(s, k, 1)) > 32 Then Exit For
    Next
    
    s = IIf(k > j, Mid$(s, j, k - j + 1), vbNullString)
    MyTrim = s
End Function

Private Function GetPath$(ByVal fn$)
    Dim j%
    
    For j = Len(fn) To 1 Step -1
        If Mid$(fn, j, 1) = vbSlash Then Exit For
    Next

    Select Case j
        Case 3: fn = Left$(fn, 3)
        Case Is > 3: fn = Left$(fn, j - 1)
        Case Else: fn = vbNullString
    End Select
    
    GetPath = fn
End Function

Private Function GetName$(ByVal fn$)
    Dim j%, l%
    
    l = Len(fn)
    For j = l To 1 Step -1
        If Mid$(fn, j, 1) = vbSlash Then Exit For
    Next

    Select Case j
        Case l: fn = vbNullString
        Case Is > 2: fn = Right$(fn, l - j)
    End Select
    
    GetName = LCase$(fn)
End Function

Private Function AddSlash$(ByVal s$)
    If Len(s) Then
        If Right$(s, 1) <> vbSlash Then s = s & vbSlash
    End If
    
    AddSlash = s
End Function

'=========================================================
'                 Clicking Events
'=========================================================
Private Sub File1_Click()
    fName = AddSlash(File1.Path) & File1.filename
    DisplayTheFile
End Sub

Private Sub DisplayTheFile()
    Command1.Enabled = False
    
    Dim f%
    f = FreeFile
    Open fName For Input As f
    theText = Input(LOF(f), f)
    Close f
    
    With RichTextBox1
        .Text = vbNullString
        .Visible = False
        
        InsertCrLf
        DoColoring
        
        .SelStart = 0
        .Visible = True
    End With
    
    Command1.Enabled = True
End Sub

Private Sub Dir1_Click()
    Dir1.Path = Dir1.List(Dir1.ListIndex)
End Sub

Private Sub Dir1_Change()
    File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
    On Error GoTo DriveHandler
    Dir1.Path = CurDir(Drive1.Drive)
    Exit Sub

DriveHandler:
    Drive1.Drive = Dir1.Path
End Sub

Private Sub Command1_Click()
    ShellExecute hwnd, "open", fName, _
        vbNullString, vbNullString, 1
End Sub

'=========================================================
'           Termination - Save INI Info
'=========================================================
Private Sub Form_Unload(Cancel As Integer)
    Dim f%
        
    f = FreeFile
    Open iniFile For Output As f
    If WindowState = vbMinimized Then
        Print #f, FmLt, FmTp, FmWd, FmHt
    Else
        Print #f, Left, Top, Width, Height
    End If
    Write #f, fName
    Close f
End Sub

If you have Internet Explorer 5 and want to integrate this program with your browser, here is a way you can do it if you compile this program:

  1. Exit all Internet Explorer instances.
  2. GoTo Start->Settings->Folder Options->File Types
  3. Scroll down to and select HTML Document
  4. Click Edit
  5. In the Actions list select Edit
  6. Click Edit
  7. Browse to this compiled program
  8. Click OK
  9. Click OK
10. Click OK
11. Start Internet Explorer
12. Menu->Tools->Internet Options->Programs
13. Select your compiled EXE from the HTML Editor ComboBox
14. Click OK

Now when you want to View the HTML in your browser, choose Edit With in the File Menu of IE. If you have already done this for your own editor then you may be out of luck. Unfortunately there is no way to do this for the View Source Option when you right click on a Web page.

RichTextBox HTML Color Viewer in Visual Basic®