Recording Information in Windows Message Boxes

Have you ever taken a screen shot of a message box so that you could transcribe a long error message? Have you kept the message box open so you could write it down?

Here's a much easier and error-free method.

Simply copy the message box to the clipboard using Ctrl + C (i.e., hold down the Ctrl and C keys simultaneously). (Make sure the message box is the active window.) Then paste it into Notepad or other editor or document.



The message box shown above will look like this when pasted from the clipboard:

---------------------------
ODBC Error
---------------------------
Complicated ODBC error message.
---------------------------
OK
---------------------------

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

Formatting code for Visual Basic 6 (Update)

I modified the source code to reduce the the unsightly, excessive line-spacing. Now it looks more like real VB.

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.

Easy Error-handling in Microsoft Visual Basic 6

I developed a technique to handle VB6 runtime errors a number of years ago and it still serves me well. I am offering it to anyone who might find it useful.

Summary

It works by raising any runtime error up the call stack to the top-level procedure—which displays a message box showing the error description and call stack information. The call stack is suppressed if the error is designated as a business error (see below).

There are three error-handling templates. (By template I mean generic code that can be pasted directly into your procedures.)

One template is for "top-level" procedures (a top-level procedure is usually an event procedure). This template's error handler displays a message box.

The second template is placed in procedures that are neither top-level nor located in classes. Its error handler simply raises an error to the procedure that called it, adding itself to the call stack.

The third template, intended for classes, is similar to the second template, but also manages the vbObjectError constant.

Message Box and Call Stack

Sample:



Note that the message box title is the application title as defined in the IDE's menu under Project > Properties > Make > Title and accessed programmatically by the construct App.Title.

In the call stack, the top-level procedure is listed first, and the procedure in which the error occurred is listed last. Intermediate procedures are listed in the proper order. Sample call stack:

Error stack:
Sales Order Import.frmOrderProperties.Form_Load
Sales Order Import.frmOrderProperties.LoadControls

In this example, the runtime error occurred in the LoadControls method and the message box was displayed by the error handler of the Form_Load subroutine.

Business Errors

The templates have a provision for what I call business errors—errors that convey user-friendly or non-technical information. They aren't necessarily errors in the sense that something is wrong; they can be informative. Thus, call stack information is suppressed. In programmatic terms, a business error is defined by a leading underscore in the error description. The top-level template simply discards the underscore before displaying the message box. To raise a business error, write code like this:

Err.Raise 512, , "_File is incorrect format."

I don't bother with custom business error numbers because of the possibility that the same number is shared by different pieces of software used by the application. Because Visual Basic reserves for itself error numbers 0 to 511, my business errors always have the number 512.

Module Declarations

In addition, I recommend adding module-level variables to hold error values. You can make them local or even global if you prefer. Also, each module and procedure has a local constant that identifies the procedure name. The error handlers use this information to build the call-stack string.

Paste these declarations into every form, class, and code module. (Of course, you should substitute the name of each particular module into the mModuleName constant.)

Private Const mModuleName               As String = "frmOrderProperties"

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

Procedure Declarations

Define a constant to hold the procedure name. Also, be sure to add the On Error GoTo statement to make the error trap operational:

Const ProcedureName                 As String = "Form_Load"

On Error GoTo ErrorRtn

Notes on the Code

I use the ExitRtn label to enforce a single exit point from the procedure, which is handy if cleanup code is necessary (such code would go under the ExitRtn label). Thus, instead of calling Exit Sub I call GoTo ExitRtn. Another benefit is to avoid excessive nesting; instead of this:

If PKID <> "" Then
    ' Do stuff.
End If

I write this:

If PKID = "" Then
    GoTo ExitRtn
End If

' Do stuff.

The main logic (under the comment "Do stuff") is thus not nested inside the If . . . End If block and in the subsequent code the programmer is free to ignore the If . . . End If block, which reduces his mental clutter.

If you're wondering how I formatted the source code in this post, see "Formatting Visual Basic 6 code for HTML."

Top-Level Template

Paste this code into the bottom of your event procedures. I've shown the End Sub for completeness.

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

Second Template

This code goes at the bottom of non-class procedures that are not at the top level. Normally, these would be non-event-handling procedures that are outside classes.

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

Third Template

This code is for classes.

ExitRtn:
    Exit Sub
ErrorRtn:
    mErrNo = Err.Number
    mErrDescr = Err.Description
    mErrSource = Err.Source
    If Left$(mErrDescr, 1) = "_" Then
        ' Business rule violation.
        mErrSource = ""
    ElseIf ((mErrNo - vbObjectError < 0) Or (mErrNo - vbObjectError > 65535)) And (mErrNo >= vbObjectError) Then
        ' Error occurred in this procedure. Test for overflow error before adding constant.
        If mErrNo >= -262144 Then mErrNo = mErrNo + vbObjectError
        mErrSource = App.Title & "." & mModuleName & "." & ProcedureName
    Else
        ' Error occurred in another procedure.
        mErrSource = App.Title & "." & mModuleName & "." & ProcedureName & vbNewLine & mErrSource
    End If
    Err.Raise mErrNo, mErrSource, mErrDescr
End Sub

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