Solved

TRichEdit and Colors

Posted on 2004-09-18
41
652 Views
Last Modified: 2010-04-16
Greetings,

I am using a TRichEdit component in hopes of getting some colors into my application.

Anyway, right now I am using a thread that uses a DisplayString() function that syncronizes with a DoDisplay() function that simply does a memo.lines.add(string).

I'd like to change it a bit so I can do colors and stuff...

[BNET] Connected to server.

I would like the 'BNET' part to be red and the rest to be orange or something.  Perhaps done like this.

WriteColorText(clRed,'[BNLS]');
writeLnColorText(clOrange,'Connected to server.');

Also, there is a small part of my program that I would like to display a data dump that needs to be mono-spaced...

[BNET]Sent: SID_AUTH_INFO
0000:  FF 50 3A 00 00 00 00 00 36 38 58 49 50 58 33 57 .P:.....68XIPX3W
0010:  10 00 00 00 53 55 6E 65 18 BA 00 A6 F0 00 00 00 ....SUne........
0020:  09 04 00 00 09 04 00 00 55 53 41 00 55 6E 69 74 ........USA.Unit
0030:  65 64 20 53 74 61 74 65 73 00                   ed States.      
[BNET]Recv: SID_PING
0000:  FF 25 08 00 55 12 05 BE                         .%..U...        

Anyone know how this can be done in an easy to do fashion?  I am not all that good with RTF codes.  I know in a normal TMemo component, you can set it to a fixedys font, but I don't want the whole thing displaying that way.

Also, I've seen things about using the sel properties or whatever it is called, but it is not all that easy to work with nor practical.

And please don't just send me links to commonly known sites and expect points for it.  I hate that.  God knows, I've been using all the search engines at looked at all the sites that came up. :)
0
Comment
Question by:werehamster-
  • 20
  • 13
  • 4
  • +2
41 Comments
 
LVL 12

Expert Comment

by:esoftbg
ID: 12094426
unit Unit1_Q_21136532;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, StrUtils;

type
  TForm1 = class(TForm)
    RichEdit: TRichEdit;
    ButtonRed: TButton;
    ButtonBlack: TButton;
    ButtonColor: TButton;
    procedure ButtonRedClick(Sender: TObject);
    procedure ButtonBlackClick(Sender: TObject);
    procedure ButtonColorClick(Sender: TObject);
  private   { Private declarations }
  public    { Public declarations }
    procedure ColoringAWord(S: string; C: TColor);
    procedure AWordInRed(S: string; C,CRest: TColor);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.ColoringAWord(S: string; C: TColor);
var
  P:      Integer;
  L:      Integer;
  T:      string;
begin
  T := RichEdit.Text;
  L := Length(S);
  P := Pos(S, T);
  while (P>0) do
  begin
    RichEdit.SelStart := P-1;
    RichEdit.SelLength := L;
    RichEdit.SelAttributes.Color := C;
    P := PosEx(S, T, P+L);
  end;
  RichEdit.SelLength := 0;
end;

procedure TForm1.AWordInRed(S: string; C,CRest: TColor);
var
  I:      Integer;
  L:      Integer;
  N:      Integer;
  P:      Integer;
  LL:     Integer;
  PN:     Integer;
  T:      string;
begin
  LL := 0;
  PN := 0;
  T := RichEdit.Text;
  L := Length(S);
  P := Pos(S, T);
  while (P>0) do
  begin
    N := 0;
    for I := 0 to RichEdit.Lines.Count-1 do
    begin
      LL := Length(RichEdit.Lines[I]);
      N := N + LL;
      if (N>P) then
      begin
        PN := Pos(S, RichEdit.Lines[I]);
        Break;
      end;
    end;
    RichEdit.SelStart := P-1;
    RichEdit.SelLength := L;
    RichEdit.SelAttributes.Color := C;
    RichEdit.SelStart := P+Length(S)-1;
    RichEdit.SelLength := LL - L - PN + 1;
    RichEdit.SelAttributes.Color := CRest;
    P := PosEx(S, T, P+L);
  end;
  RichEdit.SelLength := 0;
end;

procedure TForm1.ButtonRedClick(Sender: TObject);
var
  T:      string;
begin
  T := RichEdit.Text;
  RichEdit.SelStart := 0;
  RichEdit.SelLength := Length(T);
  RichEdit.SelAttributes.Color := clBlack;
  RichEdit.SelLength := 0;
  AWordInRed('[BNET]', clRed, clBlue);
end;

procedure TForm1.ButtonColorClick(Sender: TObject);
var
  T:      string;
begin
  T := RichEdit.Text;
  RichEdit.SelStart := 0;
  RichEdit.SelLength := Length(T);
  RichEdit.SelAttributes.Color := clGreen;
  RichEdit.SelLength := 0;
  ColoringAWord('[BNET]', clFuchsia);
end;

procedure TForm1.ButtonBlackClick(Sender: TObject);
var
  T:      string;
begin
  T := RichEdit.Text;
  RichEdit.SelStart := 0;
  RichEdit.SelLength := Length(T);
  RichEdit.SelAttributes.Color := clBlack;
  RichEdit.SelLength := 0;
end;

end.

//........

