Imports System.Text.RegularExpressions
Imports System.ComponentModel
Public Class HtmlTextBox
Inherits RichTextBox
Implements ICloneable
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As IntPtr, ByVal wMsg As Integer, _
ByVal wParam As Integer, ByVal lParam As Integer) As Integer
Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hWnd As Integer) As Integer
Private Shared TagRegex As New Regex("\<(?<TagName>[\w\d]+)\s*(\s*(?<Attribute>[\-\w]+)\s*\=\s*(?<Value>((?<Q>(""|')).*?\k<Q>|\S+))\s*|\s*(?<Attribute>\[\w+\])\s*)*\>", RegexOptions.Multiline)
Private Shared CloseTagRegex As New Regex("\<\/(?<TagName>[\w\d]+)\>", RegexOptions.Multiline)
Private Shared CommentRegex As New Regex("\<\!\-\-.+?\-\-\>", RegexOptions.Multiline)
Private _HtmlChangedEnabled As Boolean = True
Private _SyntaxHighlightingEnabled As Boolean = True
Private _IsBusy As Boolean
Private _TagColor As Color = Color.Blue
Private _AttributeColor As Color = Color.Red
Private _BooleanAttributeColor As Color = Color.Orange
Private _ValueColor As Color = Color.Purple
Private _CommentColor As Color = Color.Green
Private _TagFont As Font = Me.Font
Private _AttributeFont As Font = Me.Font
Private _BooleanAttributeFont As Font = Me.Font
Private _ValueFont As Font = Me.Font
Private _CommentFont As Font = Me.Font
Private _RtfLines() As String
Public Event HtmlChanged As EventHandler
Public Property HtmlChangedEnabled() As Boolean
Get
Return _HtmlChangedEnabled
End Get
Set(ByVal value As Boolean)
_HtmlChangedEnabled = value
End Set
End Property
Public Property SyntaxHighlightingEnabled() As Boolean
Get
Return _SyntaxHighlightingEnabled
End Get
Set(ByVal value As Boolean)
_SyntaxHighlightingEnabled = value
End Set
End Property
<Browsable(True), Description("The color with which tags are highlighted.")> _
Public Property TagColor() As Color
Get
Return _TagColor
End Get
Set(ByVal Value As Color)
_TagColor = Value
End Set
End Property
<Browsable(True), Description("The color with which attributes are highlighted.")> _
Public Property AttributeColor() As Color
Get
Return _AttributeColor
End Get
Set(ByVal Value As Color)
_AttributeColor = Value
End Set
End Property
<Browsable(True), Description("The color with which boolean attributes are highlighted.")> _
Public Property BooleanAttributeColor() As Color
Get
Return _BooleanAttributeColor
End Get
Set(ByVal Value As Color)
_BooleanAttributeColor = Value
End Set
End Property
<Browsable(True), Description("The color with which attributes' values are highlighted.")> _
Public Property ValueColor() As Color
Get
Return _ValueColor
End Get
Set(ByVal value As Color)
_ValueColor = value
End Set
End Property
Public Property CommentColor() As Color
Get
Return _CommentColor
End Get
Set(ByVal value As Color)
_CommentColor = value
End Set
End Property
<Browsable(True), Description("The font with which tags are highlighted.")> _
Public Property TagFont() As Font
Get
Return _TagFont
End Get
Set(ByVal Value As Font)
_TagFont = Value
End Set
End Property
<Browsable(True), Description("The font with which attributes are highlighted.")> _
Public Property AttributeFont() As Font
Get
Return _AttributeFont
End Get
Set(ByVal Value As Font)
_AttributeFont = Value
End Set
End Property
<Browsable(True), Description("The font with which boolean attributes are highlighted.")> _
Public Property BooleanAttributeFont() As Font
Get
Return _BooleanAttributeFont
End Get
Set(ByVal Value As Font)
_BooleanAttributeFont = Value
End Set
End Property
<Browsable(True), Description("The font with which attributes' values are highlighted.")> _
Public Property ValueFont() As Font
Get
Return _ValueFont
End Get
Set(ByVal Value As Font)
_ValueFont = Value
End Set
End Property
Public Property CommentFont() As Font
Get
Return _CommentFont
End Get
Set(ByVal value As Font)
_CommentFont = value
End Set
End Property
<Browsable(True), Description("The font of the control.")> _
Public Shadows Property Font() As Font
Get
Return MyBase.Font
End Get
Set(ByVal value As Font)
Me.TagFont = value
Me.AttributeFont = value
Me.BooleanAttributeFont = value
Me.ValueFont = value
MyBase.Font = value
End Set
End Property
Public ReadOnly Property IsBusy() As Boolean
Get
Return _IsBusy
End Get
End Property
Public ReadOnly Property CurrentLineIndex() As Int32
Get
Return Me.GetLineFromCharIndex(Me.SelectionStart)
End Get
End Property
Public ReadOnly Property RtfLines() As String()
Get
Return _RtfLines
End Get
End Property
Public ReadOnly Property RtfCurrentLineIndex() As Int32
Get
Return Me.CurrentLineIndex + 2
End Get
End Property
'Contiene costanti usate nell'inviare messaggi all'API di windows
Private Enum EditMessages
LineIndex = 187
LineFromChar = 201
GetFirstVisibleLine = 206
CharFromPos = 215
PosFromChar = 1062
End Enum
Protected Overrides Sub OnTextChanged(ByVal e As EventArgs)
'Non colora tutte le linee visibili, bensì solo la riga dove si
'trova il cursorse: in questo modo l'applicazione risulta più
'veloce. L'unico caso in cui questo approccio non funzione è
'quando si copia un testo all'interno della richtextbox. In
'quel caso ci sarà un pulsante apposito
If Me.HtmlChangedEnabled Then
Dim LineIndex As Int32 = Me.GetLineFromCharIndex(Me.SelectionStart)
Me.ColorLineNumber(LineIndex)
RaiseEvent HtmlChanged(Me, EventArgs.Empty)
End If
End Sub
Friend Sub UpdateRtfLines()
_RtfLines = Me.Rtf.Split(vbCrLf)
End Sub
'Colora tutta la RichTextBox
Public Sub ColorRtb()
For I As Int32 = 0 To Me.Lines.Length - 1
ColorLineNumber(I)
Next
End Sub
'Colora solo le linee visibili
Public Sub ColorVisibleLines()
Dim FirstLine As Integer = FirstVisibleLine()
Dim LastLine As Integer = LastVisibleLine()
If (FirstLine = 0) And (LastLine = 0) Then
'Non c'è testo
Exit Sub
Else
While FirstLine < LastLine
ColorLineNumber(FirstLine)
FirstLine += 1
End While
End If
End Sub
'Questa è la nuova versione: nelle stesso condizioni sopra citate,
'impiega 50ms, quasi la metà! L'algoritmo vecchio per SQl
'ne impiegava 10, ma non era in grado di supportare tag vicini
'come quelli dell'HTML
Public Sub ColorLineNumber(ByVal LineIndex As Int32)
Try
If Me.Lines(LineIndex).Length = 0 Then
Exit Sub
End If
Catch Ex As Exception
Exit Sub
End Try
If Me.SyntaxHighlightingEnabled = False Then
Exit Sub
End If
Dim PrevState As Boolean = Me.HtmlChangedEnabled
Me.HtmlChangedEnabled = False
_IsBusy = True
'Indice del primo carattere della linea
Dim FirstCharIndex As Int32 = _
Me.GetFirstCharIndexFromLine(LineIndex)
'Tiene traccia del cursore
Dim SelectionAt As Integer = Me.SelectionStart
Dim Line As String = Me.Lines(LineIndex)
Dim Tags As MatchCollection = TagRegex.Matches(Line)
Dim ClosedTags As MatchCollection = CloseTagRegex.Matches(Line)
Dim Comments As MatchCollection = CommentRegex.Matches(Line)
'Blocca il refresh
LockWindowUpdate(Me.Handle.ToInt32)
Me.Select(FirstCharIndex, Line.Length)
Me.SelectionColor = Me.ForeColor
Me.SelectionFont = Me.Font
Me.DeselectAll()
For Each Tag As Match In Tags
With Tag.Groups("TagName")
'-1 per comprendere anche il "<" iniziale
Me.Select(FirstCharIndex + .Index - 1, .Length + 1)
Me.SelectionColor = Me.TagColor
Me.SelectionFont = Me.TagFont
End With
If Tag.Groups("Attribute") IsNot Nothing Then
For Each C As Capture In Tag.Groups("Attribute").Captures
Me.Select(FirstCharIndex + C.Index, C.Length)
If C.Value.StartsWith("[") Then
Me.SelectionColor = Me.BooleanAttributeColor
Me.SelectionFont = Me.BooleanAttributeFont
Else
Me.SelectionColor = Me.AttributeColor
Me.SelectionFont = Me.AttributeFont
End If
Next
For Each C As Capture In Tag.Groups("Value").Captures
Me.Select(FirstCharIndex + C.Index, C.Length)
Me.SelectionColor = Me.ValueColor
Me.SelectionFont = Me.ValueFont
Next
End If
'Colora il ">" finale
Me.Select(FirstCharIndex + Tag.Index + Tag.Length - 1, 1)
Me.SelectionColor = Me.TagColor
Me.SelectionFont = Me.TagFont
Me.DeselectAll()
Next
For Each ClosedTag As Match In ClosedTags
With ClosedTag.Groups("TagName")
'-2 per comprendere anche il "</" iniziale
Me.Select(FirstCharIndex + .Index - 2, .Length + 3)
Me.SelectionColor = Me.TagColor
Me.SelectionFont = Me.TagFont
End With
Me.DeselectAll()
Next
For Each Comment As Match In Comments
Me.Select(FirstCharIndex + Comment.Index, Comment.Length)
Me.SelectionColor = Me.CommentColor
Me.SelectionFont = Me.CommentFont
Me.DeselectAll()
Next
'Ripristina la selezione
Me.SelectionStart = SelectionAt
Me.SelectionLength = 0
'E il colore
Me.SelectionColor = Me.ForeColor
'Riprende il refresh
LockWindowUpdate(0)
Me.HtmlChangedEnabled = PrevState
_IsBusy = False
End Sub
Public Sub ColorCurrentLine()
Me.ColorLineNumber(Me.GetLineFromCharIndex(Me.SelectionStart))
End Sub
'Ottiene la prima linea visibile
Public Function FirstVisibleLine() As Integer
Return SendMessage(Me.Handle, EditMessages.GetFirstVisibleLine, 0, 0)
End Function
'Ottiene l'ultima linea visibile
Public Function LastVisibleLine() As Integer
Dim LastLine As Integer = FirstVisibleLine() + _
(Me.Height / Me.Font.Height)
If LastLine > Me.Lines.Length Or LastLine = 0 Then
LastLine = Me.Lines.Length
End If
Return LastLine
End Function
Private Function CloneMe() As Object Implements System.ICloneable.Clone
Return Me.MemberwiseClone
End Function
Public Function Clone() As HTML_IntelliSense.HtmlTextBox
Return Me.CloneMe
End Function
End Class
