Re: Is there a way to prevent a RichTextBox from scrolling?

// this is a class for syntax highlighting
// i found somewhere because i had the same problem.
// you should have a try. take a look at setscrollpos:



Public Class cRTBWrapper
' Scrollbar direction
Const SBS_HORZ = 0
Const SBS_VERT = 1

' Windows Messages
Const WM_VSCROLL = &H115
Const WM_HSCROLL = &H114
Const SB_THUMBPOSITION = 4

' This is just a class structore that holds syntax options
Public Class tDict
Private _Pattern As String
Private _isRegex As Boolean
Private _ignoreCase As Boolean
Private _color As Integer

Public Sub New(ByVal thispattern As String, ByVal thisregex As
Boolean, ByVal thisCase As Boolean, ByVal thisColor As Integer)
_Pattern = thispattern
_isRegex = thisregex
_ignoreCase = thisCase
_color = thisColor
End Sub

Public Property pattern() As String
Get
Return _Pattern
End Get
Set(ByVal Value As String)
_Pattern = Value
End Set
End Property

Public Property isRegex() As Boolean
Get
Return _isRegex
End Get
Set(ByVal Value As Boolean)
_isRegex = Value
End Set
End Property

Public Property ignoreCase() As Boolean
Get
Return _ignoreCase
End Get
Set(ByVal Value As Boolean)
_ignoreCase = Value
End Set
End Property

Public Property color() As Integer
Get
Return _color
End Get
Set(ByVal Value As Integer)
_color = Value
End Set
End Property

End Class

' This is just a dictionary class used to store your color info
Public Class cDict
Inherits CollectionBase

Sub New()
End Sub

Sub add(ByVal Pattern As String, ByVal isRegex As Boolean, ByVal
isCase As Boolean, ByVal value As Integer)
If exists(Pattern) = -1 Then
list.Add(New tDict(Pattern, isRegex, isCase, value))
End If
End Sub

Public Property item(ByVal index As Integer) As Integer
Get
Return list(index)
End Get
Set(ByVal Value As Integer)
list(index) = Value
End Set
End Property

Function exists(ByVal lookup As String) As Integer
Dim entry As tDict

For Each entry In list
If entry.pattern = lookup Then Return entry.color
Next

Return -1
End Function

Function index(ByVal lookup As String) As Integer
Dim entry As tDict
Dim thisIndex = 1

For Each entry In list
If entry.pattern = lookup Then Return thisIndex
thisIndex += 1
Next

Return -1 ' Make it black
End Function
End Class

' This is just a list class used to store the headers color info
Private Class cList
Inherits CollectionBase

Sub New()
End Sub

Sub add(ByVal item As Integer)
If exists(item) = -1 Then
list.Add(item)
' Console.WriteLine("New color: " & item)
End If
End Sub

Public Property item(ByVal index As Integer) As Integer
Get
Return list(index)
End Get
Set(ByVal Value As Integer)
list(index) = Value
' Console.WriteLine("Setting color")
End Set
End Property

Function exists(ByVal lookup As Integer) As Integer
Dim current As Integer

If list.Count <> 0 Then
For current = 0 To list.Count - 1
Dim compare As Color = Color.FromArgb(lookup)
Dim source As Color = Color.FromArgb(list(current))

' This is very strange, the samme RGB color can have
diffrent
' ARGB values ???? Maybe its reporting 'A'
diffrently, oh well
' lets just work around that little feature

If compare.R = source.R And _
compare.G = source.G And _
compare.B = source.B Then
Return current
End If
Next
End If

Return -1
End Function
End Class

' This is just a class used to store the position info
Public Class cPosition
Public Cursor As Integer
Public CurrentLine As Integer
Public LinePosition As Integer
Public xScroll As Integer
Public yScroll As Integer
End Class

' Public events
Public Event position(ByVal PositionInfo As cPosition)