object Form1: TForm1
  Left = 224
  Top = 128
  Width = 696
  Height = 480
  Caption = 'Coloring a word'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object RichEdit: TRichEdit
    Left = 0
    Top = 38
    Width = 688
    Height = 408
    Align = alBottom
    Font.Charset = RUSSIAN_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'Courier New'
    Font.Style = []
    Lines.Strings = (
      '[BNET]Sent: SID_AUTH_INFO'
     
        '0000: FF 50 3A 00 00 00 00 00 36 38 58 49 50 58 33 57 .P:.....68' +
        'XIPX3W'
     
        '0010: 10 00 00 00 53 55 6E 65 18 BA 00 A6 F0 00 00 00 ....SUne..' +
        '......'
     
        '0020: 09 04 00 00 09 04 00 00 55 53 41 00 55 6E 69 74 ........US' +
        'A.Unit'
      '0030: 65 64 20 53 74 61 74 65 73 00 ed States. '
      '[BNET]Recv: SID_PING'
      '0000: FF 25 08 00 55 12 05 BE .%..U... ')
    ParentFont = False
    TabOrder = 0
  end
  object ButtonRed: TButton
    Left = 8
    Top = 8
    Width = 80
    Height = 25
    Caption = 'Red'
    TabOrder = 1
    OnClick = ButtonRedClick
  end
  object ButtonBlack: TButton
    Left = 192
    Top = 8
    Width = 80
    Height = 25
    Caption = 'Black'
    TabOrder = 2
    OnClick = ButtonBlackClick
  end
  object ButtonColor: TButton
    Left = 100
    Top = 8
    Width = 80
    Height = 25
    Caption = 'Color'
    TabOrder = 3
    OnClick = ButtonColorClick
  end
end
0
 
LVL 12

Expert Comment

by:esoftbg
ID: 12094547
download example from:
page:        http://www.geocities.com/esoftbg/
  link:        Q_21136532.zip
0
 

Author Comment

by:werehamster-
ID: 12094623
I found plenty of examples on how to search and change the color of items at a specific line, but I really want something that will let me change the color of just one line of text as I add it on and let is stay that color as it scrolls up.

Also, is there a way to make it so that only the 0000: 00 00 00 00 lines are mono spaced, but the rest are not?

Ideally I'd like something like, maybe,

procedure WriteC(S: String; C : TColor = clBlack; F : TFont = SomeDefaultFont);
and a Writeln() that will do the same, but will compile the line and display it in the TRichEdit or something.

WriteC('Some Text in red, ',clRed);
WriteLnC(' and some more text in black.');

Is something like this doable?  I don't think it is very efficient to search the whole stringlist everytime a line is added.
0
 

Author Comment

by:werehamster-
ID: 12094708
If I do something like this, the rest of the memo changes to the same color and only the last word I set is the correct color...

procedure TForm1.Button1Click(Sender: TObject);
var
  T,S:      string;
  B: Integer;
begin

  T := RichEdit.Text;
  B := Length(T);
  S := 'Another Test';
  RichEdit.Text := T + S;
  RichEdit.SelStart := B;
  RichEdit.SelLength := Length(S);
  RichEdit.SelAttributes.Color := clRed;

  T := RichEdit.Text;
  B := Length(T);
  S := '- Another Test';
  RichEdit.Text := T + S;
  RichEdit.SelStart := B;
  RichEdit.SelLength := Length(S);
  RichEdit.SelAttributes.Color := clBlue;
  RichEdit.Lines.Add('')
end;

I'm guessing setting .text resets the color information so that the whole memo is the same color.  I'd really hate to have to make a list of where colors should start and end.
0
 

Author Comment

by:werehamster-
ID: 12094710
What about doing something with RTF codes {}'s?  Can that be done?
0
 

Author Comment

by:werehamster-
ID: 12094743
I was playing with this.  I get some results out of it, but I get an error that I don't know if I should just be suppressing with the try .. except wrap.  Plus it seems rather long way of doing things...

  S := '{\rtf1\ansi\ansicpg1252\deff0\deflang1033{\fonttbl{\f0\fswiss\fcharset0 Arial;}}'
       +'{\colortbl ;\red255\green0\blue0;}{\*\generator Msftedit 5.41.15.1507;}\viewkind4\uc1\pard\f0\fs20\par [22:27:40] <Beam[1G]> 5.61 gogogogo\par [22:27:42] <\cf1 Beam[1G]>\cf0  f00s\par [22:27:48] <StolenHitman> is it me or 5.62 lagging more?\par}';
  try
  RichEdit.Lines.Add(S);
  except
  end;
0
 
LVL 4

Assisted Solution

by:Evarest
Evarest earned 25 total points
ID: 12094872
If I understand you correctly, you want the following:

 1) Add a line to your richedit. As additional param, you give the color the text must have. For example:
WriteColorText(clRed,'[BNLS]');
writeLnColorText(clOrange,'Connected to server.');

 2) Monospace some lines.

1) This can be done as follows:

Just place a TRichEdit on your form along with two TButtons. Attach the following procedures to the Buttons. WriteC is overloaded, and should be declared in the private section.

[BEGIN CODE]

