A simple RichTextBox-based source code colorizer (Part 2)
Some days ago I posted a simple RichTextBox-based source code colorizer, but after testing with big code snippets it happened that it didn't perform very well (it took several seconds), so I rewrote it from scratch. This time I use a low level approach and I compose the RTF text directly. The result algorithm performs very well (less than a second) for big code snippets and it works with the RichTextBox of .NET Framework which didn't support the SelectionBackColor property. Here is the code:
Public Class FormCodeColorizer
Private Sub ButtonColorize_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ButtonColorize.Click
Dim objDTE As EnvDTE.DTE
Dim objType As Type
objType = System.Type.GetTypeFromProgID("VisualStudio.DTE")
objDTE = CType(System.Activator.CreateInstance(objType), EnvDTE.DTE)
ColorizeRichText(objDTE, Me.RichTextBoxCode, "'", GetVBKeywords())
objDTE.Quit()
End Sub
Public Sub ColorizeRichText(ByVal objDTE As EnvDTE.DTE, ByVal ctlRichTextBox As RichTextBox, ByVal sCommentLinePrefix As String, ByVal colKeywords As Collections.Specialized.StringCollection)
Const DISPLAY_ITEM_PLAIN_TEXT As String = "Plain Text"
Const DISPLAY_ITEM_KEYWORD As String = "Keyword"
Const DISPLAY_ITEM_STRING As String = "String"
#If VS_8_0 Then
' PATCH: The Comment default color is wrong. We use the CSS Comment color instead
Const DISPLAY_ITEM_COMMENT As String = "CSS Comment"
#Else
Const DISPLAY_ITEM_COMMENT As String = "Comment"
#End If
Dim iSelectionStart As Integer
Dim iSelectionLength As Integer
Dim colFontsAndColorsItems As EnvDTE.FontsAndColorsItems = Nothing
Dim sFontFamily As String = ""
Dim sngFontSize As Single = 0.0
Dim objRtfHeaderStringBuilder As New System.Text.StringBuilder()
Dim objRtfBodyStringBuilder As New System.Text.StringBuilder()
Dim sLine As String
Dim sHeaderRtf As String
Dim sBodyRtf As String
Dim sPlainTextBackColorIndex As String = "1"
Dim sPlainTextForeColorIndex As String = "2"
Dim sKeywordBackColorIndex As String = "3"
Dim sKeywordForeColorIndex As String = "4"
Dim sCommentBackColorIndex As String = "5"
Dim sCommentForeColorIndex As String = "6"
Dim sStringBackColorIndex As String = "7"
Dim sStringForeColorIndex As String = "8"
Dim objPlainTextBackColor As Color
Dim objPlainTextForeColor As Color
Dim objKeywordBackColor As Color
Dim objKeywordForeColor As Color
Dim objCommentBackColor As Color
Dim objCommentForeColor As Color
Dim objStringBackColor As Color
Dim objStringForeColor As Color
Dim bPlainTextBold As Boolean
Dim bKeywordBold As Boolean
Dim bCommentBold As Boolean
Dim bStringBold As Boolean
Dim sKeyword As String
Dim sRtfKeywordBefore As String = ""
Dim sRtfKeywordAfter As String = ""
Dim sRtfBefore As String = ""
Dim sRtfAfter As String = ""
Dim sRtf As String
If GetTextEditorFontAndColorsItems(objDTE, sFontFamily, sngFontSize, colFontsAndColorsItems) Then
Try
' Cache selection position and length
iSelectionStart = ctlRichTextBox.SelectionStart
iSelectionLength = ctlRichTextBox.SelectionLength
GetColorsFromFontsAndColorsItems(colFontsAndColorsItems, DISPLAY_ITEM_PLAIN_TEXT, objPlainTextBackColor, objPlainTextForeColor, bPlainTextBold)
ctlRichTextBox.BackColor = objPlainTextBackColor
objRtfHeaderStringBuilder.Append("\rtf1") ' RTF Version 1.x
objRtfHeaderStringBuilder.Append("\ansi") ' ANSI
objRtfHeaderStringBuilder.Append("\deff0") ' Use font 0 as default
objRtfHeaderStringBuilder.Append("{\fonttbl") ' Font table group
objRtfHeaderStringBuilder.Append("{\f0") ' Font 0
objRtfHeaderStringBuilder.Append("\fnil") ' Use default font if specified font is not installed on the system
objRtfHeaderStringBuilder.Append("\fcharset0 ") ' Charset 0
objRtfHeaderStringBuilder.Append(sFontFamily) ' Font family name
objRtfHeaderStringBuilder.Append(";}") ' End font 0 definition
objRtfHeaderStringBuilder.Append("}") ' End font table group
objRtfHeaderStringBuilder.Append("{\colortbl ;") ' Color table group
' Add colors to table
AddColorsToRtfHeader(objRtfHeaderStringBuilder, colFontsAndColorsItems, DISPLAY_ITEM_PLAIN_TEXT, objPlainTextBackColor, objPlainTextForeColor, bPlainTextBold)
AddColorsToRtfHeader(objRtfHeaderStringBuilder, colFontsAndColorsItems, DISPLAY_ITEM_KEYWORD, objKeywordBackColor, objKeywordForeColor, bKeywordBold)
AddColorsToRtfHeader(objRtfHeaderStringBuilder, colFontsAndColorsItems, DISPLAY_ITEM_COMMENT, objCommentBackColor, objCommentForeColor, bCommentBold)
AddColorsToRtfHeader(objRtfHeaderStringBuilder, colFontsAndColorsItems, DISPLAY_ITEM_STRING, objStringBackColor, objStringForeColor, bStringBold)
objRtfHeaderStringBuilder.Append("}") ' ' End Color table group
objRtfHeaderStringBuilder.Append("\viewkind4") ' View Kind: Normal
objRtfHeaderStringBuilder.Append("\uc1") ' Unicode information
objRtfHeaderStringBuilder.Append("\pard") '
objRtfHeaderStringBuilder.Append("\tx270\tx540\tx810\tx1080\tx1350\tx1620\tx1890\tx2160\tx2430\tx2700") ' Tabulations
objRtfBodyStringBuilder.Append("\f0 ") ' Font 0
objRtfBodyStringBuilder.Append("\fs" & CType(sngFontSize * 2, Integer).ToString & " ") ' Font size in half points
If bPlainTextBold Then
objRtfBodyStringBuilder.Append("\b ")
End If
If ctlRichTextBox.Text = "" Then
objRtfBodyStringBuilder.Append("\par")
sBodyRtf = objRtfBodyStringBuilder.ToString
Else
For Each sLine In ctlRichTextBox.Lines
sLine = EscapeSpecialRTFCharacters(sLine)
objRtfBodyStringBuilder.Append(sLine) '
objRtfBodyStringBuilder.Append("\par") '
objRtfBodyStringBuilder.Append(ControlChars.Cr)
Next
sBodyRtf = objRtfBodyStringBuilder.ToString
' Colorize keywords
GetRtfBeforeAndAfter(objPlainTextBackColor, objPlainTextForeColor, bPlainTextBold, sPlainTextBackColorIndex, sPlainTextForeColorIndex, _
objKeywordBackColor, objKeywordForeColor, bKeywordBold, sKeywordBackColorIndex, sKeywordForeColorIndex, sRtfKeywordBefore, sRtfKeywordAfter)
If sRtfKeywordBefore <> "" Then
For Each sKeyword In colKeywords
' The \b regular expression means word boundary
sBodyRtf = System.Text.RegularExpressions.Regex.Replace(sBodyRtf, "\b" & sKeyword & "\b", sRtfKeywordBefore & sKeyword & sRtfKeywordAfter)
Next
End If
' Colorize strings
GetRtfBeforeAndAfter(objPlainTextBackColor, objPlainTextForeColor, bPlainTextBold, sPlainTextBackColorIndex, sPlainTextForeColorIndex, _
objStringBackColor, objStringForeColor, bStringBold, sStringBackColorIndex, sStringForeColorIndex, sRtfBefore, sRtfAfter)
If sRtfBefore <> "" Then
sBodyRtf = ColorizeTokenBetweenDelimiters(sBodyRtf, ControlChars.Quote, ControlChars.Quote, sRtfBefore, sRtfAfter, sRtfKeywordBefore, sRtfKeywordAfter)
End If
' Colorize comments
If sCommentLinePrefix <> "" Then
GetRtfBeforeAndAfter(objPlainTextBackColor, objPlainTextForeColor, bPlainTextBold, sPlainTextBackColorIndex, sPlainTextForeColorIndex, _
objCommentBackColor, objCommentForeColor, bCommentBold, sCommentBackColorIndex, sCommentForeColorIndex, sRtfBefore, sRtfAfter)
If sRtfBefore <> "" Then
sBodyRtf = ColorizeTokenBetweenDelimiters(sBodyRtf, sCommentLinePrefix, ControlChars.Cr, sRtfBefore, sRtfAfter, sRtfKeywordBefore, sRtfKeywordAfter)
End If
End If
End If
sHeaderRtf = objRtfHeaderStringBuilder.ToString
sRtf = "{" & sHeaderRtf & sBodyRtf & "}"
ctlRichTextBox.Rtf = sRtf
' Restore selection position and length
ctlRichTextBox.SelectionStart = iSelectionStart
ctlRichTextBox.SelectionLength = iSelectionLength
Catch objException As Exception
MessageBox.Show(objException.ToString)
End Try
End If
End Sub
Public Function GetVBKeywords() As System.Collections.Specialized.StringCollection
Dim colVBKeywords As New System.Collections.Specialized.StringCollection
colVBKeywords.Add("AddHandler")
colVBKeywords.Add("AddressOf")
colVBKeywords.Add("Alias")
colVBKeywords.Add("And")
colVBKeywords.Add("AndAlso")
colVBKeywords.Add("As")
colVBKeywords.Add("Boolean")
colVBKeywords.Add("ByRef")
colVBKeywords.Add("Byte")
colVBKeywords.Add("ByVal")
colVBKeywords.Add("Call")
colVBKeywords.Add("Case")
colVBKeywords.Add("Catch")
colVBKeywords.Add("CBool")
colVBKeywords.Add("CByte")
colVBKeywords.Add("CChar")
colVBKeywords.Add("CDate")
colVBKeywords.Add("CDec")
colVBKeywords.Add("CDbl")
colVBKeywords.Add("Char")
colVBKeywords.Add("CInt")
colVBKeywords.Add("Class")
colVBKeywords.Add("CLng")
colVBKeywords.Add("CObj")
colVBKeywords.Add("Const")
colVBKeywords.Add("Continue")
colVBKeywords.Add("CSByte")
colVBKeywords.Add("CShort")
colVBKeywords.Add("CSng")
colVBKeywords.Add("CStr")
colVBKeywords.Add("CType")
colVBKeywords.Add("CUInt")
colVBKeywords.Add("CULng")
colVBKeywords.Add("CUShort")
colVBKeywords.Add("Date")
colVBKeywords.Add("Decimal")
colVBKeywords.Add("Declare")
colVBKeywords.Add("Default")
colVBKeywords.Add("Delegate")
colVBKeywords.Add("Dim")
colVBKeywords.Add("DirectCast")
colVBKeywords.Add("Do")
colVBKeywords.Add("Double")
colVBKeywords.Add("Each")
colVBKeywords.Add("Else")
colVBKeywords.Add("ElseIf")
colVBKeywords.Add("End")
colVBKeywords.Add("EndIf")
colVBKeywords.Add("Enum")
colVBKeywords.Add("Erase")
colVBKeywords.Add("Error")
colVBKeywords.Add("Event")
colVBKeywords.Add("Exit")
colVBKeywords.Add("False")
colVBKeywords.Add("Finally")
colVBKeywords.Add("For")
colVBKeywords.Add("Friend")
colVBKeywords.Add("Function")
colVBKeywords.Add("Get")
colVBKeywords.Add("GetType")
colVBKeywords.Add("GetXMLNamespace")
colVBKeywords.Add("Global")
colVBKeywords.Add("GoSub")
colVBKeywords.Add("GoTo")
colVBKeywords.Add("Handles")
colVBKeywords.Add("If")
colVBKeywords.Add("Implements")
colVBKeywords.Add("Imports")
colVBKeywords.Add("In")
colVBKeywords.Add("Inherits")
colVBKeywords.Add("Integer")
colVBKeywords.Add("Interface")
colVBKeywords.Add("Is")
colVBKeywords.Add("IsNot")
colVBKeywords.Add("Let")
colVBKeywords.Add("Lib")
colVBKeywords.Add("Like")
colVBKeywords.Add("Long")
colVBKeywords.Add("Loop")
colVBKeywords.Add("Me")
colVBKeywords.Add("Mod")
colVBKeywords.Add("Module")
colVBKeywords.Add("MustInherit")
colVBKeywords.Add("MustOverride")
colVBKeywords.Add("MyBase")
colVBKeywords.Add("MyClass")
colVBKeywords.Add("Namespace")
colVBKeywords.Add("Narrowing")
colVBKeywords.Add("New")
colVBKeywords.Add("Next")
colVBKeywords.Add("Not")
colVBKeywords.Add("Nothing")
colVBKeywords.Add("NotInheritable")
colVBKeywords.Add("NotOverridable")
colVBKeywords.Add("Object")
colVBKeywords.Add("Of")
colVBKeywords.Add("On")
colVBKeywords.Add("Operator")
colVBKeywords.Add("Option")
colVBKeywords.Add("Optional")
colVBKeywords.Add("Or")
colVBKeywords.Add("OrElse")
colVBKeywords.Add("Overloads")
colVBKeywords.Add("Overridable")
colVBKeywords.Add("Overrides")
colVBKeywords.Add("ParamArray")
colVBKeywords.Add("Partial")
colVBKeywords.Add("Private")
colVBKeywords.Add("Property")
colVBKeywords.Add("Protected")
colVBKeywords.Add("Public")
colVBKeywords.Add("RaiseEvent")
colVBKeywords.Add("ReadOnly")
colVBKeywords.Add("ReDim")
colVBKeywords.Add("REM")
colVBKeywords.Add("RemoveHandler")
colVBKeywords.Add("Resume")
colVBKeywords.Add("Return")
colVBKeywords.Add("SByte")
colVBKeywords.Add("Select")
colVBKeywords.Add("Set")
colVBKeywords.Add("Shadows")
colVBKeywords.Add("Shared")
colVBKeywords.Add("Short")
colVBKeywords.Add("Single")
colVBKeywords.Add("Static")
colVBKeywords.Add("Step")
colVBKeywords.Add("Stop")
colVBKeywords.Add("String")
colVBKeywords.Add("Structure")
colVBKeywords.Add("Sub")
colVBKeywords.Add("SyncLock")
colVBKeywords.Add("Then")
colVBKeywords.Add("Throw")
colVBKeywords.Add("To")
colVBKeywords.Add("True")
colVBKeywords.Add("Try")
colVBKeywords.Add("TryCast")
colVBKeywords.Add("TypeOf")
colVBKeywords.Add("Variant")
colVBKeywords.Add("Wend")
colVBKeywords.Add("UInteger")
colVBKeywords.Add("ULong")
colVBKeywords.Add("UShort")
colVBKeywords.Add("Using")
colVBKeywords.Add("When")
colVBKeywords.Add("While")
colVBKeywords.Add("Widening")
colVBKeywords.Add("With")
colVBKeywords.Add("WithEvents")
colVBKeywords.Add("WriteOnly")
colVBKeywords.Add("Xor")
colVBKeywords.Add("#Const")
colVBKeywords.Add("#Else")
colVBKeywords.Add("#ElseIf")
colVBKeywords.Add("#End")
colVBKeywords.Add("#If")
Return colVBKeywords
End Function
Public Function GetTextEditorFontAndColorsItems(ByVal objDTE As EnvDTE.DTE, ByRef r_sFontFamily As String, ByRef r_sngFontSize As Single, ByRef r_colFontsAndColorsItems As EnvDTE.FontsAndColorsItems) As Boolean
Const CATEGORY_FONTS_AND_COLORS As String = "FontsAndColors"
Const PAGE_TEXT_EDITOR As String = "TextEditor"
Const PROPERTY_FONT_SIZE As String = "FontSize"
Const PROPERTY_FONT_FAMILY As String = "FontFamily"
Const PROPERTY_FONTS_AND_COLORS_ITEMS As String = "FontsAndColorsItems"
Dim colProperties As EnvDTE.Properties
Dim objValue As Object
Dim bResult As Boolean = False
Try
colProperties = objDTE.Properties(CATEGORY_FONTS_AND_COLORS, PAGE_TEXT_EDITOR)
If Not (colProperties Is Nothing) Then
objValue = colProperties.Item(PROPERTY_FONT_FAMILY).Value
r_sFontFamily = objValue.ToString
objValue = colProperties.Item(PROPERTY_FONT_SIZE).Value
r_sngFontSize = CType(objValue, Single)
objValue = colProperties.Item(PROPERTY_FONTS_AND_COLORS_ITEMS).Object
r_colFontsAndColorsItems = DirectCast(objValue, EnvDTE.FontsAndColorsItems)
bResult = True
End If
Catch objException As Exception
MessageBox.Show(objException.ToString)
End Try
Return bResult
End Function
Public Sub GetColorsFromFontsAndColorsItems(ByVal colFontsAndColorsItems As EnvDTE.FontsAndColorsItems, ByVal sDisplayItem As String, ByRef r_objBackColor As Color, ByRef r_objForeColor As Color, ByRef r_bBold As Boolean)
Dim colColorableItems As EnvDTE.ColorableItems
Dim iOleColor As Integer
colColorableItems = colFontsAndColorsItems.Item(sDisplayItem)
iOleColor = System.Convert.ToInt32(colColorableItems.Background)
r_objBackColor = System.Drawing.ColorTranslator.FromOle(iOleColor)
iOleColor = System.Convert.ToInt32(colColorableItems.Foreground)
r_objForeColor = System.Drawing.ColorTranslator.FromOle(iOleColor)
r_bBold = colColorableItems.Bold
End Sub
Public Sub AddColorsToRtfHeader(ByVal objRtfHeaderStringBuilder As System.Text.StringBuilder, ByVal objBackColor As Color, ByVal objForeColor As Color)
AddColorToRtfHeader(objRtfHeaderStringBuilder, objBackColor)
AddColorToRtfHeader(objRtfHeaderStringBuilder, objForeColor)
End Sub
Public Sub AddColorsToRtfHeader(ByVal objRtfHeaderStringBuilder As System.Text.StringBuilder, ByVal colFontsAndColorsItems As EnvDTE.FontsAndColorsItems, ByVal sDisplayItem As String, ByRef r_objBackColor As Color, ByRef r_objForeColor As Color, ByRef r_bBold As Boolean)
GetColorsFromFontsAndColorsItems(colFontsAndColorsItems, sDisplayItem, r_objBackColor, r_objForeColor, r_bBold)
AddColorsToRtfHeader(objRtfHeaderStringBuilder, r_objBackColor, r_objForeColor)
End Sub
Public Sub AddColorToRtfHeader(ByVal objRtfHeaderStringBuilder As System.Text.StringBuilder, ByVal objColor As Color)
objRtfHeaderStringBuilder.Append("\red") '
objRtfHeaderStringBuilder.Append(objColor.R.ToString) '
objRtfHeaderStringBuilder.Append("\green") '
objRtfHeaderStringBuilder.Append(objColor.G.ToString) '
objRtfHeaderStringBuilder.Append("\blue") '
objRtfHeaderStringBuilder.Append(objColor.B.ToString) '
objRtfHeaderStringBuilder.Append(";")
objRtfHeaderStringBuilder.Append(ControlChars.Cr)
End Sub
Public Function EscapeSpecialRTFCharacters(ByVal sLine As String) As String
Dim sResult As String
sResult = sLine
If Not (sResult Is Nothing) Then
sResult = sResult.Replace("\", "\\")
sResult = sResult.Replace("{", "\{")
sResult = sResult.Replace("}", "\}")
End If
Return sResult
End Function
Public Sub GetRtfBeforeAndAfter(ByVal objPlainTextBackColor As Color, ByVal objPlainTextForeColor As Color, ByVal bPlainTextBold As Boolean, _
ByVal sPlainTextBackColorIndex As String, ByVal sPlainTextForeColorIndex As String, _
ByVal objTokenBackColor As Color, ByVal objTokenForeColor As Color, ByVal bTokenBold As Boolean, _
ByVal sTokenBackColorIndex As String, ByVal sTokenForeColorIndex As String, _
ByRef r_sRtfBefore As String, ByRef r_sRtfAfter As String)
r_sRtfBefore = ""
r_sRtfAfter = ""
If Not objTokenBackColor.Equals(objPlainTextBackColor) Then
r_sRtfBefore &= "\highlight" & sTokenBackColorIndex & " "
r_sRtfAfter &= "\highlight" & sPlainTextBackColorIndex & " "
End If
If Not objTokenForeColor.Equals(objPlainTextForeColor) Then
r_sRtfBefore &= "\cf" & sTokenForeColorIndex & " "
r_sRtfAfter &= "\cf" & sPlainTextForeColorIndex & " "
End If
If bTokenBold <> bPlainTextBold Then
If bTokenBold Then
r_sRtfBefore &= "\b "
r_sRtfAfter &= "\b0 "
Else
r_sRtfBefore &= "\b0 "
r_sRtfAfter &= "\b "
End If
End If
End Sub
Public Function ColorizeTokenBetweenDelimiters(ByVal sInput As String, ByVal sDelimiter1 As String, ByVal sDelimiter2 As String, ByVal sRtfBefore As String, ByVal sRtfAfter As String, ByVal sRtfKeywordBefore As String, ByVal sRtfKeywordAfter As String) As String
Dim iStartPositionSearch1 As Integer
Dim iStartPositionSearch2 As Integer
Dim iDelimiterPos1 As Integer
Dim iDelimiterPos2 As Integer
Dim sToken As String
Dim objStringBuilder As New System.Text.StringBuilder()
iStartPositionSearch1 = 0
Do
If iStartPositionSearch1 >= sInput.Length Then
Exit Do
Else
' Find the first delimiter
iDelimiterPos1 = sInput.IndexOf(sDelimiter1, iStartPositionSearch1)
If iDelimiterPos1 = -1 Then ' Not found
' Add the remaining string before exiting
objStringBuilder.Append(sInput.Substring(iStartPositionSearch1))
Exit Do
Else
' Add the consumed string until the found hit
If iDelimiterPos1 > iStartPositionSearch1 Then
objStringBuilder.Append(sInput.Substring(iStartPositionSearch1, iDelimiterPos1 - iStartPositionSearch1))
End If
' Find the second delimiter
iStartPositionSearch2 = iDelimiterPos1 + sDelimiter1.Length
If iStartPositionSearch2 < sInput.Length Then
iDelimiterPos2 = sInput.IndexOf(sDelimiter2, iStartPositionSearch2)
Else
iDelimiterPos2 = -1
End If
If iDelimiterPos2 = -1 Then
' Not found, so we assume it means until the end of text.
' This is the case of comments, which use Cr (carriage return) as delimiter2 as the token delimiter. We must
' colorize the comment even if it is the last line and no carriage return is used.
sToken = sInput.Substring(iDelimiterPos1)
Else
sToken = sInput.Substring(iDelimiterPos1, iDelimiterPos2 - iDelimiterPos1 + sDelimiter2.Length)
End If
' Remove the existing keyword colorization that may exist
If sRtfKeywordBefore <> "" Then
sToken = sToken.Replace(sRtfKeywordBefore, "")
sToken = sToken.Replace(sRtfKeywordAfter, "")
End If
' Add the token and its colorization
If sRtfBefore <> "" Then
objStringBuilder.Append(sRtfBefore)
End If
objStringBuilder.Append(sToken)
If sRtfAfter <> "" Then
objStringBuilder.Append(sRtfAfter)
End If
If iDelimiterPos2 = -1 Then ' The delimiter was not found, so we are done
Exit Do
Else ' Prepare for the next loop
iStartPositionSearch1 = iDelimiterPos2 + sDelimiter2.Length
End If
End If
End If
Loop
Return objStringBuilder.ToString
End Function
End Class