Recent

Author Topic: [SOLVED] TRichMemo and text colour  (Read 2253 times)

MarkMLl

  • Hero Member
  • *****
  • Posts: 6930
[SOLVED] TRichMemo and text colour
« on: May 20, 2024, 05:18:52 pm »
I know that this is a bit of an FAQ, but I'm trying to strip things down to the bare minimum without any frills.

I have a TRichMemo set read-only, and am adding logging-style text to the end of its Lines property. All added text will be an entire paragraph followed by a blank line, I will never be adding a partial line or attempting to append to an existing one.

In order to conserve resources and maximise performance, I am periodically deleting entire lines from the start of the Lines property.

The user can scroll the display, but not manipulate the content.

What is the most-straightforward way of saying, at the point in the code where lines are being added, "set the colour to clSomething" such that the colour stays with the text even though lines above it are being deleted?

MarkMLl
« Last Edit: June 07, 2024, 01:08:29 pm by MarkMLl »
MT+86 & Turbo Pascal v1 on CCP/M-86, multitasking with LAN & graphics in 128Kb.
Pet hate: people who boast about the size and sophistication of their computer.
GitHub repositories: https://github.com/MarkMLl?tab=repositories

MarkMLl

  • Hero Member
  • *****
  • Posts: 6930
Re: TRichMemo and text colour
« Reply #1 on: May 23, 2024, 10:00:51 am »
On Linux this works without further correction for the number of lines etc.:

Code: Pascal  [Select][+][-]
  1. function CurtailedAppend(lines: TStrings; const line: ansistring; var caret: TPoint;
  2.                 blockText: boolean= false; limit: integer= CurtailLimit; slop: integer= -1): integer;
  3.  
  4. begin
  5.   result := 0;
  6.   lines.Append(line)
  7. end { CurtailedAppend } ;
  8.  
  9. ...
  10.  
  11. (* Output a single line.
  12. *)
  13. procedure TFrameInfield.PaneAppend(const line: ansistring; colour: TColor= clDefault);
  14.  
  15. const
  16.   hasBeenVisible: boolean= false;       (* Static variable                      *)
  17.  
  18. var
  19.   caret: TPoint;
  20.   lengthBeforeAppend, deletedByAppend: integer;
  21.  
  22. begin
  23.   lengthBeforeAppend := Length(RichMemoInfield.Lines.Text);
  24.   deletedByAppend := CurtailedAppend(RichMemoInfield.Lines, line, caret, true);
  25.   lengthBeforeAppend -= deletedByAppend;
  26.  
  27. (* CurtailedAppend() returns the number of characters deleted (is any) from the *)
  28. (* start of the TMemo or TRichMemo. This is used to adjust the start point of   *)
  29. (* the range to be coloured.                                                    *)
  30.  
  31.   if colour <> clDefault then
  32.  
  33. // https://wiki.freepascal.org/RichMemo?#Append_mixed_color_text_at_the_end_of_the_RichMemo
  34. // This will go wrong if any lines were deleted.
  35.  
  36. {
  37. SetRangeColor(Length(Lines.Text) - Length(Lines[Lines.Count - 1]) - Lines.Count - 1, Length(Lines[Lines.Count - 1]), clBlue);
  38. }
  39.  
  40.     RichMemoInfield.SetRangeColor(lengthBeforeAppend, Length(line), colour);
  41.  
  42. end { TFrameInfield.PaneAppend } ;
  43.  

I've stripped down CurtailedAppend() there to only append a single line, under normal circumstances it would ensure that the total number of lines was less than some maximum by deleting stuff from the start and would make sure that the most-recent text remained visible.

CurtailedAppend() is tested thoroughly with a TMemo. With a TRichMemo appending text with a defined colour works OK, but it deletion is allowed something goes wrong with the colouration a few lines above the insertion point.

I'll provide more detail once I've stripped stuff down to a bare-bones test app.

MarkMLl
MT+86 & Turbo Pascal v1 on CCP/M-86, multitasking with LAN & graphics in 128Kb.
Pet hate: people who boast about the size and sophistication of their computer.
GitHub repositories: https://github.com/MarkMLl?tab=repositories

KodeZwerg

  • Hero Member
  • *****
  • Posts: 2269
  • Fifty shades of code.
    • Delphi & FreePascal