' Vars
Private WithEvents _bind As RichTextBox
Public rtfSyntax As New cDict
Private rtfColors As New cList
Private rtfHeader As String
Private rtfBody() As String
Private txtBody() As String
Private CursorPosition As cPosition
Private RTFDebug As Boolean = True


'--------------------------------------------------------------------------
' Sub: New
' Purpose: This was the most chalanging part of the entire project.
' How to write this, humm. Maybe i'll save it till later.
' Ya, later!
'
Public Sub New()
End Sub

'--------------------------------------------------------------------------
' Sub: Bind
' Purpose: Provide access to the object and its events
'
Public Sub bind(ByVal rtb As RichTextBox)
_bind = rtb
AddHandler _bind.KeyUp, AddressOf update
AddHandler _bind.MouseUp, AddressOf update
AddHandler _bind.TextChanged, AddressOf update
End Sub

'--------------------------------------------------------------------------
' API: GetScrollPos
' Purpose: Returns an integer of the position of the scrollbar
'
Private Declare Function GetScrollPos Lib "user32.dll" ( _
ByVal hWnd As IntPtr, _
ByVal nBar As Integer) As Integer

'--------------------------------------------------------------------------
' API: SetScrollPos
' Purpose: Sets the scrollbars to a certin value
'
Private Declare Function SetScrollPos Lib "user32.dll" ( _
ByVal hWnd As IntPtr, ByVal nBar As Integer, _
ByVal nPos As Integer, ByVal bRedraw As Boolean) As Integer

'--------------------------------------------------------------------------
' API: PostMessageA
' Purpose: Sends a message to a control
'
Private Declare Function PostMessageA Lib "user32.dll" ( _
ByVal hwnd As IntPtr, ByVal wMsg As Integer, _
ByVal wParam As Integer, ByVal lParam As Integer) As Boolean

'--------------------------------------------------------------------------
' API: LockWindowUpdate
' Purpose: Locks or Unlocks a window
'
Private Declare Function LockWindowUpdate Lib "user32.dll" (ByVal
hwnd As Long) As Long

'--------------------------------------------------------------------------
' Sub: Update
' Purpose: Reports the curssor position (Customized for word wrap
support)
'
Private Overloads Sub update()
CursorPosition = getCurrentPosition()
RaiseEvent position(CursorPosition)
debugprint(_bind.Rtf)
End Sub
Private Overloads Sub update(ByVal sender As Object, ByVal e As
System.Windows.Forms.KeyEventArgs)
update()
End Sub
Private Overloads Sub update(ByVal sender As Object, ByVal e As
System.Windows.Forms.MouseEventArgs)
update()
End Sub
Private Overloads Sub update(ByVal sender As Object, ByVal e As
System.EventArgs)
rtfColors.Clear() ' Clear the colors
readRTFColor() ' Read and parse the colors in the current
document
readRTFBody() ' Read and split the RTF into lines
readTXTBody() ' Read and split the text into lines
End Sub

'--------------------------------------------------------------------------
' Sub: asciiprint
' Purpose: Help in debugging, converts line to ascii char numbers
'
Private Function asciiprint(ByVal str As String) As String
Dim counter As Integer
Dim retval As String

For counter = 1 To str.Length
retval &= "{" & Asc(Mid(str, counter, 1)) & "} "
Next

Return retval
End Function

'--------------------------------------------------------------------------
' Sub: debugprint
' Purpose: Prints out the current document substitutring
non-printables
'
Private Sub debugprint(ByVal out As String)
out = out.Replace(Chr(13) & Chr(10), Chr(182) & vbCrLf)
out = out.Replace(Chr(32), Chr(183))
End Sub

'--------------------------------------------------------------------------
' Sub: toggleDebug
' Purpose: Hide or show the debug window
'
Public Function toggleDebug() As Boolean
RTFDebug = Not RTFDebug
Return RTFDebug
End Function

'--------------------------------------------------------------------------
' Sub: getCurrentPosition
' Purpose: Determins relitive line position
'
Private Function getCurrentPosition() As cPosition
Dim retval As New cPosition
Dim counter As Integer

