Formatting Visual Basic 6 code for HTML

[Update (24 Oct. 2008): I modified the source code to reduce the the excessive line-spacing. Now it looks more like real VB.]

Because Blogger doesn't preserve white space (e.g., leading spaces, tabs, indents), it doesn't display computer code properly—unless your code is, oddly, always flush with the left margin.

Others have wrestled with the problem, and Google Code has a Javascript/CSS solution for "prettifying" code snippets—which I haven't tried. CodeHTMLer is an easy-to-use converter that runs in your browser, but it doesn't have a VB6 option (the VB.NET option doesn't get the colors quite right). HTML tables are another solution, but copying the resulting code (for pasting into your IDE) would be annoying. HTML definition-list tags are another option, but Blogger doesn't display them properly, either—although they are formatted correctly when viewed in Blogger's "Compose" mode. Enclosing code in "pre" HTML tags, which preserve the original formatting for display purposes, is viable, but formatting is lost when blog readers copy it to the clipboard.

Instead, I wrote a VB6 module that replaces every space with a non-breaking space HTML entity. As a bonus it also colors comments green and keywords blue. In addition, when you copy it to the clipboard, its formatting will be retained.



Instructions

Create a VB6 project, add two RichTextBoxes, a CommandButton, and my code to Form1. My code will size and place the controls at runtime, so don't worry about where you slap them on the form. No need to rename anything, either; my code uses the default control names. The form is resizable and all controls are moved and resized accordingly.

(Note that in order to add a RichTextBox control to your form, you will have to make it available on your VB project's Toolbox via the Project > Components menu; in the control list look for "Microsoft Rich Textbox Control 6.0 (SP4)" or the equivalent. You can use regular Textboxes, but will have to set the MultiLine property to True.)

Notes

For information on my error trapping technique, see "Easy Error-handling in Microsoft Visual Basic 6."

Source Code

The code was formatted using itself.

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Main.frm
'
' Author: Steve L., 14 Oct. 2008
' Revised: Steve L., 24 Oct. 2008
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

Private Const mModuleName               As String = "frmMain"

' Error variables.
Private mErrNo                          As Long
Private mErrDescr                       As String
Private mErrSource                      As String

Private Sub Command1_Click()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Author: Steve L., 17 Oct. 2008
' Revised:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Const ProcedureName                 As String = "Command1_Click"

    On Error GoTo ErrorRtn

    RichTextBox2.Text = GetFormattedCodeText(RichTextBox1.Text)

ExitRtn:
    Exit Sub
ErrorRtn:
    mErrNo = Err.Number
    mErrDescr = Err.Description
    mErrSource = Err.Source
    If Left$(mErrDescr, 1) = "_" Then
        ' Business rule violation.
        mErrDescr = Mid$(mErrDescr, 2)
        mErrSource = ""
    ElseIf Len(mErrSource) > 0 And LCase$(mErrSource) <> LCase$(App.EXEName) Then
        ' Runtime error occurred in another procedure.
        mErrSource = vbNewLine & vbNewLine & "Error stack: " & vbNewLine & App.Title & "." & mModuleName & "." & ProcedureName & vbNewLine & mErrSource
    Else
        ' Runtime error occurred in this procedure.
        mErrSource = vbNewLine & vbNewLine & "Error stack: " & vbNewLine & App.Title & "." & mModuleName & "." & ProcedureName
    End If
    MsgBox mErrDescr & mErrSource, vbExclamation, App.Title
    Resume ExitRtn
End Sub

Private Function GetFormattedCodeText(ByVal CodeText As String) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Args:
'   CodeText    VB code as it appears in the IDE.
'
' Returns the code formatted with HTML tags to preserve original formatting.
'
' Author: Steve L., 14 Oct. 2008
' Revised: Steve L., 24 Oct. 2008
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Const ProcedureName                 As String = "GetFormattedCodeText"
   
    Const CSSFontFamily                 As String = "courier new"
    Const CSSFontSize                   As String = "85%"
    Const CSSLineHeight                 As String = "1.2"
   
    Dim RetVal                          As String
    Dim LineText                        As String
    Dim LineNo                          As Long
    Dim Lines                           As Variant
    Dim LeadingSpaces                   As Variant
    Dim HasLeadingSpaces                As Boolean
    Dim MinLeadingSpaces                As Long
    Dim LeadingSpacesInLine             As Long
    Dim CharPos                         As Long
    Dim LineEnd                         As Long
    Dim HTMLTag                         As String
    Dim HTMLSpace                       As String
   
    On Error GoTo ErrorRtn

    If Len(CodeText) = 0 Then GoTo ExitRtn
   
    Lines = Split(CodeText, vbNewLine)
    If IsArray(Lines) = False Then GoTo ExitRtn
    If UBound(Lines) < 0 Then GoTo ExitRtn
   
    ' Determine whether any line has a leading space.
    For LineNo = LBound(Lines) To UBound(Lines)
        LineText = Lines(LineNo)
        If Len(LineText) > 0 Then
            If Left$(LineText, 1) = " " Then
                HasLeadingSpaces = True
                ' Dummy value intended to be larger than any real line.
                MinLeadingSpaces = 10000
                Exit For
            End If
        End If
    Next LineNo
   
    ' Find the number of leading spaces of the line with the fewest leading
    ' spaces.
    If HasLeadingSpaces Then
        For LineNo = LBound(Lines) To UBound(Lines)
            LineText = Lines(LineNo)
            If Len(LineText) > 0 Then
                LeadingSpacesInLine = 0
                If MinLeadingSpaces < Len(LineText) Then
                    LineEnd = MinLeadingSpaces
                Else
                    LineEnd = Len(LineText)
                End If
               
                For CharPos = 1 To LineEnd
                    If Left$(LineText, CharPos) = Space(CharPos) Then
                        LeadingSpacesInLine = CharPos
                    Else
                        Exit For
                    End If
                Next CharPos
                If LeadingSpacesInLine < MinLeadingSpaces Then
                    MinLeadingSpaces = LeadingSpacesInLine
                End If
            End If
        Next LineNo
       
        ' "Shift" the code leftward: remove a number of leading spaces from
        ' each line equal to the number of leading spaces of the line with the
        ' fewest leading spaces.
        For LineNo = LBound(Lines) To UBound(Lines)
            Lines(LineNo) = Mid$(Lines(LineNo), MinLeadingSpaces + 1)
        Next LineNo
    End If
   
    ' Store the number of leading spaces belonging to each line.
    ReDim LeadingSpaces(LBound(Lines) To UBound(Lines))
    For LineNo = LBound(Lines) To UBound(Lines)
        LeadingSpacesInLine = 0
        LineText = Lines(LineNo)
        For CharPos = 1 To Len(LineText)
            If Left$(LineText, CharPos) = Space(CharPos) Then
                LeadingSpacesInLine = CharPos
            Else
                Exit For
            End If
        Next CharPos
        LeadingSpaces(LineNo) = LeadingSpacesInLine
    Next LineNo
   
    ' We must create the HTML space sequence programmatically or it won't be
    ' displayed when this code is shown on a Web page.
    HTMLSpace = GetHTMLSpace()
   
    For LineNo = LBound(Lines) To UBound(Lines)
        LineText = Lines(LineNo)
       
        ' Substitute HTML entities. (Only the < sign has been a
        ' problem.)
        LineText = Replace$(LineText, "<", "<")
        LineText = Replace$(LineText, ">", ">")
        LineText = Replace$(LineText, " ", HTMLSpace)
       
        If Mid$(LineText, Len(HTMLSpace) * LeadingSpaces(LineNo) + 1, 1) = "'" Then
            ' Make full-line comments green.
            LineText = "<span style=" & Chr$(34) & "color:#006600;" & Chr$(34) & ">" & LineText & "</span>"
        Else
            ' Color keywords.
            LineText = ColorKeywords(LineText)
        End If
       
        Lines(LineNo) = LineText
    Next LineNo
   
    RetVal = Join(Lines, vbNewLine)
   
    ' Enclose code in HTML font tags.
    HTMLTag = "<span style=" & Chr$(34) & "font-family:" & CSSFontFamily & ";" & Chr$(34) & ">"
    HTMLTag = HTMLTag & "<span style=" & Chr$(34) & "font-size:" & CSSFontSize & ";" & Chr$(34) & ">"
    HTMLTag = HTMLTag & "<span style=" & Chr$(34) & "line-height:" & CSSLineHeight & ";" & Chr$(34) & ">"
    RetVal = HTMLTag & RetVal & "</span></span></span>"
   
    GetFormattedCodeText = RetVal
   
ExitRtn:
    Exit Function
ErrorRtn:
    mErrNo = Err.Number
    mErrDescr = Err.Description
    mErrSource = Err.Source
    If Left$(mErrDescr, 1) = "_" Then
        ' Business rule violation.
        mErrSource = ""
    ElseIf Len(mErrSource) > 0 And LCase$(mErrSource) <> LCase$(App.EXEName) Then
        ' Runtime error occurred in another procedure.
        mErrSource = App.Title & "." & mModuleName & "." & ProcedureName & vbNewLine & mErrSource
    Else
        ' Runtime error occurred in this procedure.
        mErrSource = App.Title & "." & mModuleName & "." & ProcedureName
    End If
    Err.Raise mErrNo, mErrSource, mErrDescr
End Function

Private Sub Form_Load()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Author: Steve L., 15 Oct. 2008
' Revised: Steve L., 19 Oct. 2008
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Const ProcedureName                 As String = "Form_Load"
   
    On Error GoTo ErrorRtn

    With RichTextBox1
        .TabIndex = 0
        .AutoVerbMenu = True
        .Font = "Courier New"
        .Font.Size = 8
        .Text = ""
    End With
   
    With Command1
        .TabIndex = 1
        .Caption = "&Format"
        .Height = 405
    End With
   
    With RichTextBox2
        .TabIndex = 2
        .AutoVerbMenu = True
        .Font = "Courier New"
        .Font.Size = 8
        .Text = ""
    End With
   
    Me.Caption = "VB Code Formatter"

ExitRtn:
    Exit Sub
ErrorRtn:
    mErrNo = Err.Number
    mErrDescr = Err.Description
    mErrSource = Err.Source
    If Left$(mErrDescr, 1) = "_" Then
        ' Business rule violation.
        mErrDescr = Mid$(mErrDescr, 2)
        mErrSource = ""
    ElseIf Len(mErrSource) > 0 And LCase$(mErrSource) <> LCase$(App.EXEName) Then
        ' Runtime error occurred in another procedure.
        mErrSource = vbNewLine & vbNewLine & "Error stack: " & vbNewLine & App.Title & "." & mModuleName & "." & ProcedureName & vbNewLine & mErrSource
    Else
        ' Runtime error occurred in this procedure.
        mErrSource = vbNewLine & vbNewLine & "Error stack: " & vbNewLine & App.Title & "." & mModuleName & "." & ProcedureName
    End If
    MsgBox mErrDescr & mErrSource, vbExclamation, App.Title
    Resume ExitRtn
End Sub

Private Function ColorKeywords(ByVal LineText As String) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Args:
'   LineText    The text to be returned.
'
' Returns the supplied text with keywords enclosed in HTML color tags.
'
' Author: Steve L., 16 Oct. 2008
' Revised: Steve L., 18 Oct. 2008
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Const ProcedureName                 As String = "ColorKeywords"
   
    Const BlueCode                      As String = "3333ff"
   
    Dim WordDelimiter                   As String
    Dim HTMLColorTag                    As String
    Dim RetVal                          As String
    Dim Words                           As Variant
    Dim Word                            As Long
   
    On Error GoTo ErrorRtn
   
    HTMLColorTag = "<span style=" & Chr$(34) & "color:#" & BlueCode & ";" & Chr$(34) & ">"
 
    WordDelimiter = GetHTMLSpace()
   
    Words = Split(LineText, WordDelimiter)
   
    For Word = LBound(Words) To UBound(Words)
        Select Case Words(Word)
            ' (Keyword list is alphabetical.)
            Case "As", "Boolean", "ByVal", "ByRef", "Byte", "Call", "Case", _
                "CBool", "CByte", "CCur", "CDate", "CDbl", "CDec", "CInt", _
                "CLng", "Close", "Compare", "Const", "CSng", "CStr", _
                "Currency", "CVar", "Date", "Decimal", "Declare", "Dim", _
                "Do", "Double", "Each", "Else", "ElseIf", "Empty", "End", _
                "Enum", "Erase", "Error", "Event", "Exit", "Explicit", _
                "False", "For", "Friend", "Function", "Get", "GoSub", _
                "GoTo", "If", "Input", "Implements", "Integer", "Is", "Let", _
                "Lock", "Loop", "Long", "LSet", "New", "Next", "Nothing", _
                "Null", "Object", "On", "Open", "Option", "Optional", _
                "ParamArray", "Print", "Private", "Property", "Public", _
                "Put", "RaiseEvent", "ReDim", "Resume", "Return", "RSet", _
                "Seek", "Select", "Set", "Single", "Static", "Step", "Stop", _
                "String", "Sub", "Then", "To", "True", "Type", "Unlock", _
                "Until", "Variant", "Wend", "While", "With", "WithEvents", _
                "Write"
               
                Words(Word) = HTMLColorTag & Words(Word) & "</span>"
        End Select
    Next Word
   
    ' Reassemble return value from array.
    RetVal = Join(Words, WordDelimiter)
   
    ColorKeywords = RetVal
   
ExitRtn:
    Exit Function
ErrorRtn:
    mErrNo = Err.Number
    mErrDescr = Err.Description
    mErrSource = Err.Source
    If Left$(mErrDescr, 1) = "_" Then
        ' Business rule violation.
        mErrSource = ""
    ElseIf Len(mErrSource) > 0 And LCase$(mErrSource) <> LCase$(App.EXEName) Then
        ' Runtime error occurred in another procedure.
        mErrSource = App.Title & "." & mModuleName & "." & ProcedureName & vbNewLine & mErrSource
    Else
        ' Runtime error occurred in this procedure.
        mErrSource = App.Title & "." & mModuleName & "." & ProcedureName
    End If
    Err.Raise mErrNo, mErrSource, mErrDescr
End Function

Private Function IsBounded(ByVal ArrayToTest As Variant) As Boolean
    On Error Resume Next
    IsBounded = IsNumeric(UBound(ArrayToTest))
End Function

Private Function GetHTMLSpace() As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Returns a non-breaking HTML space sequence. Unless we create it
' programmatically it won't displayed when this code is shown on a Web page.
' That is, the browser will replace it with an actual space.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    On Error Resume Next
    GetHTMLSpace = "&" & "nbsp;"
End Function

Private Sub Form_Resize()
    Const RichTextBox1Top               As Long = 90
    Const RichTextBox1Left              As Long = 50
   
    Dim FormHeight                      As Long
    Dim FormWidth                       As Long
   
    On Error Resume Next

    If Me.WindowState <> vbMinimized Then
       
        With Me
            FormHeight = .Height
            FormWidth = .Width
        End With
       
        With RichTextBox1
            .Top = RichTextBox1Top
            .Left = RichTextBox1Left
            .Width = (FormWidth / 2) - 50
            .Height = FormHeight - 1000
        End With
       
        With RichTextBox2
            .Top = RichTextBox1Top
            .Left = RichTextBox1Left + RichTextBox1.Width + 50
            .Width = (FormWidth / 2) - 200
            .Height = FormHeight - 1000
        End With
       
        With Command1
            .Top = RichTextBox1.Top + RichTextBox1.Height + 50
            .Left = RichTextBox1Left + (RichTextBox1.Width / 2) - (.Width / 2)
        End With
    End If
End Sub

Update: this post has been re-published on my programming blog, Code Cache.