Re: TRichMemo and text colour
« Reply #2 on: May 23, 2024, 11:11:18 am »
I guess I did not really understand what you try to do, adding colored lines into a richmemo, readonly, remove from time to time some lines by not change colors for other lines.
Okay, all above can be simple done with those helpers:
Code: Pascal  [Select][+][-]
  1. procedure TForm1.AddRichText(const ARichMemo: TRichMemo; const AText: string; const AFont: TFont; const ABackgroundColor: TColor);
  2. var
  3.   StartPos, EndPos: Integer;
  4.   FontParams: TFontParams;
  5. begin
  6.   StartPos := ARichMemo.SelStart;
  7.   EndPos := StartPos + Length(AText);
  8.  
  9.   FontParams.Color := AFont.Color;
  10.   FontParams.HasBkClr := True;
  11.   FontParams.BkColor := ABackgroundColor;
  12.   FontParams.Name := AFont.Name;
  13.   FontParams.Size := AFont.Size;
  14.   FontParams.Style := AFont.Style;
  15.   FontParams.VScriptPos := vpNormal;
  16.  
  17.   ARichMemo.Lines.BeginUpdate;
  18.   ARichMemo.SelText := AText;
  19.   ARichMemo.SelStart := StartPos;
  20.   ARichMemo.SelLength := EndPos - StartPos;
  21.   ARichMemo.SetTextAttributes(StartPos, EndPos - StartPos, FontParams);
  22.   ARichMemo.SelStart := EndPos;
  23.   ARichMemo.Lines.EndUpdate;
  24. end;
  25.  
  26. procedure TForm1.AddRichBreak(const ARichMemo: TRichMemo);
  27. begin
  28.   ARichMemo.Lines.BeginUpdate;
  29.   ARichMemo.SelText := LineEnding;
  30.   ARichMemo.SelStart := ARichMemo.SelStart + Length(ARichMemo.SelText);
  31.   ARichMemo.Lines.EndUpdate;
  32. end;
  33.  
  34. procedure TForm1.DelRichLine(const ARichMemo: TRichMemo; const ALineNumber: Integer);
  35. begin
  36.   if ALineNumber >= ARichMemo.Lines.Count then
  37.     Exit;
  38.   ARichMemo.Lines.BeginUpdate;
  39.   ARichMemo.Lines.Delete(ALineNumber);
  40.   ARichMemo.Lines.EndUpdate;
  41. end;

use "AddRichText()" to add text at wherever the caret is.
use "AddRichBreak()" to add a CRLF/linebreak wherever the caret is.
use "DelRichLine()" to delete a line, index 0 based for line #1.

Does that help?
« Last Edit: Tomorrow at 31:76:97 xm by KodeZwerg »

cdbc

  • Hero Member
  • *****
  • Posts: 1247
    • http://www.cdbc.dk
Re: TRichMemo and text colour
« Reply #3 on: May 23, 2024, 11:43:00 am »
Hi
I think Mark is trying to maintain a colored 'viewport', (scrolling as I understand it)...
I, for one, am following his progress  :)
Regards Benny
If it ain't broke, don't fix it ;)
PCLinuxOS(rolling release) 64bit -> KDE5 -> FPC 3.2.2 -> Lazarus 2.2.6 up until Jan 2024 from then on it's: KDE5/QT5 -> FPC 3.3.1 -> Lazarus 3.0

paweld

  • Hero Member
  • *****
  • Posts: 1061
Re: TRichMemo and text colour
« Reply #4 on: May 23, 2024, 01:01:14 pm »
@MarkMLI: Or maybe a listbox + HTML is enough for you? see @wp's example in this thread: https://forum.lazarus.freepascal.org/index.php/topic,55971.msg416110.html#msg416110
Best regards / Pozdrawiam
paweld

MarkMLl

  • Hero Member
  • *****
  • Posts: 6930
Re: TRichMemo and text colour
« Reply #5 on: May 24, 2024, 09:04:49 am »
Hi
I think Mark is trying to maintain a colored 'viewport', (scrolling as I understand it)...
I, for one, am following his progress  :)
Regards Benny

No, I'm trying to append coloured text that stays coloured from that point onwards (i.e. "henceforth") irrespective of scrolling etc. In effect, it's a "default for all new text" rather than the existing "default for everything".

From what I can see, there is no provision to do that. However my code that appends and then colours does appear to work- /unless/ there is subsequent deletion from the start of the text as shown in the partial screenshot of alternating-colour blocks with a colour change after deletion has started.

I'll append a demo program in a day or so when I've had time to chop things down a bit.

