Sometimes people have a need for text-entry where they want line numbering. Normally a Form only needs one of these, but sometimes you might want more.
Here is an example of a way to accomplish that without too many gymnastics such as trying to synchronize two controls. It uses a RichTextBox with TOM in order to style the lines as numbered paragraphs.
Whenever you clear the RTB or assign new text programmatically you need to renumber. Normal user text editing doesn't topple the house of cards, but if the user uses Ctrl-A or otherwise selects all text and deletes or replaces it the numbering could be lost. I added logic in the Change event to detect this and renumber as required.
The example here has a second RTB where uppercase roman numerals are used just for grins. There are other styles as well but the only really useful ones are variations (plain, period, parentheses, default right-parenthesis) along with arabic numerals.
There is also a TextBox to show that the .Text is just plain text without the numbering as part of it.
So it seems resistant to user fumbling, but it probably isn't bullet proof yet. Can anyone find editing patterns that "break" the line numbering?
I'd love to find a way to right-justify the line numbering or even in some cases to left-zero fill the numbers, but I haven't found any tricks for that.
Change:
Ok, found and fixed the unlikely but possible case where the user copies rich text with another style of numbering or bullets and pastes that into the RTB. Attachment re-uploaded.
Last edited by dilettante; May 22nd, 2019 at 08:04 AM.
Reason: update
I thought there was a TOM constant for a cpLim value of &H3FFFFFFF meaning "end of document" but I can't find it. I believe &H7FFFFFFF works just as well but I think that is larger than the largest story that RichEdit can hold.
this is what I tried long ago, gave it up because is wasn't required anymore by users
this in a class
Code:
'Classname : clsRTBoxLineNrCursor
Option Explicit
'zum Zeichnen des Cursors
Private Declare Function CreateCaret Lib "user32" _
(ByVal hWnd As Long, ByVal hBitmap As Long, _
ByVal nWidth As Long, ByVal nHeight As Long) _
As Long
Private Declare Function ShowCaret Lib "user32" (ByVal _
hWnd As Long) As Long
'für Positionsermittlungen
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Const EM_GETFIRSTVISIBLELINE As Long = &HCE
Private Const EM_GETLINECOUNT As Long = &HBA
Private Const EM_LINELENGTH = &HC1
Private Const EM_LINEINDEX = &HBB
Private Const EM_LINEFROMCHAR = &HC9
'----- Controls ------------------------------------
Private WithEvents RTBox As RichTextBox
Private WithEvents Frm As VB.Form
Private Pic As VB.PictureBox
Private mLblZNr As VB.Label
Private mLblFr As VB.Label
Private WithEvents mTimer As VB.Timer
'------ Events -------------------------------------
Public Event RowCol(Row As Long, Col As Long, _
Pos As Long, LinesCount As Long)
Public Event InsertModeChanged(InsertMode As Boolean, _
InsertText As String)
Public Event LineNumberChar(CharCount As Long)
'----- Variable ------------------------------------
Private mbInsertMode As Boolean 'Insert oder Update
Private mbShowLineNr As Boolean '
Private mLinesCount As Long
Private mlTop As Long
Private mlLeft As Long
Private mlHeight As Long
Private mlWidth As Long
Private mlBorderStyle As Long
Private LastFirstLine As Long 'intern
Private LastLineCount As Long 'intern
Private MaxLines As Long 'intern
Private mLineNrMinWidth As Long '
Private mTimerInterval As Long 'Tempo des Timer
Private mTimerEnabled As Boolean 'Timer einsetzen
'für Scroll Abfrage
'----- Properties -----------------------------------
Public Property Let TimerInterval(vData As Long)
mTimerInterval = vData
End Property
Public Property Get TimerInterval() As Long
TimerInterval = mTimerInterval
End Property
Public Property Let ShowLineNr(vData As Boolean)
mbShowLineNr = vData
Refresh
End Property
Public Property Get ShowLineNr() As Boolean
ShowLineNr = mbShowLineNr
End Property
Public Property Let Top(lData As Long)
mlTop = lData
Refresh
End Property
Public Property Get Top() As Long
Top = mlTop
End Property
Public Property Let Left(lData As Long)
mlLeft = lData
Refresh
End Property
Public Property Get Left() As Long
Left = mlLeft
End Property
Public Property Let Height(lData As Long)
mlHeight = lData
Refresh
End Property
Public Property Get Height() As Long
Height = mlHeight
End Property
Public Property Let Width(lData As Long)
mlWidth = lData
Refresh
End Property
Public Property Get Width() As Long
Width = mlWidth
End Property
'Timer für Überwachung der Scrolleiste
Public Property Let TimerEnabled(vData As Boolean)
mTimerEnabled = vData
If vData Then
mTimer.Interval = mTimerInterval
mTimer.Enabled = True
Else
mTimer.Enabled = False
End If
End Property
Public Property Get TimerEnabled() As Boolean
TimerEnabled = mTimerEnabled
End Property
'----- Functions ---------------------------------------
'Control auf die Form bringen
Private Function AddControl(mFrm As Form, mCtl As Control, _
CtlType As String, _
CtlName As String) As Control
Dim i As Long
'prüfen, ob schon vorhanden
If Not (mCtl Is Nothing) Then
Exit Function
End If
On Error Resume Next
Do
'Control zur Formcollection
Set mCtl = Frm.Controls.Add(CtlType, CtlName & i)
If Err.Number = 0 Then
Exit Do
End If
Err.Clear
i = i + 1
Loop
On Error GoTo 0
Set AddControl = mCtl
Set mCtl = Nothing
End Function
'----- Init der Klasse ---------------------------------------
Public Sub Init(mRTextBox As RichTextBox, Optional BorderStyle As Long = 1)
'Referenzen bilden
Set RTBox = mRTextBox
Set Frm = mRTextBox.Parent
'Controls zur Collection der Form
Set Pic = AddControl(Frm, Pic, "VB.PictureBox", "picTbox")
Set mTimer = AddControl(Frm, mTimer, "VB.Timer", "TimerTbox")
Set mLblZNr = AddControl(Frm, mLblZNr, "VB.label", "LblNr")
Set mLblFr = AddControl(Frm, mLblFr, "VB.Label", "LblFr")
mlBorderStyle = BorderStyle
'
With mLblZNr
.Width = Screen.TwipsPerPixelY '=min
.BorderStyle = 0
.BackColor = RTBox.BackColor
.Visible = True
.WordWrap = True
.Alignment = vbRightJustify
End With
'
With mLblFr
.Visible = True
.BorderStyle = mlBorderStyle
End With
With RTBox
mlTop = .Top
mlLeft = .Left
mlHeight = .Height
mlWidth = .Width
End With
'
'Timer Grundeinstellung
TimerInterval = 100
'wenn Scrollbar gesetzt
If RTBox.ScrollBars > 1 Then
TimerEnabled = True
End If
Refresh
RTBox_Change
'zum Abfangen der Taste Ins
Frm.KeyPreview = True
mbInsertMode = True
InsertModeEvent
End Sub
'----- Einrichten der Elemente -----
Public Sub Refresh()
'
On Error Resume Next
'Font für Höhenberechnung
With Pic
.FontName = RTBox.Font
.FontSize = RTBox.SelFontSize
.FontBold = RTBox.SelBold
End With
With mLblZNr
.FontName = RTBox.Font
.FontSize = RTBox.SelFontSize
.FontBold = RTBox.SelBold
End With
With mLblFr
.BorderStyle = mlBorderStyle
.Top = mlTop
.Left = mlLeft
.Height = mlHeight
.Width = mlWidth
End With
If Not mbShowLineNr Then
mLineNrMinWidth = Screen.TwipsPerPixelY ' =min
End If
With mLblZNr
.Top = mlTop + 2 * Screen.TwipsPerPixelY
.Left = mlLeft + 2 * Screen.TwipsPerPixelX
'RTBox-Anweisungen hier zur Vermeidung Flash
RTBox.Width = mlWidth - mLineNrMinWidth - 4 * Screen.TwipsPerPixelX
RTBox.Left = .Left + mLineNrMinWidth
.Width = mLineNrMinWidth
End With
With RTBox
.Top = mLblZNr.Top
.Height = mlHeight - 4 * Screen.TwipsPerPixelY
End With
If RTBox.ScrollBars = 0 Or RTBox.ScrollBars = 2 Then
mLblZNr.Height = RTBox.Height
Else
mLblZNr.Height = IIf(RTBox.Height - 16 * Screen.TwipsPerPixelY > 0, _
RTBox.Height - 16 * Screen.TwipsPerPixelY, 0)
End If
MaxLines = Int(mLblZNr.Height / Pic.TextHeight("X")) + 1 ' 1=angeschnittene Zeile
On Error GoTo 0
LastFirstLine = 0
LastLineCount = 0
LineNumbersShow
End Sub
'----- Zeilennummern anzeigen -----
Private Sub LineNumbersShow()
Dim FirstLine As Long
Dim ShowLines As Long, i As Long, lDiff As Long
Dim s As String
If Not mbShowLineNr Then Exit Sub
'ermitteln Anzahl Zeilen und 1. sichtbare Zeile
FirstLine = SendMessage(RTBox.hWnd, _
EM_GETFIRSTVISIBLELINE, 0, 0)
'hat sich was geändert?
If FirstLine = LastFirstLine Then
If mLinesCount = LastLineCount Then
'nein, Flackern vermeiden
Exit Sub
End If
End If
'Anzeige?
ShowLines = MaxLines
If (mLinesCount - FirstLine) < MaxLines Then
ShowLines = mLinesCount - FirstLine
End If
'Zeilennummern erstellen
For i = FirstLine To FirstLine + ShowLines - 1
s = s & vbCrLf & (i + 1) & " : "
Next
mLblZNr.Caption = Mid(s, 3)
'
'muss die Breite geändert werden?
'Variante ZeilenAnzeige Breite nach größter ZeilenNr
'If mLineNrMinWidth <> Pic.TextWidth(CStr(mLinesCount) & " : ") Then
' mLineNrMinWidth = Pic.TextWidth(CStr(mLinesCount) & " : ")
'Variante Zeilenanzeige Breite nach größter angezeigter Zeile
If mLineNrMinWidth <> Pic.TextWidth(CStr(i) & " : ") Then
mLineNrMinWidth = Pic.TextWidth(CStr(i) & " : ")
lDiff = mLineNrMinWidth - mLblZNr.Width
mLblFr.BackColor = RTBox.BackColor 'große Dateien, Flash vermeiden
mLblZNr.Width = mLineNrMinWidth
RTBox.Left = mLblZNr.Left + mLineNrMinWidth
RTBox.Width = RTBox.Width - lDiff
mLblFr.BackColor = Frm.BackColor
RaiseEvent LineNumberChar(Len(CStr(i) & " : "))
End If
'sichern der aktuellen Positionen
LastFirstLine = FirstLine
LastLineCount = mLinesCount
End Sub
'----- am Ende Speicher freigeben -----
Private Sub Class_Terminate()
If RTBox Is Nothing Then
Exit Sub
End If
Frm.Controls.Remove Pic
Frm.Controls.Remove mTimer
Frm.Controls.Remove mLblZNr
Frm.Controls.Remove mLblFr
Set RTBox = Nothing
Set Frm = Nothing
Set Pic = Nothing
Set mTimer = Nothing
Set mLblZNr = Nothing
Set mLblFr = Nothing
End Sub
'Wechsel zwischen Einfüge- und Überschreibmodus
Private Sub Frm_KeyDown(KeyCode As Integer, Shift As Integer)
If Shift = 0 Then
If KeyCode = 45 Then
mbInsertMode = Not mbInsertMode
InsertModeEvent
End If
End If
End Sub
'Überwachen, ob gescrollt wurde
Private Sub mTimer_Timer()
Dim FirstLine As Long
FirstLine = SendMessage(RTBox.hWnd, _
EM_GETFIRSTVISIBLELINE, 0, 0)
If FirstLine <> LastFirstLine Then
'es wurde gescrollt
LineNumbersShow
End If
End Sub
'Text wurde geändert
Private Sub RTBox_Change()
mLinesCount = SendMessage(RTBox.hWnd, EM_GETLINECOUNT, 0, 0&)
RowColEvent 'Event feuern
LineNumbersShow 'Zeilennummern anzeigen
End Sub
Private Sub RTBox_Click()
RowColEvent 'Event feuern
ShowCursor 'Cursor einrichten
End Sub
Private Sub RTBox_GotFocus()
ShowCursor 'Cursor einrichten
End Sub
Private Sub RTBox_KeyDown(KeyCode As Integer, Shift As Integer)
Frm_KeyDown KeyCode, Shift
RowColEvent
LineNumbersShow 'Zeilennummern anzeigen
End Sub
Private Sub RTBox_KeyPress(KeyAscii As Integer)
'ShowCursor
End Sub
Private Sub RTBox_KeyUp(KeyCode As Integer, Shift As Integer)
RowColEvent 'Event feuern
LineNumbersShow 'Zeilennumern anzeigen
ShowCursor 'Cursor einrichten
End Sub
'Event über aktuelle Positionen
Public Sub RowColEvent()
Dim Row As Long
Dim Col As Long
Dim CursorPos As Long
' Zeile
CursorPos = RTBox.SelStart
Row = SendMessage(RTBox.hWnd, EM_LINEFROMCHAR, _
CursorPos, ByVal 0&)
' Spalte
Col = SendMessage(RTBox.hWnd, EM_LINEINDEX, _
Row, ByVal 0&)
Row = Row + 1
Col = CursorPos - Col + 1
'Zeile, Spalte, Position im Text, Zeilenanzahl
RaiseEvent RowCol(Row, Col, RTBox.SelStart + 1, mLinesCount)
End Sub
'Event auslösen für Einfüge- oder Überschreibmodus
Private Sub InsertModeEvent()
Dim s As String
If mbInsertMode Then
s = "Ins"
Else
s = "Upd"
End If
RaiseEvent InsertModeChanged(mbInsertMode, s)
End Sub
'Status ausgeben
Public Sub GetStatus()
'
RowColEvent
InsertModeEvent
'
End Sub
'Cursor anzeigen
Private Sub ShowCursor()
Dim h As Long
Dim w As Long
Dim s As String
'Höhe des Cursors
h = Pic.TextHeight("A") / Screen.TwipsPerPixelY
If mbInsertMode Then
'bei Einfügemodus Breite 0
w = 0
Else
'bei Überschreibmodus Breite eines Zeichens
'Schriftart gleiche Zeichenbreie!
w = Pic.TextWidth("X") / Screen.TwipsPerPixelX
'Schriftart unterschiedliche Zeichenbreite
End If
'Cursor zeichen
CreateCaret RTBox.hWnd, Pic.Picture, w, h
'und übergeben
ShowCaret RTBox.hWnd
End Sub
and the Form
Code:
Option Explicit
'
Private WithEvents clsEditor As clsRTBoxLineNrCursor
Private Sub Form_Load()
'
Set clsEditor = New clsRTBoxLineNrCursor
clsEditor.Init RichTextBox1, 1
clsEditor.ShowLineNr = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
'
Set clsEditor = Nothing
End Sub
hth
chris
to hunt a species to extinction is not logical !
since 2010 the number of Tigers are rising again in 2016 - 3900 were counted. with Baby Callas it's 3901, my wife and I had 2-3 months the privilege of raising a Baby Tiger.