//...
  private
    procedure WriteC(S: String; C: TColor = clBlack); overload;
    procedure WriteC(List: TList); overload;
    { Private declarations }
//...

type
  PLineInfo = ^TLineInfo;
  TLineInfo = record
    Str: string;
    Color: TColor;
  end;


procedure TForm1.WriteC(S: String; C : TColor = clBlack);
begin
 with RichEdit1, Richedit1.SelAttributes do
  begin
   SelStart := GetTextLen;
   Size     :=8;
   Color    :=C;
   Style    :=[];
   selText  := S;
   Lines.Add('');
  end;
end;

procedure TForm1.WriteC(List: TList);
var
 Q: integer;
begin
 with RichEdit1, Richedit1.SelAttributes do
  begin
   for Q :=0 to List.Count -1 do
    begin
     SelStart := GetTextLen;
     Size     :=8;
     Color    :=PLineInfo(List[Q])^.Color;
     Style    :=[];
     selText  :=PLineInfo(List[Q])^.Str;
    end;
   Lines.Add('');
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
 NewLine: TList;
 LineInfo: PLineInfo;
begin
 NewLine :=TList.Create;
 new(LineInfo);
 LineInfo^.Str :='test ';
 LineInfo^.Color :=clBlue;
 NewLine.Add(LineInfo);
 new(LineInfo);
 LineInfo^.Str :='test';
 LineInfo^.Color :=clRed;
 NewLine.Add(LineInfo);

 WriteC(NewLine);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
 WriteC('test', clRed);
end;

[END CODE]

Usage: you can either write 1 line in 1 color, or 1 line in several colors. To do the latter, you need to create a small TList that contains the strings and their resp colors. This info is contained in the record LineInfo.

You can optimize this code by creating a separate Class for the NewLine: TList; I use. This will enable you to better define the font (face, color, size, etc) without making your code unreadable...

Kind regards and good luck!
Evarest
0
 
LVL 12

Expert Comment

by:esoftbg
ID: 12095102
download the example again:

unit Unit1_Q_21136532;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, StrUtils;

type
  TForm1 = class(TForm)
    RichEdit: TRichEdit;
    ButtonBlack: TButton;
    ButtonColor: TButton;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    procedure ButtonBlackClick(Sender: TObject);
    procedure ButtonColorClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private   { Private declarations }
  public    { Public declarations }
    procedure ColoringAWord(S: string; F: TFont);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.ColoringAWord(S: string; F: TFont);
var
  P:      Integer;
  L:      Integer;
  T:      string;
begin
  T := RichEdit.Text;
  L := Length(S);
  P := Pos(S, T);
  while (P>0) do
  begin
    RichEdit.SelStart := P-1;
    RichEdit.SelLength := L;
    RichEdit.SelAttributes.Assign(F);
    P := PosEx(S, T, P+L);
  end;
  RichEdit.SelLength := 0;
end;

procedure TForm1.ButtonColorClick(Sender: TObject);
var
  F:      TFont;
  T:      string;
begin
  T := RichEdit.Text;
  RichEdit.SelStart := 0;
  RichEdit.SelLength := Length(T);
  RichEdit.SelAttributes.Color := clBlue;
  RichEdit.SelLength := 0;
  F := TFont.Create;
  try
    F.Name := 'Times New Roman';
    F.Height := 9;
    F.Size := -16;
    F.Color := clRed;
    F.Style := [fsBold, fsUnderline];
    ColoringAWord('[BNET]', F);
    F.Name := 'MS Sans Serif';
    F.Height := 11;
    F.Size := -12;
    F.Color := clFuchsia;
    F.Style := [fsBold,fsItalic];
    ColoringAWord('Connected to server.', F);
  finally
    F.Destroy;
  end;
end;

procedure TForm1.ButtonBlackClick(Sender: TObject);
var
  T:      string;
begin
  T := RichEdit.Text;
  RichEdit.SelStart := 0;
  RichEdit.SelLength := Length(T);
  RichEdit.SelAttributes.Color := clBlack;
  RichEdit.SelLength := 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  P:      Integer;
  S:      string;
  T:      string;
  R:      string;
begin
  if (Sender.ClassType=TButton) then
  begin
    case (Sender as TButton).Tag of
      1: S := Edit1.Text;
      2: S := Edit2.Text;
      3: S := Edit3.Text;
      4: S := Edit4.Text;
    end;
    P := Pos(' ', S);
    while (P>0) do
    begin
      T := S[P-2] + S[P-1];
      R := S[P+1] + S[P+2];
      if ((T='0:') or (T='00')) and (R='00') then
      begin
        Delete(S, P, 1);
        P := PosEx(' ', S, P);
      end
      else
        P := 0;
    end;
    RichEdit.Lines.Add(S);
    ButtonColorClick(Self);
  end;
end;

end.
0
 

Author Comment

by:werehamster-
ID: 12098643
esoftbq,

Your code looks liek it works great, but I don't want to have to re-colorized the entire memo just to add one line of text.  I'll look into both things tonight.  I do, however, appreciate any and all help and will still provide points accordingly.

As of right now, though haven't looked at recent things in detail yet, haven't found a solution.
0
 

Author Comment

