[RESOLVED] Capture Scroll Event of RichTextBox

[Static]

I did a search and found very little..

I am trying to draw lines to seperate sections in a RichTextBox
except the lines do not stay after scrolling off the screen.

So should I capture the scroll event and redraw or is there a better way?

if not.. how do I capture the scroll event?

thanks!

[poison6feet]

I did a search and found very little..

I am trying to draw lines to seperate sections in a RichTextBox
except the lines do not stay after scrolling off the screen.

So should I capture the scroll event and redraw or is there a better way?

if not.. how do I capture the scroll event?

thanks!

check for the previos scroll value and compare with the new value - if there is any change in these two values then the scroll occured in the rich text box... hope this will help u

[Static]

ok.. so how do I capture the scroll?

[Static]

anyone?
Bueller?

[poison6feet]

seems not possible ...

[dglienna]

Maybe inser space(80) and make it underlined?

[moeur]

how do I capture the scroll event?

Didn't we already discuss this?

You can generate your own scroll event
send a EM_SETEVENTMASK message to your rtb to set the mask for EN_VSCROLL notification.
Then subclass your main window and trap WM_COMMAND messages
when EN_VSCROLL comes up the user has scrolled
If you just redraw the lines during scrolling there shouldn't be too much flicker, if there is you can do a double buffer.
http://msdn.microsoft.com/library/d...eteventmask.asp

[Static]

moeur, yes... but I cant find any good code examples! I Need an example to be able to change / learn how to use EM_SETEVENTMASK etc..

CANT FIND ANY!!

dglienna.. I dont want to use an underline because then it will save into the file..(This is for the CodeBank app.. the underline will become part of the code snippet)

[moeur]

I can work up an example for you. But first let's discuss using an underline further.

What are the reasons you don't want to use it?

If you're only worried about it being saved to the rtf file then you can remove it before saving.

and why are you saving as rtf and not plain text?

[Static]

not saving as rtf.. just the text..
I would rather not have to remove before save...
and I dont want the user to be able to highlight / edit / change the line...
if they do.. then it would be hard to remove it from the text before save...

[moeur]

If you're just saving as text, then the underline won't get saved so you don't have to worry about that.

[Static]

but the user will still be able to edit it...
no good

Just like in VB IDE.. Lines

[moeur]

Are you worried that if the user edits a line that has an underline then the new text won't be underlined? If so, then you could handle that pretty easily by putting some code in the selchange event to underline new text when the cursor is in the special underlined region.

[Static]

no , I just dont want the user to be able to interact with the lines at all.. as iff they dont exist.. just like in VB IDE. there are line seperating the subs etc.. but you cant touch them

[moeur]

OK, I understand. I'll write something up for you.

[Static]

Cool! Thanks moeur!

[moeur]

OK, here is something. For some stupid reason, the EN_VSCROLL notification is not sent when the user drags the thumb. So I had to also subclass the form to catch those messages.
In a module define these public routines

Option Explicit
 
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    lParam As Any _
) As Long
 
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
    ByVal lpPrevWndFunc As Long, _
    ByVal hWnd As Long, _
    ByVal Msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long _
) As Long
 
Private Type POINTAPI
        x As Long
        y As Long
End Type
 
Private Const WM_USER = &H400
Private Const EN_HSCROLL = &H601
Private Const EN_VSCROLL = &H602
Private Const EN_CHANGE = &H300
Private Const EN_UPDATE = &H400
Private Const EM_SETEVENTMASK = (WM_USER + 69)
Private Const ENM_SCROLL = &H4
Private Const EM_GETSCROLLPOS = (WM_USER + 221)
Private Const EM_SETSCROLLPOS = (WM_USER + 222)
Private Const WM_COMMAND = &H111
Private Const WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114
 
'Must be declared in BAS file not FRM file.
Public frmSubClass As CSubclass
Public RTBsubClass As CSubclass
 