retval.Cursor = _bind.SelectionStart

If _bind.Text <> "" Then
For counter = 0 To retval.Cursor - 1
If _bind.Text.Substring(counter, 1) = Chr(10) Then
retval.CurrentLine += 1
retval.LinePosition = 0
Else
retval.LinePosition += 1
End If
Next
End If

Return retval
End Function

'--------------------------------------------------------------------------
' Sub: saveScroll
' Purpose: saves the scroll info and locks the window
'
Private Sub saveScroll(ByVal hWnd As IntPtr)


CursorPosition.xScroll = GetScrollPos(_bind.Handle, SBS_HORZ)
CursorPosition.yScroll = GetScrollPos(_bind.Handle, SBS_VERT)
End Sub

'--------------------------------------------------------------------------
' Sub: restoreScroll
' Purpose: Resets the scroll info ans unlocks the window
'
Private Sub restoreScroll(ByVal hWnd As IntPtr)
SetScrollPos(_bind.Handle, SBS_HORZ, CursorPosition.xScroll,
True)
PostMessageA(_bind.Handle, WM_HSCROLL, SB_THUMBPOSITION +
&H10000 * CursorPosition.xScroll, Nothing)
SetScrollPos(_bind.Handle, SBS_VERT, CursorPosition.yScroll,
True)
PostMessageA(_bind.Handle, WM_VSCROLL, SB_THUMBPOSITION +
&H10000 * CursorPosition.yScroll, Nothing)

End Sub

'--------------------------------------------------------------------------
' Sub: _bind_TextChanged
' Purpose: Do the highlighting
'
Private Sub _bind_KeyUp(ByVal sender As Object, ByVal e As
System.Windows.Forms.KeyEventArgs) Handles _bind.KeyUp
If e.KeyData = Keys.Space Then
update() ' Update the cursor position
saveScroll(_bind.Handle) ' Freeze the windows and get the
scroll nfo

applyColor(CursorPosition.CurrentLine) ' Do any coloring
_bind.Rtf = Render() ' Update the RTF
_bind.SelectionStart = CursorPosition.Cursor ' Reset the
cursor
debugprint(_bind.Rtf) ' Update the debug window

restoreScroll(_bind.Handle) ' Unfreeze the windows and
Restore the scroll
End If
If e.KeyCode = Keys.Enter Then
update() ' Update the cursor position
saveScroll(_bind.Handle) ' Freeze the windows and get the
scroll nfo