by:werehamster-
ID: 12099036
esoftbg,
Alright, I tried it.  It seems to "work", but not very desirable.  It is extremely flickery and doesn't seem like a very practically way to do it concidering it would involve a lot of coding.

Evarest,
I haven't tried your code yet, but it looks like it doesn't allow for making a line that has many different color text on it.  I was thinking of using WriteC() to store the text and colors in the buffer, and when it does a WriteCLn() it then adds the line of text with the appropriate coloring.

Anyway,
I will see if I can take pieces of code here and put it to some good use, but for now I am still searching for a "better way", even if it does not currently exist.

Through my own experimentation, I have been able to use RTF codes instead of the selection and color process, just I get some errors that I don't know if I should ignore or not with the try...except wrapping.

Let me ask this though,
Can I add a line of text without recoloring the text that has already been added?  It just seems a waste of searching and recoloring if it does not need to do that.  Apparently it seems that as long as I don't touch the .text property, it leaves what is there alone.  I've got to be able to use that some how.
0
 
LVL 12

Expert Comment

by:esoftbg
ID: 12099246
werehamster-,
It is possible to be colorized only the just-added text. I am starting to develope that ....
0
 

Author Comment

by:werehamster-
ID: 12099350
I have been spending the last couple of hours seeing if I could find source for forum code or something...

I was thinking if I could do something that would let me do something like...

The [color=red]apple[/color] was good.

... it would be perfect.  Maybe something a little more simple than that though.

Another thing with RichEdit control that is bugging me out is that when you add a new line of text, the screen does not follow it.  It goes off the screen while you are still looking at the first lines.

Also, I've been playing with RTF some more.  I can get it to work that way as well, but I keep getting errors everytime I put a line in.  I use try..except to suppress it, but dunno if this is the best way.  It seems rather complex.

Even if I can use something other than a RichEdit control, all i really want to do is diplay text in different colors without using any fancy keyword scheme or whatever.  Like old turbo pascal days, but can be used just like a Memo from the user's standpoint where they can cut and paste.

SetColor(Red);
Write('[BNET]');
SetColor(Black);
Writeln('Connected.');

I am sure someone has done this before.  It doesn't seem like something that would have gone unnoticed.
0
 
LVL 12

Expert Comment

by:Ivanov_G
ID: 12099638
procedure AddColorLine (RichEdit : TRichEdit; Str : String; Color : TColor);
var
  pos_start      : Integer;
  pos_end        : Integer;
  old_SelAttr    : TTextAttributes;
begin
  // take the old SelAttributes
  old_SelAttr := RichEdit.SelAttributes;
  // get the end pos
  pos_start := length(RichEdit.Text);
  // add the text
  RichEdit.Lines.Add(Str);
  // the the new end position
  pos_end := length(RichEdit.Text);
  // colorize the text
  RichEdit.SelStart := pos_start;
  RichEdit.SelLength := pos_end - pos_start;
  RichEdit.SelAttributes.Color := Color;
  // put back the old attributes
  RichEdit.SelAttributes := old_SelAttr;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  AddColorLine(RichEdit1, 'Hello world!', clGreen);
  AddColorLine(RichEdit1, 'RedLine!', clRed);
end;
0
 
LVL 12

Expert Comment

by:Ivanov_G
ID: 12099657
I just thought you may need something additional like bold or italic... This is the same produre as above, but with some more features :)))
-----------------------------------------------------------------------------------------------

procedure AddColorLine (RichEdit : TRichEdit; Str : String; Color : TColor;
  IsBold : Boolean = False; IsItalic : Boolean = False);
var
  pos_start      : Integer;
  pos_end        : Integer;
  old_SelAttr    : TTextAttributes;
begin
  // take the old SelAttributes
  old_SelAttr := RichEdit.SelAttributes;
  // get the end pos
  pos_start := length(RichEdit.Text);
  // add the text
  RichEdit.Lines.Add(Str);
  // the the new end position
  pos_end := length(RichEdit.Text);
  // colorize the text
  RichEdit.SelStart := pos_start;
  RichEdit.SelLength := pos_end - pos_start;
  RichEdit.SelAttributes.Color := Color;
  // set bold
  if IsBold then
    RichEdit.SelAttributes.Style := RichEdit.SelAttributes.Style + [fsBold];
  // set italic
  if IsItalic then
    RichEdit.SelAttributes.Style := RichEdit.SelAttributes.Style + [fsItalic];
  // put back the old attributes
  RichEdit.SelAttributes := old_SelAttr;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  AddColorLine(RichEdit1, 'Hello world!', clGreen, True);
  AddColorLine(RichEdit1, 'RedLine!', clRed, False, True);
end;
0
 

Author Comment

by:werehamster-
ID: 12099672
Anyway, fornot, I am using...

procedure TBNETReader.DoDisplayString;
begin
  FForm.OutputBox.SelAttributes.Color := fDisplayColor;
  fForm.OutputBox.Lines.Add(fDisplayString)
end;

procedure TBNETReader.DisplayString(AString:String; Color : TColor = clBlack);
begin
  fDisplayString := AString;
  fDisplayColor := Color;
  synchronize(DoDisplayString);
end;

