[This item was previously posted as a Facebook note. However, this will be the authoritative version in case of updates or corrections.]
Is mayor-elect Rob Ford a bigot?
What is the evidence that Toronto mayor-elect Rob Ford has mounted an "assault on gay people" (or is a bigot)?
1. An anonymous pro-Ford, anti-gay-marriage Tamil radio ad was aired for one day.
Ford can't be held morally accountable for the actions of others. Furthermore, he disapproved of the ad, saying, "It is not good for politics, generally speaking. It is just bad. I don't condone that sort of behaviour. I can't control it; you don't know who they are. There is no name attached to them" (source: CTV.ca).
2. Signs saying "Should Muslim vote for him who married a man? [sic]" were posted anonymously at Danforth and Victoria Park Ave.
According to CTV News, "It is unknown who is responsible for the signs." Without a connection to Ford, the signs can't in good faith be held against him.
3. He called homosexuality a "lifestyle choice."
On Twitter, Ford said, "I do not condone the recent Tamil Radio ad. I support diversity & have no issue with others' lifestyle choices."
Although homosexuality may not be a choice, thinking otherwise is at worst only an error, which is a long way from assault or bigotry.
4. He endorsed the views of fundamentalist Christian pastor Wendell Brereton.
"I support traditional marriage. I always have. But if people want to, to each their own. I’m not worried about what people do in their private life. I look out for taxpayers' money," Ford said (source: CTV.ca).
Support for traditional marriage does not mean opposition to gay marriage. "To each their own," said Ford, articulating the antithesis of bigotry.
Ford also said about Pastor Brereton, "We’re together. We have the same thoughts (source: CTV.ca)," the implication being that Ford agrees with Brereton about literally everything, including marginal views held by the latter. This is silly. Because no two people agree on everything, it is impossible to conclude which specific views they share without consulting them or their statements.
The pastor's allegedly odious view is paraphrased by CTV.ca in a manner calculated to discredit Ford (which is wrong in a news story); here is the article's lead sentence: "Rob Ford’s long-held belief in traditional marriage has exploded into a campaign issue now that he has endorsed the views of a fundamentalist Christian pastor who suggested online that same-sex marriage could 'dismantle' a 'healthy democratic civilization.'"
This is a spineless accusation using weasel words. Suggested and could are hardly indicative of fanaticism or unreasonableness; indeed, we don't know the context of these remarks. Even if one objects to the pastor's words in every possible context (which is unreasonable; nobody can live up to such a standard), Ford is not responsible for them. In any case, if this is the least flattering way to summarize Brereton's views on homosexuality, one has to ask, is that it?
Incidentally, the gay marriage issue is really about the role of the state in marriage. If marriage were private, it would be immune to legal proscription, and opposition to gay marriage would be restricted to mere words. Also, insofar as marriage is tied into government and its infrastructure, taxpayers will feel entitled to have their views enforced, even though the only practical effect of this is to grant them the power to erect legal obstacles. As Ford says, it's a private matter.
5. He voted against public funding for AIDS education in 2006 and against public funding for Toronto's Gay Pride parade in 2007.
If a cause is worthy, people will fund it voluntarily. Public funding, on the other hand, is drawn from tax money, which is extorted from citizens and spent in ways with which they may disagree.
6. Ford supporters Arnie Lemaire and Kathy Shaidle made fun of Islam.
According to Toronto Life, "Rob Ford's team isn't attached with this [i.e., with Blazingcatfur blog's "Everybody Draw Mohammed Day Contest] . . ."
Warren Kinsella alleges that Lemaire and his wife have been "at the forefront of his online campaign strategy. . . ." Unfortunately for Ford's detractors, the associated link leads to a blog post that lays out the evidence that a computer at the Toronto Star was used to edit Ford's Wikipedia entry to Ford's detriment (see also "Computer inside Toronto Star company edited Rob Ford’s Wikipedia entry", National Post, 8/17/10).
Again we see the false argument that a person is responsible for the acts of others.
Should religious people be immune to irreverence, as is implied here (Islam), or should they be castigated for opposing gay marriage (Islam and some Christian sects)? Anti-Fordites seem to want it both ways.
7. Ford has not denounced Arnie Lemaire.
He has no obligation to do so. Moreover, a non-action (not condemning someone) cannot be construed in good faith as an attack or as bigotry.
8. Ford stated in 2006 that "It [AIDS] is very preventable. If you are not doing needles and you are not gay, you wouldn’t get AIDS probably, that's the bottom line. . . . These are the facts."
In the Citytv.com story, the reporter responded in the next line with: "According to the United Nations, the majority of those affected with AIDS are heterosexual, non-drug users." But this isn't a refutation of Ford, for even if the UN is right, it doesn't contradict the fact that gays contract AIDS in disproportionately greater numbers than heterosexuals. (I'm ignoring drug-users, as comparable stats are hard to find.) Therefore, gays have a greater probability of contracting AIDS, vindicating Ford.
How much greater? Only 1.1% of Canadians aged 18 to 59 surveyed in 2009 by Statistics Canada consider themselves homosexual (0.9% reported being bisexual) (source: "Gay Pride... by the numbers," Statistics Canada, 2010). Results from 1994 are similar: 1.5% homosexual, 94% heterosexual, 5% unstated (ibid.). Thus, there are anywhere from 15.6 times (if 6% are gay) to 85.4 times (if 1.1% are gay) more heterosexuals than gays in Canada (if 94% are heterosexual). "At the end of 2006, MSM [men who have sex with men] accounted for 76.1% of cumulative reported AIDS cases among adult males" (Source: "Populations at Risk", Public Health Agency of Canada, 2007). Thus, Canadian MSM have historically contracted AIDS at rate that is from roughly 49.8 to 272.0 times greater than that of Canadian heterosexuals. (I've ignored female homosexuals with AIDS, as the stats are hard to find, but female homosexuality is less risky, so my numbers are somewhat off.)
Therefore, Ford's contention that non-gays are less likely to contract AIDS is correct.
9. In 2008, Ford said, "Those Oriental people work like dogs… They sleep beside their machines… The Oriental people, they’re slowly taking over… They’re hard, hard workers."
Obviously, working like a dog means working hard. Everyone knows this. Ford even clarified. "When I said working like a dog, I was brought up, my father told me every day to 'Get out of bed and work like a dog, son.' A dog means you’re a hard worker" (The Globe and Mail).
Who is supposed to be the victim of Ford's remark? Asians, for being characterized as hard workers, or the rest of us, whom Ford thinks may not be as diligent?
Is it bigoted to attribute superior qualities to a different culture or people? Definition of bigot: "One who is strongly partial to one's own group, religion, race, or politics and is intolerant of those who differ." The answer is no.
Oriental may be politically incorrect, but it is not an insult. The word means eastern, just as the little-used Occidental is western. From a dictionary usage note:
"The usual objection to Oriental—meaning 'eastern'—is that it identifies Asian countries and peoples in terms of their location relative to Europe. However, this objection is not generally made of other Eurocentric terms such as Near and Middle Eastern. The real problem with Oriental is more likely its connotations stemming from an earlier era when Europeans viewed the regions east of the Mediterranean as exotic lands full of romance and intrigue, the home of despotic empires and inscrutable customs. At the least these associations can give Oriental a dated feel, and as a noun in contemporary contexts (as in the first Oriental to be elected from the district) it is now widely taken to be offensive. However, Oriental should not be thought of as an ethnic slur to be avoided in all situations. As with Asiatic, its use other than as an ethnonym, in phrases such as Oriental cuisine or Oriental medicine, is not usually considered objectionable."
It is a fact—not an insult—that Asia is east of Europe (or that Europe is west of Asia). Implications of exoticism and romance are not troubling. Despotic empires still exist in Asia. Inscrutable customs refers to cultural differences, and no one would deny that such differences still exist. A dated feel? This is grasping at gossamer handles.
Despite this, Ford himself later corrected his use of the word, likely to placate those who simply accept political correctness without questioning it. (Political correctness is the creed of the coward insofar as it avoids plain-speaking and truth.)
The evidence that he is a bigot is just not there. Even Ontario cabinet minister Glen Murray, a capital-L Liberal and a Ford opponent, agrees. "I do not believe Rob Ford or Stephen Harper or Tim Hudak are bigots," he wrote on Oct. 26.
Friday, November 5, 2010
Friday, October 24, 2008
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.
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.
Friday, October 17, 2008
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.
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.
Thursday, October 9, 2008
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:
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.
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.
Subscribe to:
Posts (Atom)
