Results 1 to 5 of 5

Thread: Line-numbered RichTextBox

Hybrid View

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Line-numbered RichTextBox

    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?


    Name:  sshot.png
Views: 323
Size:  8.2 KB

    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.
    Attached Files Attached Files
    Last edited by dilettante; May 22nd, 2019 at 08:04 AM. Reason: update

  2. #2

    Thread Starter
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Re: Line-numbered RichTextBox

    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.

  3. #3
    Hyperactive Member
    Join Date
    Mar 2018
    Posts
    460

    Re: Line-numbered RichTextBox

    this is nice if you need the line number embedded with the text. I've always seen line numbers used outside (like word's line number feature)

  4. #4

    Thread Starter
    PowerPoster
    Join Date
    Feb 2006
    Posts
    24,482

    Re: Line-numbered RichTextBox

    If you can figure out how to manage that without major effort or a 3rd party library I'd love to see it.

    I was trying to get line-numbered text entry with minimal effort.

  5. #5
    PowerPoster ChrisE's Avatar
    Join Date
    Jun 2017
    Location
    Frankfurt
    Posts
    3,042

    Re: Line-numbered RichTextBox

    Hi

    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width