It seems to work well for my purposes (for now), but I would still like to be able to make just part of the string one color.  maybe embed some codes into the AString which is ommited when displayed, but used after the line is displayed to add color to 1 word or something.  Plus I still want the ability to change the font spacing to monospacing when I display dumps and stuff.  Any help with this?

DisplayString('Some Text '+DoColor(clRed)+'Red'+doColor(clDefault)+' something '+doFont(myFont)+'different.');

where doColor() and doFont() are functions that return a string with embedded codes to tell where to change colors and stuff.
0
 
LVL 12

Expert Comment

by:esoftbg
ID: 12099674
download example again from:
page:        http://www.geocities.com/esoftbg/
  link:        Q_21136532.zip

//........

unit Unit1_Q_21136532;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, StrUtils;

type
  TForm1 = class(TForm)
    RichEdit: TRichEdit;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    procedure Button1Click(Sender: TObject);
  private   { Private declarations }
    OldLinesCount:    Integer;
    OldLegth:         Integer;
  public    { Public declarations }
    procedure AWordColoring(S: string; F: TFont; FR: TFont);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.AWordColoring(S: string; F: TFont; FR: TFont);
var
  C:      Integer;
  L:      Integer;
  P:      Integer;
  T:      string;
begin
  C := 0;
  T := RichEdit.Text;
  L := Length(S);
  P := Pos(S, T);
  while (P>0) do
  begin
    if (P>OldLegth) then
    begin
      Inc(C);
      RichEdit.SelStart := P - 1;
      RichEdit.SelLength := L;
      RichEdit.SelAttributes.Assign(F);
      RichEdit.SelStart := P + L - 1;
      RichEdit.SelLength := Length(T) - OldLegth - L + 1;
      RichEdit.SelAttributes.Assign(FR);
      OldLegth := OldLegth + L;
    end;
    P := PosEx(S, T, P+L);
  end;
  if (C=0) then
  begin
    RichEdit.SelStart := OldLegth+1;
    RichEdit.SelLength := Length(T) - OldLegth + 1;
    RichEdit.SelAttributes.Assign(FR);
  end;
  RichEdit.SelLength := 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  P:      Integer;
  F:      TFont;
  FR:     TFont;
  S:      string;
  T:      string;
  R:      string;
begin
  if (Sender.ClassType=TButton) then
  begin
    case (Sender as TButton).Tag of
      1: S := Edit1.Text;
      2: S := Edit2.Text;
      3: S := Edit3.Text;
      4: S := Edit4.Text;
    end;
    P := Pos(' ', S);
    while (P>0) do
    begin
      T := S[P-2] + S[P-1];
      R := S[P+1] + S[P+2];
      if ((T='00') and (R='00')) then
      begin
        Delete(S, P, 1);
        P := PosEx(' ', S, P);
      end
      else
        P := 0;
    end;

    OldLegth := Length(RichEdit.Text);
    OldLinesCount := RichEdit.Lines.Count;
    RichEdit.Lines.Add(S);

    F := TFont.Create;
    try
      FR := TFont.Create;
      try
        FR.Size := 12;
        FR.Color := clBlue;
        FR.Style := [fsBold];

        F.Name := 'Times New Roman';
        F.Size := 12;
        F.Color := clRed;
        F.Style := [fsBold, fsUnderline];
        AWordColoring('[BNET]', F, FR);
        F.Name := 'MS Sans Serif';
        F.Size := 12;
        F.Color := clFuchsia;
        F.Style := [fsBold,fsItalic];
        AWordColoring('Connected to server.', F, FR);
      finally
        FR.Destroy;
      end;
    finally
      F.Destroy;
    end;
  end;
end;

end.
0
 

Author Comment

by:werehamster-
ID: 12099798
It is looking more promising now actually.  Though I still have some problems with it.  It is keeping the view at the top of the memo and not automatically scrolling down after a line is added.

Also, instead of searching for fixed words like 'BNET' and stuff, i think it could probalbly be changed to look between keywords in the string.

So what if we had a string

'The quick brown fox jumps over the lazy dog. The quick brown fox jumps over the lazy dog.'

if we wanted the word 'dog' to be colorized, we could do something like this...

'The quick brown fox jumps over the lazy dog. The quick brown fox jumps over the lazy [$C00FF000000]dog[$C...].'

'... the lazy '+DoColor(clBlue)+'dog'+DoColor(clDefault)+'.'

which would do a WordColoring('dog',...);

but if I had more than one of the say word, but only wanted one colorized, there would be a problem with your function I think.

So what if we did some kind of list of positions based on keywords in the string that get ommited before added, and then colorized.  But only on the last line added and not the whole memo field, but retained the prior colors?  Perhaps something with font data instead of just color.  The function could strip the data of all the codes, add the line, then use the codes to colorize it.  If I'm repeating myself it is because it is 3am.  :)
0
 
LVL 12

Expert Comment

by:esoftbg
ID: 12099845
Take a look at:

    if (P>OldLegth) then
    begin
      Inc(C);
This means that my code works only with new added line ....

And about the 'dog' lazy or not it is possible to be colorized only the first ot the specified count of it ....
Just wait a little bit ....
0
 
LVL 12

Assisted Solution