MarkMLl
MT+86 & Turbo Pascal v1 on CCP/M-86, multitasking with LAN & graphics in 128Kb.
Pet hate: people who boast about the size and sophistication of their computer.
GitHub repositories: https://github.com/MarkMLl?tab=repositories

KodeZwerg

  • Hero Member
  • *****
  • Posts: 2269
  • Fifty shades of code.
    • Delphi & FreePascal
Re: TRichMemo and text colour
« Reply #6 on: May 24, 2024, 10:25:05 am »
No, I'm trying to append coloured text that stays coloured from that point onwards (i.e. "henceforth") irrespective of scrolling etc. In effect, it's a "default for all new text" rather than the existing "default for everything".
Sweet, I've understood your initial post :D
From what I can see, there is no provision to do that.
Sure there is, I've posted the methods that do exact what you want.  O:-)
Maybe exchange the "string" with a better suiting one, eg TStrings/TStringList etc ...
« Last Edit: Tomorrow at 31:76:97 xm by KodeZwerg »

MarkMLl

  • Hero Member
  • *****
  • Posts: 6930
Re: TRichMemo and text colour
« Reply #7 on: May 24, 2024, 11:46:56 am »
Sure there is, I've posted the methods that do exact what you want.  O:-)
Maybe exchange the "string" with a better suiting one, eg TStrings/TStringList etc ...

Not in there /as/ /standard/ then. I'll check that out when I have time, thanks.

MarkMLl
MT+86 & Turbo Pascal v1 on CCP/M-86, multitasking with LAN & graphics in 128Kb.
Pet hate: people who boast about the size and sophistication of their computer.
GitHub repositories: https://github.com/MarkMLl?tab=repositories

MarkMLl

  • Hero Member
  • *****
  • Posts: 6930
Re: TRichMemo and text colour
« Reply #8 on: June 01, 2024, 09:39:24 am »
Not in there /as/ /standard/ then. I'll check that out when I have time, thanks.

So what do I have to do to get that example to actually generate output? AddRichText() appears to be having no effect whatsoever.

Test program attached.

MarkMLl
MT+86 & Turbo Pascal v1 on CCP/M-86, multitasking with LAN & graphics in 128Kb.
Pet hate: people who boast about the size and sophistication of their computer.
GitHub repositories: https://github.com/MarkMLl?tab=repositories

MarkMLl

  • Hero Member
  • *****
  • Posts: 6930
Re: TRichMemo and text colour
« Reply #9 on: June 01, 2024, 09:07:05 pm »
I've tracked down my problem: when I was deleting a line at the start of the memo I was adding  Length(Lines[0])  to the number of characters I was reporting deleted, when I should have been adding  Length(Lines[0]) + 1  to allow for an internal EOL marker. The fact that an entire line was appearing with the wrong colour was an unfortunate coincidence.

I've now got a single function which handles length management of either a TMemo or TRichMemo, with the final line kept in view which is what would be expected for debugging etc. output:

Code: Pascal  [Select][+][-]
  1. const
  2.   CurtailLimit= 1024;                   (* Default limit and slop               *)
  3.   CurtailSlop= 32;                      (* This is a fraction since +ve         *)
  4.  
  5. (* This is typically used to keep the total number of lines in a TMemo etc.
  6.   below some limit, so that the resources it consumes do not start to impose a
  7.   bottleneck. The return value is the number of characters deleted, including
  8.   line-ends.
  9.  
  10.   If the blockText parameter is false then deletion is of individual lines at
  11.   the start of the memo, otherwise it continues until it reaches a blank line
  12.   assumed to indicate the end of a block or paragraph. If hasBeenVisible is
  13.   false no attempt is made to save and restore the caret position, avoiding the
  14.   penalty of an internal exception if text is being sent to a form known to be
  15.   hidden.
  16.  
  17.   If the slop parameter is +ve then it indicates the fraction by which the size
  18.   is allowed to "hunt" around the limit; +1 is a special case indicating that
  19.   there should be no deletion. If the slop parameter is -ve then it is a number
  20.   of lines rather than a fraction; -1 is a special case indicating a default.
  21. *)
  22. function CurtailedAppend(const memo: TCustomMemo; const line: ansistring;
  23.                 blockText: boolean= false; hasBeenVisible: boolean= true;
  24.                 limit: integer= CurtailLimit; slop: integer= -1): integer;
  25.  
  26. {$define USE_TAG_FOR_TIMEOUT }
  27.  
  28. const
  29.   timeout= 150;                         (* Seconds                              *)
  30.  
  31. var
  32.   caret: TPoint;
  33.   trimmedLines, halfSlop: integer;
  34.   forceToEnd: boolean;
  35.  
  36. begin
  37.   result := 0;
  38.   memo.Lines.BeginUpdate;
  39.   try
  40.     if hasBeenVisible then              (* Avoid "GetCaretPos called without handle" *)
  41.       try
  42.         caret := memo.CaretPos
  43.       except
  44.         caret.X := 0;
  45.         caret.Y := 0
  46.       end
  47.     else begin
  48.       caret.X := 0;
  49.       caret.Y := 0
  50.     end;
  51.  
  52. (* Slop values of -1 and +1 are chosen to indicate the default and no-deletion  *)
  53. (* cases since (-1 div 2) lines is zero and (limit / +1) would result in no     *)
  54. (* retained output.                                                             *)
  55.  
  56.     case Sign(slop) of
  57.       -1: if slop = -1 then
  58.             halfSlop := (limit div CurtailSlop) div 2
  59.           else
  60.             halfSlop := -slop div 2;    (* Slop was number of lines             *)
  61.        0: halfSlop := 0;
  62.        1: halfSlop := (limit div slop) div 2 (* Slop was denominator            *)
  63.      end;
  64.  
  65. (* If the cursor (as distinct from scrollbar) has been placed at some position  *)
  66. (* other that the end of the displayed text then there will not be an automatic *)
  67. (* jump to the end as soon as more output arrives. However this is subject to a *)
  68. (* timeout so that if the operator is not actively investigating older messages *)
  69. (* the memo reverts to a state where it is the newer ones that are displayed.   *)
  70.  
  71.     trimmedLines := memo.Lines.Count;   (* Visible for debugging                *)
  72.     forceToEnd := caret.Y >= trimmedLines - 1;
  73. {$ifdef USE_TAG_FOR_TIMEOUT }
  74.     if forceToEnd then
  75.       memo.Tag := ptruint(UnixNow()) or 1;   (* Convenient seconds source       *)
  76. {$endif                     }
  77.     trimmedLines := 0;
  78.     try
  79.       if (slop <> 1) and (memo.Lines.Count > limit + halfSlop) then begin
  80.         while memo.Lines.Count > limit - halfSlop do begin
  81.           result += memo.Lines[0].Length + 1;
  82.           memo.Lines.Delete(0);
  83.           trimmedLines += 1;
  84.           if caret.Y > 0 then
  85.             caret.Y -= 1
  86.         end;
  87.  
  88. (* If that's left us on a non-blank line then advance to the next blank line,   *)
  89. (* then one more to get rid of that as well.                                    *)
  90.  
  91.         if blockText then begin
  92.           while (memo.Lines.Count > 0) and (memo.Lines[0] <> '') do begin
  93.             result += memo.Lines[0].Length + 1;
  94.             memo.Lines.Delete(0);
  95.             trimmedLines += 1;
  96.             if caret.Y > 0 then
  97.               caret.Y -= 1
  98.           end;
  99.           if (memo.Lines.Count > 0) and (memo.Lines[0] = '') then begin
  100.             result += memo.Lines[0].Length + 1;
  101.             memo.Lines.Delete(0);
  102.             trimmedLines += 1;
  103.             if caret.Y > 0 then
  104.               caret.Y -= 1
  105.           end
  106.         end
  107.       end;
  108.  
  109. (* Scrolling etc. behaviour above and in finally block below largely cribbed    *)
  110. (* from WatchP0x via PSTalk.                                                    *)
  111.  
  112.       memo.Lines.Append(line)
  113.     finally
  114. {$ifndef USE_TAG_FOR_TIMEOUT }
  115.       if forceToEnd then
  116. {$else                       }
  117.       if forceToEnd or (ptruint(UnixNow()) - memo.Tag > timeout) then
  118. {$endif                      }
  119.         if memo.Lines.Count > 0 then begin
  120.           caret.Y := memo.Lines.Count - 1;
  121.           caret.X := 0
  122.         end
  123.     end;
  124.     if hasBeenVisible then              (* Avoid "SetCaretPos called without handle" *)
  125.       try
  126.         memo.CaretPos := caret
  127.       except
  128.       end
  129.   finally
  130.     memo.Lines.EndUpdate
  131.   end
  132. end { CurtailedAppend } ;
  133.  

For a TMemo it can be called like this:

Code: Pascal  [Select][+][-]
  1. (* Output a single line.
  2. *)
  3. procedure TFrameOutfield.PaneAppend(const line: ansistring);
  4.  
  5. begin
  6.   CurtailedAppend(MemoOutfield, line, true)
  7. end { TFrameOutfield.PaneAppend } ;
  8.  

while the code for a TRichMemo is only slightly more complex:

Code: Pascal  [Select][+][-]
  1. (* Output a single line.
  2. *)
  3. procedure TFrameInfield.PaneAppend(const line: ansistring; colour: TColor= clDefault);
  4.  
  5. var
  6.   existingTextLength: integer;
  7.  
  8. begin
  9.   existingTextLength := Length(RichMemoInfield.Lines.Text);
  10.   existingTextLength -= CurtailedAppend(RichMemoInfield, line, true);
  11.  
  12. (* CurtailedAppend() returns the number of characters deleted (if any) from the *)
  13. (* start of the TMemo or TRichMemo. This is used to adjust the start point of   *)
  14. (* the range to be coloured.                                                    *)
  15.  
  16.   if colour <> clDefault then
  17.     RichMemoInfield.SetRangeColor(existingTextLength, Length(line), colour)
  18. end { TFrameInfield.PaneAppend } ;
  19.  

Performance is sufficiently good that I've not investigated appending a block as a single operation. It should be easy enough with CurtailedAppend() called only for the final line, with suitable consideration of the length parameter (the example above doesn't colour the EOL, which might slow line addition down but OTOH might speed deletion up).