applyColor(CursorPosition.essageA(_bind.Handle, WM_VSCROLL,
SB_THUMBPOSITION + &H10000 * CursorPosition.yScroll, Nothing)

End Sub

'--------------------------------------------------------------------------
' Sub: _bind_TextChanged
' Purpose: Do the highlighting
'
Private Sub _bind_KeyUp(ByVal sender As Object, ByVal e As
System.Windows.Forms.KeyEventArgs) Handles _bind.KeyUp
If e.KeyData = Keys.Space Then
---------------------------------------
' Sub: readRTFColor()
' Purpose: parse the color information in the header of the document
'
Private Function readRTFColor() As Boolean
Dim strHeader As String = ""

' Get Header string
' I hate RegEx :-)
'
Dim colHeader As System.Text.RegularExpressions.MatchCollection
= System.Text.RegularExpressions.Regex.Matches(_bind.Rtf,
"{\\colortbl\s?;(.*);}")

If RTFDebug Then Console.WriteLine("Colors found: " &
colHeader.Count)

If colHeader.Count = 1 Then
strHeader = colHeader.Item(0).Groups(1).Value
If RTFDebug Then
Console.WriteLine(colHeader.Item(0).Groups(1).Value)
Else
If RTFDebug Then Console.WriteLine("No color info in
header")
Return False
End If

' Translate the string to ARGB color values
' I hate RegEx :-)
'
Dim colColors As System.Text.RegularExpressions.MatchCollection
= System.Text.RegularExpressions.Regex.Matches(strHeader, "(\d+)")

If Not colColors Is Nothing Then
Dim colorCounter As---------------------------------------
' Sub: readRTFColor()
' Purpose: parse the color information in the header of the document
'
Private Function readRTFColor() As Boolean
Dim strHeader As String = ""

' Get Header string
' I hate RegEx :-)
'
Dim colHeader As System.Text.RegularExpressions.MatchCollection
= System.Text.RegularExpressions.Regex.Matc Next
End If
End Function

'--------------------------------------------------------------------------
' Sub: readRTFBody()
' Purpose: Read the RTF and strip off the header info, and split it
into limes.
' RegEx avoided here !
'
Private Function readRTFBody() As String
Dim tmp As String = _bind.Rtf
Dim bodyStart As Integer

Dim position As Integer = InStr(tmp, "\viewkind4")
If InStr(position, tmp, " ") < 0 Then
bodyStart = InStr(position, tmp, "\par")
Else
bodyStart = InStr(position, tmp, " ")
End If

Dim tmpRtfBody As String = tmp.Substring(bodyStart)
rtfBody = Split(tmpRtfBody, "\par")
End Function

'--------------------------------------------------------------------------
' Sub: readTXTBody()
' Purpose: Split the text portion into lines
' RegEx avoided here !
'
Private Function readTXTBody() As String
Dim tmpText As String
Dim counter As Integer

tmpText = _bind.Text
Next
End If
End Function

'--------------------------------------------------------------------------
' Sub: readRTFBody()
' Purpose: Read the RTF and strip off the header info, and split it
into limes.
' RegEx avoided here !
'
Private Function readRTFBody() As String
Dim tmp As String = _bind.Rtf
Dim bodyStart As Integer

--------------------------------------------
' Sub: Render()
' Purpose: Put the moded RTF back together
'
Private Function Render() As String
Dim tmp As String = reBuildBody()
Return reBuildHeader() & "\viewkind4 " & reBuildBody()
End Function

'--------------------------------------------------------------------------
' Sub: reBuildHeader()
' Purpose: Using the colortable supplied by readRTFColor() rebuilds
the
' headers after all you might have added a color!
'
Private Function reBuildHeader() As String
Dim thisColor As Integer
Dim DocHead As String

DocHead = "{\rtf1\ansi\ansicpg1252\deff0\deflang1033"
DocHead &= "{\colortbl ;"

For Each thisColor In rtfColors
Dim setColor As Color = Color.FromArgb(thisColor)
DocHead &= "\red" & setColor.R
DocHead &= "\green" & setColor.G
DocHead &= "\blue" & setColor.B & ";"
If RTFDebug Then Console.WriteLine("Adding Header Color")
Next

DocHead &= "}"--------------------------------------------
' Sub: Render()
' Purpose: Put the moded RTF back together
'
Private Function Render() As String
Dim tmp As String = reBuildBody()
Return reBuildHeader() & "\viewkind4 " & reBuildBody()
End Function

'--------------------------------------------------------------------------
' Sub: reBuildHeader()
0A Dim tmp As String = rtfBody(counter)
If tmp = "" Then tmp = " "
DocBody &= tmp & "\par" & vbCrLf
Next

If RTFDebug Then Console.WriteLine("RTF body lines rendered: " &
UBound(rtfBody))
Return DocBody
End Function

'--------------------------------------------------------------------------
' Sub: ChangeColor
' Purpose: Change the color of an element document wide. Basicly
this changes
' the info in the color table used to build the headers.
' Note: This changes a color to a color
'
Private Sub changeColor(ByVal srcColor As Color, ByVal toColor As
Color)
Dim index = rtfColors.exists(srcColor.ToArgb)

If index <> -1 Then
rtfColors.item(index) = toColor.ToArgb
End If
End Sub

'--------------------------------------------------------------------------
' Sub: ChangeColor
' Purpose: Change the color of an element document wide. Basicly
this changes
' the info in the color table used to build the headers.
' Note: This changes a index value of a color to a color
'
Dim tmp As String = rtfBody(counter)
If tmp = "" Then tmp = " "
DocBody &= tmp & "\par" & vbCrLf
Next

If RTFDebug Then Console.WriteLine("RTF body lines rendered: " &
UBound(rtfBody))
Return DocBody
End Function

'--------------------------------------------------------------------------
' Sub: ChangeColor
h
Dim Style As tDict
Dim rxOptions As New System.Text.RegularExpressions.RegexOptions
Dim colorindex As Integer

rtfBody(line) = txtBody(line)

For Each Style In rtfSyntax
If Style.ignoreCase Then rxOptions =
System.Text.RegularExpressions.RegexOptions.IgnoreCase Else rxOptions =
System.Text.RegularExpressions.RegexOptions.None

rtfColors.add(Style.color)
colorindex = rtfColors.exists(Style.color)

If Style.isRegex Then
Dim Matches As
System.Text.RegularExpressions.MatchCollection =
System.Text.RegularExpressions.Regex.Matches(rtfBody(line), Style.pattern,
rxOptions)
Dim count As Integer = 0

For Each thisMatch In Matches
Dim oldWord =
rtfBody(line).Substring(thisMatch.Index + count, thisMatch.Length)
Dim newString = "\cf" & colorindex + 1 & oldWord &
"\cf0 "

rtfBody(line) = rtfBody(line).Remove(thisMatch.Index
+ count, thisMatch.Length)
rtfBody(line) = rtfBody(line).Insert(thisMatch.Index
+ count, newString)
If RTFDebug Then Console.WriteLine("Regex pattern
match: " & Style.pattern)
count += 9
Next
Else
Dim Matches As
System.Text.RegularExpressions.MatchCollection =
System.Text.RegularExpressions.Regex.Matches(rtfBody(line), "\b" &
Style.pattern & "\b", rxOptions)
Dim count As Integer = 0

For Each thisMatch In Matches
Dim oldWord =
rtfBody(line).Substring(thisMatch.Index + count, thisMatch.Length)
Dim newString = "\cf" & colorindex + 1 & oldWord &
"\cf0 "

rtfBody(line) = rtfBody(line).Remove(thisMatch.Index
+ count, thisMatch.Length)
rtfBody(line) = rtfBody(line).Insert(thisMatch.Index
+ count, newString)
count += 9
If RTFDebug Then Console.WriteLine("Pattern match: "
& Style.pattern)
Next
End If
Next

End Function

Public Function colorDocument()
Dim counter As Integer
update(Me, New System.EventArgs)

For counter = 0 To UBound(txtBody)
applyColor(counter)
Next

_bind.Rtf = Render()
End Function
End Class

End Class

Just add this code to your form:

Code:
Friend Withevents rtbwrapper as new crtbwrapper


And then

Code:
with rtbwrapper
..bind(Name of rtb)
..rtfsyntax.add("\bhello\b",true,true,color.blue.toargb)
'add more syntax
end with


"Brad Wood" <dude@xxxxxxxxx> schrieb im Newsbeitrag
news:%23ejXt5PNHHA.536@xxxxxxxxxxxxxxxxxxxxxxx
Problem:
Selecting / changing color of text in a subclassed RichTextBox on
TextChanged.
- Native suppress redrawing with WM_SETREDRAW
- Make selections, set colors
- Set position back to where user was using Select()
- Unsuppress redrawing
- Call Refresh()

All works fine except the text always scrolls such that the line selected
(the line the user is modifying) jumps to the top.

Seems I've read and tried everything:
- Suppress native windows scroll messages (WM_VSCROLL and WM_HSCROLL).
- Getting/Resetting scroll position using Get/SetScrollPos (GetScrollPos
returns 0 which indicates failure but last windows message is
inconsistent - sometimes "the operation completed successfully").
- Setting HideSelection to true (seemed to help others with similar
issues).

Is there no way to make this work?



.