by:Ivanov_G
Ivanov_G earned 25 total points
ID: 12099882
> I would still like to be able to make just part of the string one color. maybe embed some codes into the AString which
> is ommited when displayed, but used after the line is displayed to add color to 1 word or something.  Plus I still want
> the ability to change the font spacing to monospacing when I display dumps and stuff.  Any help with this?

I tried once using
Text1 <B>Bold part</B> another part <I>Italic</I>

and it was paint in the ass. The whole problem came from the storing these values into the text, because they mess up the length of the strings and thus it is more difficut to use SelAttributes.

Another problem will be if you have
<B><I>Some text here</I></B>
0
 
LVL 12

Expert Comment

by:Ivanov_G
ID: 12099899
Just and idea ... you can use TWebBrowser + regular expressions...

with the regular expression you can replace
[B]some text[/B]

with
<STRONG>some text</STRONG>

just like this is done in the Forums and Bulletin Boards. This practise is called "BBCodes"...
0
Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

 
LVL 12

Expert Comment

by:esoftbg
ID: 12099947
pleaese download the example again.... it can select 1 or two 'dogs' ....
0
 

Author Comment

by:werehamster-
ID: 12099990
I can understand your code and how it works, but it seems to be something that will be cumbersome to actually use in a program that uses all sorts of different colors and stuff.  You are making me add like 12 lines of code to like 100 spots in my program.

I need simplicity.

I supposed I could do some of it in a wrapper somehow.

TC('Blah',Color, TC(' more blah',Color2,NIL));

bah, too complicated.  :)
0
 
LVL 12

Expert Comment

by:esoftbg
ID: 12100076
I am going to make the code more simply. I have an idea ....
0
 

Author Comment

by:werehamster-
ID: 12100135
I see the quick changes you made, just the AWordColoring is not practical if you are trying to colorize all different parts of the program and there is a possiblity that a user can manually type in keywords and stuff that would normally be colorized, but shouldn't be in certain situations and stuff.

It is, however, giving me ideas to improve upon.  I'm just not good with string manipulation in delphi all that much.

Ok, this is largely untested as I wrote this in this topic instead of in the editor, but tell me what you think about this...  Perhaps if it looks promising, someone could fix it up.  I got some other work I gotta do now.  :)

procedure DisplayString(S: String);
var
  SelStart, SelLength,P : Integer;
  Stripped : String;
  C : TColor;
repeat
  P := PosEx('[$',AString,1) ; // [$00000000]
  If P > 0 then
    begin
      Stripped := Left(S,P) + Right(S, Length(S)-(P+11)  // prolly errors on this line
      SelStart :- OldLength + P;
      SelLength := Length(stripped) - P;
      P := PosEx('[$',Stripped,1);

      TByteArray(C)[0] := ord(S[P+2]);
      TByteArray(C)[1] := ord(S[P+3]);
      TByteArray(C)[2] := ord(S[P+4]);
      TByteArray(C)[3] := ord(S[P+5]);

      If P = 0 then P := Length(Stripped);
      DisplayString(Stripped);
     
      RE.SelStart := SelStart;
      RE.Length := SelLength;
      RE.Color := C;
end;
0
 

Author Comment

by:werehamster-
ID: 12100144
oh, forgot something like...

    end
    else addline(S);
0
 

Author Comment

by:werehamster-
ID: 12100156
If ya got ICQ 33957229 or AIM/MSN: stevenjmorales@aol or yahoo:korotish, feel free to drop me a chat.
0
 

Author Comment

by:werehamster-
ID: 12100182
Hmm, if I am using Ords() would only be 4 bytes long I guess, not 8.  which would make the stripped right be like P+7 instead of 11.  Anyway, I am going to see if I can make this work.

Recursive stuff can be funny sometimes, so if ya got a better way, I'm all eyes.
0
 
LVL 12

Expert Comment

by:esoftbg
ID: 12100338
pleaese download the example again.... it is a super simply example ....

But you don't must to use the example with TEdits, I am using it this way to be more easy the testing ....
On FormCreate event it fills the dynamic array of 3 words (you can change it in your needs)....
Then every call of the procedure is very, very simple:

    AWordColoring(ColorWordArr, NewS, N);

ColorWordArr is filled at FormCreate();
You send only 2 params:
  -  NewS - string to be added and colored
  -  How many times to be colored

Emil

0
 

Author Comment

by:werehamster-
ID: 12100558
ok, check this out....  :)


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ComCtrls, StrUtils;

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    Panel1: TPanel;
    Button1: TButton;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TByteArray = array[word] of byte;

var
  Form1: TForm1;

implementation

{$R *.dfm}



procedure DisplayString(S: String; Offset : integer = 0);
var
  SelStart, SelLength,P : Integer;
  Stripped : String;
  AColor : TColor;
  OldLength : Integer;

begin
  OldLength := Length(Form1.RichEdit1.text);
  P := PosEx('[$',S,1) ; // [$00000000]
  If P > 0 then
    begin
      SelStart := OldLength+P-1;
      AColor := StrToInt(MidStr(S,P+1,9));
      Stripped := LeftStr(S,P-1)+RightStr(S, Length(S)-(P+10));  // prolly errors on this line
      SelLength := PosEx('[$',Stripped,1)-1;
      If SelLength <= 0 then SelLength := Length(stripped);

      DisplayString(Stripped,SelLength);

      Form1.RichEdit1.SelStart := SelStart-Offset;
      Form1.RichEdit1.SelLength := SelLength;
      Form1.RichEdit1.SelAttributes.Color := AColor;
    end
    else Form1.RichEdit1.Lines.Add(S);