Hoping that is useful to somebody.

MarkMLl
« Last Edit: June 07, 2024, 10:03:31 am by MarkMLl »
MT+86 & Turbo Pascal v1 on CCP/M-86, multitasking with LAN & graphics in 128Kb.
Pet hate: people who boast about the size and sophistication of their computer.
GitHub repositories: https://github.com/MarkMLl?tab=repositories

cdbc

  • Hero Member
  • *****
  • Posts: 1247
    • http://www.cdbc.dk
Re: TRichMemo and text colour
« Reply #10 on: June 02, 2024, 02:48:24 am »
Hi
Nice, good on you Mark.
Quote
Hoping that is useful to somebody.
It is, Thanks  :)
Regards Benny
If it ain't broke, don't fix it ;)
PCLinuxOS(rolling release) 64bit -> KDE5 -> FPC 3.2.2 -> Lazarus 2.2.6 up until Jan 2024 from then on it's: KDE5/QT5 -> FPC 3.3.1 -> Lazarus 3.0

MarkMLl

  • Hero Member
  • *****
  • Posts: 6930
Re: TRichMemo and text colour
« Reply #11 on: June 05, 2024, 09:19:18 am »
I've edited that example function I provided with a couple more internal error checks, and to use the memo's .Tag property for a seconds timeout so that if the user has scrolled (and set the cursor) to look at an older message it will revert to displaying newly-appended messages after 2:30. That originally used a static variable (initialised constant), but that's obviously NBG if multiple memos are being used.

MarkMLl
MT+86 & Turbo Pascal v1 on CCP/M-86, multitasking with LAN & graphics in 128Kb.
Pet hate: people who boast about the size and sophistication of their computer.
GitHub repositories: https://github.com/MarkMLl?tab=repositories

cdbc

  • Hero Member
  • *****
  • Posts: 1247
    • http://www.cdbc.dk
Re: TRichMemo and text colour
« Reply #12 on: June 05, 2024, 10:07:49 am »
Hi
Nifty little solution, Me Likey  ;)
Regards Benny
If it ain't broke, don't fix it ;)
PCLinuxOS(rolling release) 64bit -> KDE5 -> FPC 3.2.2 -> Lazarus 2.2.6 up until Jan 2024 from then on it's: KDE5/QT5 -> FPC 3.3.1 -> Lazarus 3.0

MarkMLl

  • Hero Member
  • *****
  • Posts: 6930
Re: TRichMemo and text colour
« Reply #13 on: June 07, 2024, 01:07:53 pm »
Hi
Nifty little solution, Me Likey  ;)
Regards Benny

It appears that system colours like clGrayText can't be used in this context, although that might depend on the widget set.

I've added a term to force the tag's LSB to 1 which will reduce the risk it could be confused with a reference to an object.

MarkMLl
MT+86 & Turbo Pascal v1 on CCP/M-86, multitasking with LAN & graphics in 128Kb.
Pet hate: people who boast about the size and sophistication of their computer.
GitHub repositories: https://github.com/MarkMLl?tab=repositories

 

TinyPortal © 2005-2018