Public Function NewFrmWndProc(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
'This is where the messages for our Form will arrive
Dim ScrollPos As POINTAPI
        If uMsg = WM_COMMAND Then
            Select Case Int(wParam \ &H10000)
            Case EN_VSCROLL
                Debug.Print Timer, "EN_VSCROLL",
                SendMessage frmRTB.RTB.hWnd, EM_GETSCROLLPOS, 0, ScrollPos
                Debug.Print ScrollPos.y
            Case Else
            End Select
        End If
    NewFrmWndProc = CallWindowProc(frmSubClass.OrigWndProc, hWnd, uMsg, wParam, lParam)
End Function
 
Public Function NewRTBWndProc(ByVal hWnd As Long, ByVal uMsg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
'This is where the messages for our RichTExtBox will arrive
Dim ScrollPos As POINTAPI
        If uMsg = WM_VSCROLL Then
            Debug.Print Timer, "WM_VSCROLL",
            SendMessage hWnd, EM_GETSCROLLPOS, 0, ScrollPos
            Debug.Print ScrollPos.y
        End If
    NewRTBWndProc = CallWindowProc(RTBsubClass.OrigWndProc, hWnd, uMsg, wParam, lParam)
End Function
 
Public Sub SetCaptureScroll(hWndFRM As Long, hWndRTB As Long)
    'subclass our form to get scrollbar events
    Set frmSubClass = New CSubclass
    frmSubClass.EnableSubclass hWndFRM, AddressOf NewFrmWndProc
    'subclass the RTB to get scrollbar events
    Set RTBsubClass = New CSubclass
    RTBsubClass.EnableSubclass hWndRTB, AddressOf NewRTBWndProc
    'set notify mask for RTB so we receive scroll messages
    SendMessage hWndRTB, EM_SETEVENTMASK, 0, ByVal ENM_SCROLL
End Sub

To start it off just do this

Private Sub Form_Load()
    'pass form hWnd and RichTextBox hWnd
    SetCaptureScroll Me.hWnd, RTB.hWnd
End Sub

I've zipped it all up for you, including a class to do the subclassing.

What you'll get from the new window procedures is a vertical position in pixels that you can use to keep track of your lines.

[Static]

To bad I cant Swear on here... Becase I Would Say HOLY S***
IT WORKS PERFECTLY!!!

MANY MANY MANY THANX!!


The only thing is occasionally the lines disappear on resize.. but I dont care!

[moeur]

I think I might have an even better solution. Hang on for a bit and I'll get back.

[Static]

woot!

[moeur]

I am developing a WYSIWYG editor for this forum which uses a richtextbox so I am going to need something similar to your request. I think this method of inserting a separator line is much better no subclassing or tracking involved.

Public Sub Separator(rtb As RichTextBox, lColor As Long)
    Dim iPos As Long
    Dim strRTF As String
    With rtb
        iPos = .SelStart
        'bracket selection
        .SelText = Chr(&H80) & .SelText & Chr(&H81) ' \'80 \'81
        strRTF = rtb.TextRTF
'add new color
        lColor = AddColorToTable(strRTF, lColor)
'add highlighting
         strRTF = Replace(strRTF, "\'80", "\par\cf" & CStr(lColor) & "\protect ---------------------- Separator ----------------------------- ")
         strRTF = Replace(strRTF, "\'81", "\protect0\cf0\par  ")
 
         .TextRTF = strRTF
        .SelStart = iPos
       End With
End Sub
 
Function AddColorToTable(strRTF As String, lColor As Long) As Integer
Dim iPos As Long, jpos As Long
Dim ctbl As String
Dim tagColors
Dim nColors As Integer
Dim tagNew As String
Dim i As Integer
Dim iLen As Integer
Dim split1 As String
Dim split2 As String
 
    'make new color into tag
    tagNew = "\red" & CStr(lColor And &HFF) & _
        "\green" & CStr(Int(lColor / &H100) And &HFF) & _
        "\blue" & CStr(Int(lColor / &H10000))
    
    'find colortable
    iPos = InStr(strRTF, "{\colortbl")
    
    If iPos > 0 Then 'if table already exists
        jpos = InStr(iPos, strRTF, ";}")
        'color table
        ctbl = Mid(strRTF, iPos + 12, jpos - iPos - 12)
        'array of color tags
        tagColors = Split(ctbl, ";")
        nColors = UBound(tagColors) + 2
        'see if our color already exists in table
        For i = 0 To UBound(tagColors)
            If tagColors(i) = tagNew Then
                AddColorToTable = i + 1
                Exit Function
            End If
        Next i
        
        split1 = Left(strRTF, jpos)
        split2 = Mid(strRTF, jpos + 1)
        strRTF = split1 & tagNew & ";" & split2
        AddColorToTable = nColors
    
    Else
        'color table doesn't exists, let's make one
        iPos = InStr(strRTF, "{\fonttbl") 'beginning of font table
        jpos = InStr(iPos, strRTF, ";}}") + 2 'end of font table
        split1 = Left(strRTF, jpos)
        split2 = Mid(strRTF, jpos + 1)
        strRTF = split1 & "{\colortbl ;" & tagNew & ";}" & split2
        AddColorToTable = 1
    End If
End Function

I'll continue to improve this code, but wanted to get it to you incase you'd rather use it.
I also have code for highlighting and super/sub-scripts too if you need that.

Edit Fixed bug in addcolor function

[moeur]

Here is a better looking separator routine.
The beauty of this routine is that it inserts a seperator that looks nice, scrolls properly and the user cannot access. The one problem is that you will have to remove it before saving, but that is easily handled with a call to replace.

Use the above (fixed) colortable function and this new separator routine

Public Sub Separator(rtb As RichTextBox, lColor1 As Long, _
    lColor2 As Long, halfWidth As Integer, txtTitle As String)
    Dim iPos As Long
    Dim strRTF As String
    Dim txtTemp As String
    Dim icolor1 As Integer
    Dim icolor2 As Integer
    Dim iUP As Integer
    With rtb
        iPos = .SelStart
        iUP = Int(.SelFontSize) - 1
        'bracket selection
        .SelText = Chr(&H80) & .SelText & Chr(&H81) ' \'80 \'81
        strRTF = rtb.TextRTF
'add new colors
        icolor1 = AddColorToTable(strRTF, lColor1)
        icolor2 = AddColorToTable(strRTF, lColor2)
'add separator
 
        txtTemp = "\par" & _
         "\cf" & CStr(icolor1) & "\protect\up" & CStr(iUP) & " " & String(halfWidth, "_") & "\up0" & _
         "\cf" & CStr(icolor2) & " " & txtTitle & _
         "\cf" & CStr(icolor1) & "\up" & CStr(iUP) & " " & String(halfWidth, "_") & "\up0\cf0"
 
         strRTF = Replace(strRTF, "\'80", txtTemp)
         strRTF = Replace(strRTF, "\'81", "\protect0\cf0\par  ")
 
         .TextRTF = strRTF
        .SelStart = iPos
       End With
End Sub

Just call it like this

Separator rtb, vbRed, vbBlue, 20, " Visual Basic Code "

[Static]

ok, the lines look great..
but you still can interact with them. put you cursor in the middle of one of them and hit enter... splits them

I will stick with the original way.. just need to tweak it here and there.

thanks again for all your help!

[moeur]

I don't see that behavior in my example,
Anyway you've got something that works.
Your program looks great. I'll start using it when it's finished.

[Static]

ok, your going to be mad.. but I've found after all that. The code for putting lines in and keep them, seems to be interfering with other code!!

Not sure why.. example: RichTextBox_Change event no longer gets fired...
my auto indent code is adding extra #'s to the selstart location so it moves it when done.. etc.

I removed all the code/ module/ cls and it works fine..
I was concentrating so much on the lines.. I never tried other code until the lines worked right....I may go back to your other code.. need to play more

[moeur]

I hate it when that happens

[Static]

me too! thanks again for your help