end;



function doColor(C:TColor) : string;
begin
  result := '[$'+IntToHex(C,8)+']';
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DisplayString(Edit1.Text);
  DisplayString(doColor(clGreen)+'test green');
  DisplayString(doColor(clblue)+'test blue '+doColor(clRed)+'test red '+doColor(clskyblue)+'test skyblue ');
end;

end.
0
 

Author Comment

by:werehamster-
ID: 12100640
Ivanov_G,
To solve your ever changing string length, just use recursion with a returned offset like I did.

esoftbg,
Your examples pretty much taught me how to use the richedit methods correctly.  Kinda inspired me to make my idea work.

I just need to know how to get the damn thing to scroll to the bottom when a line is added instead of just seeing the beginning the whole time and having to scroll down yourself.

The fixed and proportional fonts need some working with also.  But i suppose I could set the font to it before I call dodisplay and then set it back afterwards for the few times that I actually would use it.  I just am still not sure how to even change to fixed and proportional fonts.  I know it can be changed in the memo fields, but can I have both?

Also, I gotta make this thread safe too.  :)
0
 
LVL 12

Expert Comment

by:esoftbg
ID: 12100747
> I just need to know how to get the damn thing to scroll to the bottom when a line is added instead of just seeing the  beginning the whole time and having to scroll down yourself.


didn't you see my last example ?
This code solves the problem with scrolling down to the end of the text:

  RichEdit.HideSelection := False; // This I made at design time by ObjectInspector
  RichEdit.SelStart := Length(RichEdit.Text);
  RichEdit.SelLength := 0;
0
 

Author Comment

by:werehamster-
ID: 12100809
>> This code solves the problem with scrolling down to the end of the text:

Actually, I *WANT* it to scroll to the end of the text.  I want to always see the last newly made line if it was at the last line.  I might want it not to do that if I scrolled up myself to look at what has been logged.
0
 

Author Comment

by:werehamster-
ID: 12100821
Ignore last comment.  :)  Didn't realize it worked in the last sample.  Let me see how it was done.
0
 

Author Comment

by:werehamster-
ID: 12100898
Anyway, feel free to download my version at...
www.datazap.net/ftp/werehamster/MyBot/REColor.zip

It still needs some work.

Just gonna keep the topic open a little longer just incase anyone wants to toss in a few ideas.
0
 
LVL 12

Expert Comment

by:esoftbg
ID: 12101171
Oooops,
It is needed for the scrolling down to the end of the text:
  RichEdit.ScrollBars := ssBoth; // or RichEdit.ScrollBars := ssVertical;
0
 

Author Comment

by:werehamster-
ID: 12101526
I am still not getting it to stay at the bottom.  Hmm.
0
 
LVL 12

Accepted Solution

by:
esoftbg earned 425 total points
ID: 12102356
Sory, I was sleep 2 hours (I was tired) ....

> I am still not getting it to stay at the bottom.  Hmm.

Try this code for your version:

procedure DisplayString(S: string; Offset : integer = 0);
var
  SelStart,
  SelLength,P:   Integer;
  OldLength :    Integer;
  AColor :       TColor;
  Stripped :     string;
begin
  try
    OldLength := Length(Form1.RichEdit1.text);
    P := PosEx('[$',S,1) ; // [$00000000]
    if (P > 0) and (Length(S)>P+10) and (S[P+10]=']') then
    begin
      SelStart := OldLength+P-1;
      try
        AColor := StrToInt(MidStr(S,P+1,9));
      except
        AColor := clBlack;
      end;

      Stripped := LeftStr(S,P-1)+RightStr(S, Length(S)-(P+10));  // prolly errors on this line
      SelLength := PosEx('[$',Stripped,1)-1;
      if SelLength <= 0 then
        SelLength := Length(stripped);

      DisplayString(Stripped,SelLength);

      Form1.RichEdit1.SelStart := SelStart-Offset;
      Form1.RichEdit1.SelLength := SelLength;
      Form1.RichEdit1.SelAttributes.Color := AColor;
    end
    else
    begin
      Form1.RichEdit1.Lines.Add(S);
    end;
  finally
    OldLength := Length(Form1.RichEdit1.text);
    if (OldLength>=1) then
    begin
      Form1.RichEdit1.SelStart := OldLength - 2;
      Form1.RichEdit1.SelLength := 1;
      Form1.RichEdit1.SetFocus;
    end;
  end;
end;
0
 
LVL 12

Expert Comment

by:esoftbg
ID: 12102420
Please remove this line below. It is work fine whithout it ....
      Form1.RichEdit1.SetFocus;
0
 
LVL 14

Assisted Solution

by:Pierre Cornelius
Pierre Cornelius earned 25 total points
ID: 12102876
This is what you need:

procedure AddRTFString(r: TRichEdit; F: TFont; T: string; Overwrite: Boolean);
var SaveStart, SaveLen: integer;
begin
  if Overwrite then r.SelText:= '';
  r.SelLength:= 0;
  SaveStart:= r.SelStart;
  r.Perform(EM_REPLACESEL, LongInt(TRUE), LongInt(pchar(T)));
  SaveLen:= r.SelStart - SaveStart;
  r.SelStart:= SaveStart; r.SelLength:= SaveLen;
  r.SelAttributes.Assign(F);
  r.SetFocus;
end;


EXAMPLE OF USE:
===========
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls;

type
  TForm1 = class(TForm)
    dlgFont: TFontDialog;
    GroupBox1: TGroupBox;
    inpTxt: TEdit;
    Text: TLabel;
    btnAdd: TButton;
    btnSetFont: TButton;
    inpEditor: TRichEdit;
    procedure btnSetFontClick(Sender: TObject);
    procedure btnAddClick(Sender: TObject);
  private
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure AddRTFString(r: TRichEdit; F: TFont; T: string; Overwrite: Boolean);
var SaveStart, SaveLen: integer;
begin
  if Overwrite then r.SelText:= '';
  r.SelLength:= 0;
  SaveStart:= r.SelStart;
  r.Perform(EM_REPLACESEL, LongInt(TRUE), LongInt(pchar(T)));
  SaveLen:= r.SelStart - SaveStart;
  r.SelStart:= SaveStart; r.SelLength:= SaveLen;
  r.SelAttributes.Assign(F);
  r.SetFocus;
end;

procedure TForm1.btnSetFontClick(Sender: TObject);
begin
  dlgFont.Font.Assign(inpEditor.SelAttributes);
  dlgFont.Execute;
end;

procedure TForm1.btnAddClick(Sender: TObject);
begin
  AddRTFString(inpEditor, dlgFont.Font, inpTxt.Text, true);
end;

end.


DFM FILE:
======
object Form1: TForm1
  Left = 192
  Top = 114
  Width = 322
  Height = 380
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object GroupBox1: TGroupBox
    Left = 16
    Top = 224
    Width = 281
    Height = 113
    Caption = 'Text to add'
    TabOrder = 0
    object Text: TLabel
      Left = 8
      Top = 28
      Width = 21
      Height = 13
      Caption = 'Text'
    end
    object inpTxt: TEdit
      Left = 40
      Top = 28
      Width = 161
      Height = 21
      TabOrder = 0
    end
    object btnAdd: TButton
      Left = 120
      Top = 56
      Width = 75
      Height = 25
      Caption = 'Add'
      TabOrder = 1
      OnClick = btnAddClick
    end
    object btnSetFont: TButton
      Left = 40
      Top = 56
      Width = 75
      Height = 25
      Caption = 'Set Font'
      TabOrder = 2
      OnClick = btnSetFontClick
    end
  end
  object inpEditor: TRichEdit
    Left = 16
    Top = 16
    Width = 281
    Height = 201
    Lines.Strings = (
      'inpEditor')
    TabOrder = 1
  end
  object dlgFont: TFontDialog
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    Left = 24
    Top = 280
  end
end

Regards
Pierre
0
 
LVL 14

Expert Comment

by:Pierre Cornelius
ID: 12102945
You can break up the text (i.e. referring to you write and writeln type examples) using the #13#10 pair in your string e.g.  passing this as your string will add the text in two separate lines:

SomeText:= 'Line1'#13#10'Line2';
0
 
LVL 14

Expert Comment

by:Pierre Cornelius
ID: 12103529
To scroll the Richedit control to the caretpos after inserting text, change the above function to the following:

procedure AddRTFString(r: TRichEdit; F: TFont; T: string; Overwrite, AddEOL: Boolean);
var SaveStart, SaveLen, sPos, wPrm: integer;
begin
  if Overwrite then r.SelText:= '';
  if AddEOL then t:= t+#13#10;
  r.SelLength:= 0;
  SaveStart:= r.SelStart;
  r.Perform(EM_REPLACESEL, LongInt(TRUE), LongInt(pchar(T)));
  SaveLen:= r.SelStart - SaveStart;
  r.SelStart:= SaveStart; r.SelLength:= SaveLen;
  r.SelAttributes.Assign(F);
  r.SetFocus;

  sPos:= r.Perform(EM_LINEINDEX, -1, 0);
  wPrm:= SB_THUMBPOSITION +                     //scrollCode in low word
         sPos SHL 16; //line number in high word
  if (SetScrollPos(r.Handle, SB_VERT, sPos, True) <>-1)
    then r.Perform(EM_SCROLLCARET,0,0);
end;



Also, I'm just curious. My solution is everything you asked for, why only 25 of the 500 points?
0

Featured Post

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

In this tutorial I will show you how to use the Windows Speech API in Delphi. I will only cover basic functions such as text to speech and controlling the speed of the speech. SAPI Installation First you need to install the SAPI type library, th…
Introduction I have seen many questions in this Delphi topic area where queries in threads are needed or suggested. I know bumped into a similar need. This article will address some of the concepts when dealing with a multithreaded delphi database…
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…
This video demonstrates how to create an example email signature rule for a department in a company using CodeTwo Exchange Rules. The signature will be inserted beneath users' latest emails in conversations and will be displayed in users' Sent Items…

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now