Re: Problem with Rich Text Box

From: David Youngblood (dwy_at_flash.net)
Date: 01/04/05 

Date: Mon, 3 Jan 2005 20:48:45 -0600

"Les" <vb4@prodigy.net> wrote...
> A developer helped me with thiscode snippet from the General Forum and it
> worked the way it was intended on his machine but on mine and another
> gentlleman from that forum...

Did you not like the API solution that I posted in the other forum? Here I have
modified Rick's code with the API's, and it should behave exactly as Rick
intended (and should have). The API's replace the UpTo/Span methods. I left
those commented out so that you can see the difference. However, since you are
not allowing the user to enter text, I would still recommend doing the selection
in the SelChange event, as posted in the other forum. It works better, visually
(in my opinion).

David

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 GetCaretPos Lib "user32" ( _
    lpPoint As POINTAPI) As Long

Private Type POINTAPI
        x As Long
        y As Long
End Type

Private Const EM_LINELENGTH = &HC1
Private Const EM_SETSEL = &HB1
Private Const EM_CHARFROMPOS = &HD7

Private Sub Form_Load()
    Dim t As String
    t = "Line 1 This is a test to see if it works"
    t = t & vbCrLf & "Line 2 This is a test to see if it works"
    t = t & vbCrLf & "Line 3 This is a test to see if it works"
    t = t & vbCrLf & "Line 4 This is a test to see if it works"
    t = t & vbCrLf & "Line 5 This is a test to see if it works"
    t = t & vbCrLf & "Line 6 This is a test to see if it works"
    t = t & vbCrLf & "Line 7 This is a test to see if it works"
    t = t & vbCrLf & "Line 8 This is a test to see if it works"
    t = t & vbCrLf & "Line 9 This is a test to see if it works"
    t = t & vbCrLf & "Line 10 This is a test to see if it works"
    t = t & vbCrLf & "Line 11 This is a test to see if it works"
    t = t & vbCrLf & "Line 12 This is a test to see if it works"
    t = t & vbCrLf & "Line 13 This is a test to see if it works"
    t = t & vbCrLf & "Line 14 This is a test to see if it works"
    t = t & vbCrLf & "Line 15 This is a test to see if it works"
    t = t & vbCrLf & "Line 16 This is a test to see if it works"
    t = t & vbCrLf & "Line 17 This is a test to see if it works"
    t = t & vbCrLf & "Line 18 This is a test to see if it works"
    t = t & vbCrLf & "Line 19 This is a test to see if it works"
    RichTextBox1 = t
End Sub

Private Sub RichTextBox1_Click()
  With RichTextBox1
    '.UpTo vbLf, False, False
    '.Span vbCr, True, True
    SetSelection
  End With
  ' The line the user clicked on is now highlighted; put
  ' whatever code you wanted to follow this action here
End Sub

Private Sub RichTextBox1_KeyUp(KeyCode As Integer, Shift As Integer)
  Dim HighLight As Boolean
  With RichTextBox1
    Select Case KeyCode
      Case vbKeyUp, vbKeyDown, vbKeyPageUp, vbKeyPageDown
        HighLight = True
      Case vbKeyHome
        HighLight = True
        .SelStart = 0
      Case vbKeyEnd
        HighLight = True
        .SelStart = Len(.Text)
    End Select
    If HighLight Then
      '.UpTo vbLf, False, False
      '.Span vbCr, True, True
      SetSelection
    End If
  End With
  ' The line the user clicked on is now highlighted; put
  ' whatever code you wanted to follow this action here
End Sub

Private Sub SetSelection()

    Dim pt As POINTAPI
    Dim iOffset As Long
    Dim iLength As Long

    If GetCaretPos(pt) Then
        pt.x = 1
        With RichTextBox1
        iOffset = SendMessage(.hwnd, EM_CHARFROMPOS, 0&, _
                  ByVal VarPtr(pt))
        iLength = SendMessage(.hwnd, EM_LINELENGTH, _
                  ByVal iOffset, ByVal 0&)
        SendMessage .hwnd, EM_SETSEL, iOffset, _
                  ByVal iOffset + iLength
        End With
    End If

End Sub

Relevant Pages

  • Re: An event raise twice when click the button.
    ... Private Sub AddinInstance_OnAddInsUpdateAs Variant) ... Private Sub AddinInstance_OnBeginShutdownAs Variant) ... Private WithEvents m_objInsp As Outlook.Inspector ... Dim tempMailItem As Outlook.MailItem ...
    (microsoft.public.office.developer.outlook.vba)
  • Re: An event raise twice when click the button.
    ... Private Sub AddinInstance_OnAddInsUpdateAs Variant) ... Private Sub AddinInstance_OnBeginShutdownAs Variant) ... Private WithEvents m_objInsp As Outlook.Inspector ... Dim tempMailItem As Outlook.MailItem ...
    (microsoft.public.office.developer.outlook.vba)
  • Re: reading mouse wheel rotation in VB6
    ... Private Sub ucSubclass1_MouseWheel ... Private Type tSubData 'Subclass data type ... Private Sub UserControl_ReadProperties ... Public Sub zSubclass_Proc(ByVal bBefore As Boolean, ByRef bHandled As Boolean, ByRef lReturn As Long, ByRef lng_hWnd As Long, ByRef uMsg As Long, ByRef wParam As Long, ByRef lParam As Long) ...
    (microsoft.public.vb.general.discussion)
  • Re: How many timers?
    ... Private PeriodicTasks As New Collection ... Private WithEvents HalfSecond As EventSync ... Private ConnectState As ConnectFlags ... Private Sub Form_Click ...
    (microsoft.public.vb.general.discussion)
  • Re: GUI question (slightly complicated - maybe only for the experts in here)
    ... An invalid drop target is drawn in red. ... Private WithEvents Board As CBoard ... Private mMoving As Boolean ... Private Sub Form_Resize ...
    (microsoft.public.vb.general.discussion)