Solved

Change a word Color in RichEdit

Posted on 2001-06-10
12
1,057 Views
Last Modified: 2013-11-22
hi all
i want a simple procedure to change a word or wards color in RichEdit.
simple procedure or other:)
bakry
0
Comment
Question by:bakry99
  • 5
  • 3
  • 2
  • +2
12 Comments
 
LVL 22

Expert Comment

by:Mohammed Nasman
ID: 6172902
Hello

  this is sample from delphi help for finding a word in RichEdit, I just add one line to change the color of found text to red

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    Button1: TButton;
    FindDialog1: TFindDialog;
    procedure Button1Click(Sender: TObject);
    procedure FindDialog1Find(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

begin
  FindDialog1.Position := Point(RichEdit1.Left + RichEdit1.Width, RichEdit1.Top);
  FindDialog1.Execute;
end;

procedure TForm1.FindDialog1Find(Sender: TObject);
var
  FoundAt: LongInt;
  StartPos, ToEnd: Integer;
begin
  with RichEdit1 do
  begin
    if SelLength <> 0 then
      StartPos := SelStart + SelLength
    else
      StartPos := 0;
    ToEnd := Length(Text) - StartPos;
    FoundAt := FindText(FindDialog1.FindText, StartPos, ToEnd, [stMatchCase]);
    if FoundAt <> -1 then
    begin
      SetFocus;
      SelStart := FoundAt;
      SelLength := Length(FindDialog1.FindText);
// just add the color here
      RichEdit1.SelAttributes.color := clred;
    end;
  end;

end;

end.
0
 
LVL 1

Author Comment

by:bakry99
ID: 6172958
i think i didn't explain my question
now i make my own Editor and i want to make RESERVED WORD with different Color.

i wish u get it.

Bakry
0
 
LVL 5

Expert Comment

by:alanwhincup
ID: 6173338
Here is an example:

To use it just drop a RichEdit, Button and EditBox onto a form the put the below code as the buttons OnClick Event. After just run it and enter the text you want to be changed into the EditBox and click on the Button.

procedure TForm1.Button1Click(Sender: TObject);
var
  CurPos, StartPos : PChar;
begin
  StartPos := PChar(RichEdit1.Text);
  CurPos := StartPos;
  RichEdit1.Lines.BeginUpdate;
  try
    repeat
      CurPos := AnsiStrPos(CurPos, PChar(Edit1.Text));
      if CurPos <> nil then
      begin
        with RichEdit1 do
        begin
          SelStart := CurPos - StartPos;
          SelLength := Length(Edit1.Text);
          SelAttributes.Color := clRed;
          Inc(CurPos);
        end;
      end;
    until
      CurPos = nil;
  finally
    RichEdit1.Lines.EndUpdate;
  end;
end;

Cheers,

Alan
0
Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
LVL 2

Expert Comment

by:bugroger
ID: 6173572
Just put this code into your unit and a
TRichEdit on your form.

If you enter "Test" or "Variable" in your RichEdit
then they will be change to red.

Const
 ResWordCount : Cardinal = 0;

Var
 WordList     : TStrings;
 ResWordPos   : array of Cardinal;


Function WordWasReserved(ws : cardinal) : integer;
Var
 i : integer;

Begin
 Result := -1;

 For i := 0 to ResWordCount -1 do
  IF ws = ResWordPos[i] then
  Begin
   Result := i;
   BREAK;
  End;
End;

Procedure GetWordInfo(S : String; Pos : integer; VAR WordStart, WordLength : Integer);
Var
 i, l : Integer;
Begin
 l := Length(s);

 //Get word start
 If l = 0 then
 Begin
  WordStart    := 0;
  WordLength   := 0;
  Exit;
 End;

 IF pos = 1 then pos := 0;
 i := pos;
 While (S[i] <> ' ') and ((i) <> 0) do dec(i);
 WordStart := i;

 If i = l then
 Begin
  WordLength := 0;
  Exit;
 End;
 Inc(i);

 //Get word length
 While (S[i] <> ' ') and (i <> l) do Inc(i);
 WordLength := i - WordStart;
End;

Procedure ScanRichEdit(VAR RichEdit : TRichEdit; Words : TStrings);
Var
 xyPos                    : TPoint;
 WordStart, WordLength    : Integer;
 WordLineStartPos         : Integer;
 Word                     : string;
 WordCMP                  : string;
 i, RIdx                  : Integer;

 AddIT                    : Boolean;


Begin
 AddIt := FALSE;

 With RichEdit do
 Begin
  xyPos := CaretPos;
  GetWordInfo(Lines.Strings[xyPos.Y], xyPos.x, WordStart, WordLength);
  Word := Copy(Lines.Strings[xyPos.Y], WordStart+1, WordLength);
  IF Length(word) <> 0 then
  Begin
   IF Word[1] = ' ' then Delete(Word, 1, 1);
   IF Length(word) <> 0 then
    If Word[Length(Word)] = ' ' then Delete(Word, Length(Word), 1);
  End;

  WordLineStartPos := 0;

  For i := 0 to xyPos.Y -1 do
   WordLineStartPos := WordLineStartPos + Length(Lines.Strings[i]) +2;

  WordStart := WordLineStartPos + WordStart;



  For i := 0 to Words.Count -1 do
  Begin
   WordCMP := LowerCase(Words.Strings[i]);
   Word    := LowerCase(Word);
   //not case sensitive
   IF CompareSTR(Word, WordCMP) = 0 then
   Begin

    SetFocus;
    SelStart            := WordStart;
    SelLength           := Length(Word);
    SelAttributes.color := clred;

    SelStart            := WordLineStartPos + xyPos.x;
    SelLength           := 0;
    SelAttributes.color := clblack;

    ADDIt := TRUE
   End else
   Begin
    RIDx := WordWasReserved(wordStart);
    If (RIDx <> -1)and(not AddIT) then
    Begin
     IF RIDx < ResWordCount -1 then
      Move(ResWordPos[RIDx +1], ResWordPos[RIDx], ResWordCount -1 - RIDx);

     Dec(ResWordCount);
     SetLength(ResWordPos, ResWordCount);

     SetFocus;
     SelStart := WordStart;
     SelLength := Length(Word);
     SelAttributes.color := clblack;

     SelStart := WordLineStartPos + xyPos.x;
     SelLength := 0;
     SelAttributes.color := clblack;
    End;
   End;
  End;
 End;
 IF AddIt then
 Begin
  Inc(ResWordCount);
  SetLength(ResWordPos, ResWordCount);
  ResWordPos[ResWordCount -1] := WordStart;
 End;
End;

procedure TForm1.FormCreate(Sender: TObject);
begin
 WordList := TStringList.Create;
 With WordList do
 Begin
  Add('Test');
  Add('Variable');
 End;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 WordList.Free;
end;

procedure TForm1.RichEdit1Change(Sender: TObject);
begin
 ScanRichEdit(RichEdit1, WordList);
end;
0
 
LVL 5

Expert Comment

by:alanwhincup
ID: 6173595
You could try the below if you wanted to change text whilst it was being yped into the RichEdit:

procedure TForm1.RichEdit1Change(Sender: TObject);
var
  S : string;
  Line, I, StartPos : Integer;
const
  RWord = 'TEST';
begin
  with RichEdit1 do
  begin
    I := 0;
    StartPos := 0;
    Line := CaretPos.Y;
    S := Copy(Lines[Line], CaretPos.X - Length(RWord) + 1, Length(RWord));
    if UpperCase(S) = RWord then
    begin
      if Line > 0 then
      begin
        repeat
          StartPos := StartPos + Length(Lines[I]) + CaretPos.X - Length(RWord);
          SelStart := StartPos;
          Inc(I);
        until
          I = Line;
      end
      else
        SelStart := CaretPos.X - Length(RWord);
      SelLength := Length(RWord);
      SelAttributes.Color := clRed;
      I := 0;
      StartPos := 0;
      if Line > 0 then
      begin
        repeat
          StartPos := StartPos + Length(Lines[I]) + CaretPos.X;
          SelStart := StartPos;
          Inc(I);
        until
          I = Line;
      end
      else
        SelStart := CaretPos.X;
      SelAttributes.Color := clBlack;
    end;
  end;
end;
0
 
LVL 3

Expert Comment

by:lopem
ID: 6174314
listening
0
 
LVL 1

Author Comment

by:bakry99
ID: 6176049
ok guys
  a minute to Test your code

bakry
0
 
LVL 1

Author Comment

by:bakry99
ID: 6176491
bugroger : ur Code is good. but what about end of words?
i mean if the word is Reserved and end of it is non alpha char eg :
  Variable (Colored)
  Varable, (not colored)
  .Variable (Not Colored)
ect..

bakry
 
0
 
LVL 1

Author Comment

by:bakry99
ID: 6180640
heeeeeeeeeeeeeey
where r u?
0
 
LVL 2

Accepted Solution

by:
bugroger earned 100 total points
ID: 6180917
Here is my new code.

There must be another way to change the
text format to reduce the flicker.



Const
 EnterPressed : Boolean = FALSE;
 SpacePressed : Boolean = FALSE;


Var
 WordList                 : TStrings;

Procedure GetWordInfo(S : String; Pos : integer; VAR WordStart, WordLength : Integer);
Var
 i, l : Integer;
Begin
 l := Length(s);

 //Get word start
 If l = 0 then
 Begin
  WordStart    := 0;
  WordLength   := 0;
  Exit;
 End;

 IF pos = 1 then pos := 0;
 i := pos;
 While (S[i] in ['a'..'z','A'..'Z']) and ((i) <> 0) do dec(i);
 WordStart := i;

 If i = l then
 Begin
  WordLength := 0;
  Exit;
 End;
 Inc(i);

 //Get word length
 While (S[i] in ['a'..'z','A'..'Z']) and (i <> l) do Inc(i);
 WordLength := i - WordStart;
End;


Function GetWordLineStartPos(VAR RichEdit : TRichEdit; Y : integer) : integer;
Var
 i : Integer;

Begin
 Result := 0;
 For i := 0 to Y -1 do
  Result := Result + Length(RichEdit.Lines.Strings[i]) +2;
End;


Procedure ScanRichEdit(VAR RichEdit : TRichEdit; Words : TStrings; _xyPos : TPoint);
Var
 xyPos                    : TPoint;
 WordStart, WordLength    : Integer;
 WordLineStartPos         : Integer;
 Word                     : string;
 WordCMP                  : string;
 i, RIdx                  : Integer;

 AddIT                    : Boolean;


Begin
 AddIt := FALSE;

 With RichEdit do
 Begin
  xyPos := _xyPos;
  GetWordInfo(Lines.Strings[xyPos.Y], xyPos.x, WordStart, WordLength);
  Word := Copy(Lines.Strings[xyPos.Y], WordStart+1, WordLength);
  IF Length(word) <> 0 then
  Begin
   IF Word[1] = ' ' then Delete(Word, 1, 1);
   IF Length(word) <> 0 then
    If Word[Length(Word)] = ' ' then Delete(Word, Length(Word), 1);
  End;

  WordLineStartPos := GetWordLineStartPos(RichEdit, xyPos.y);
  WordStart := WordLineStartPos + WordStart;


  ADDIt := FALSE;
  For i := 0 to Words.Count -1 do
  Begin
   WordCMP := LowerCase(Words.Strings[i]);
   Word    := LowerCase(Word);
   //not case sensitive
   IF CompareSTR(Word, WordCMP) = 0 then
   Begin

    SetFocus;
    SelStart            := WordStart;
    SelLength           := Length(Word);
    SelAttributes.Style := [fsBold];
    SelAttributes.color := clred;

    ADDIt := TRUE
   End else
   IF not ADDit then
   Begin

     //Set normal Color, Style
     SetFocus;
     SelStart := WordStart;
     SelLength := Length(Word);
     SelAttributes.Style := [];
     SelAttributes.color := clblack;
    End;
   End;
 End;
End;


procedure TForm1.FormCreate(Sender: TObject);
begin
 WordList := TStringList.Create;
 With WordList do
 Begin
  Add('procedure');
  Add('function');
  Add('with');
  Add('do');
  Add('for');
  Add('while');
  Add('begin');
  Add('end');
  Add('repeat');
  Add('until');
  Add('to');
 End;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 WordList.Free;
end;

procedure TForm1.RichEdit1Change(Sender: TObject);
Var
 P, OldP : TPoint;

begin
 With RichEdit1 do
 Begin
  P    := CaretPos;
  OldP := P;

  ScanRichEdit(RichEdit1, WordList, P);

  IF EnterPressed then
  Begin
   EnterPressed := FALSE;
   P.y := P.y -1;
   P.x := Length(Lines.Strings[P.y]);
   ScanRichEdit(RichEdit1, WordList, P);
  End else
  IF SpacePressed then
  Begin
   SpacePressed := FALSE;
   Dec(P.x);
   ScanRichEdit(RichEdit1, WordList, P);
  End;

  //Set Old Position, normal Color, Style
  SelStart            := GetWordLineStartPos(RichEdit1, OldP.Y) + OldP.X;
  SelLength           := 0;
  SelAttributes.Style := [];
  SelAttributes.color := clblack;
 End;
end;

procedure TForm1.RichEdit1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 IF Key = vk_Return then EnterPressed := TRUE;
 IF Key = vk_Space  then SpacePressed := TRUE;
end;

0
 
LVL 2

Expert Comment

by:bugroger
ID: 6181000
This will be my last comment.
I reduce the flicker.
But there is still another way.
-> look at delphi !



USes RichEdit;

Const
 EnterPressed : Boolean = FALSE;
 SpacePressed : Boolean = FALSE;


Var
 WordList                 : TStrings;

Procedure GetWordInfo(S : String; Pos : integer; VAR WordStart, WordLength : Integer);
Var
 i, l : Integer;
Begin
 l := Length(s);

 //Get word start
 If l = 0 then
 Begin
  WordStart    := 0;
  WordLength   := 0;
  Exit;
 End;

 IF pos = 1 then pos := 0;
 i := pos;
 //              vvvvvvvvvvvvvvvvv can be highlighted
 While (S[i] in ['a'..'z','A'..'Z']) and ((i) <> 0) do dec(i);
 WordStart := i;

 If i = l then
 Begin
  WordLength := 0;
  Exit;
 End;
 Inc(i);

 //Get word length
 //              vvvvvvvvvvvvvvvvv can be highlighted
 While (S[i] in ['a'..'z','A'..'Z']) and (i <> l) do Inc(i);
 WordLength := i - WordStart;
End;


Function GetWordLineStartPos(VAR RichEdit : TRichEdit; Y : integer) : integer;
Var
 i : Integer;

Begin
 Result := 0;
 For i := 0 to Y -1 do
  Result := Result + Length(RichEdit.Lines.Strings[i]) +2;
End;


Procedure ScanRichEdit(VAR RichEdit : TRichEdit; Words : TStrings; _xyPos : TPoint);
Var
 xyPos                    : TPoint;
 WordStart, WordLength    : Integer;
 WordLineStartPos         : Integer;
 Word                     : string;
 WordCMP                  : string;
 i, RIdx                  : Integer;

 AddIT                    : Boolean;


Begin
 AddIt := FALSE;

 With RichEdit do
 Begin
  xyPos := _xyPos;
  GetWordInfo(Lines.Strings[xyPos.Y], xyPos.x, WordStart, WordLength);
  Word := Copy(Lines.Strings[xyPos.Y], WordStart+1, WordLength);
  IF Length(word) <> 0 then
  Begin
   IF Word[1] = ' ' then Delete(Word, 1, 1);
   IF Length(word) <> 0 then
    If Word[Length(Word)] = ' ' then Delete(Word, Length(Word), 1);
  End;

  WordLineStartPos := GetWordLineStartPos(RichEdit, xyPos.y);
  WordStart := WordLineStartPos + WordStart;


  ADDIt := FALSE;
  For i := 0 to Words.Count -1 do
  Begin
   WordCMP := LowerCase(Words.Strings[i]);
   Word    := LowerCase(Word);
   //not case sensitive
   IF CompareSTR(Word, WordCMP) = 0 then
   Begin

    SelStart            := WordStart;
    SelLength           := Length(Word);
    SelAttributes.Style := [fsBold];
    SelAttributes.color := clred;

    ADDIt := TRUE
   End else
   IF not ADDit then
   Begin

     //Set normal Color, Style

     SelStart := WordStart;
     SelLength := Length(Word);
     SelAttributes.Style := [];
     SelAttributes.color := clblack;
    End;
   End;
 End;
End;


procedure TForm1.FormCreate(Sender: TObject);
begin
 WordList := TStringList.Create;
 With WordList do
 Begin
  Add('procedure');
  Add('function');
  Add('with');
  Add('do');
  Add('for');
  Add('while');
  Add('begin');
  Add('end');
  Add('repeat');
  Add('until');
  Add('to');
 End;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 WordList.Free;
end;

procedure TForm1.RichEdit1Change(Sender: TObject);
Var
 P, OldP : TPoint;
 OldSel, OldSelLen : Integer;

begin
 lockwindowupdate(richedit1.handle);                   //do not update
// richedit1.Perform(EM_HIDESELECTION,Integer(true),0);  //show no selection

 With RichEdit1 do
 Begin
  SetFocus;
  P         := CaretPos;
  OldP      := P;
  OldSel    := SelStart;
  OldSelLen := SelLength;


  ScanRichEdit(RichEdit1, WordList, P);

  IF EnterPressed then
  Begin
   EnterPressed := FALSE;
   P.y := P.y -1;
   P.x := Length(Lines.Strings[P.y]);
   ScanRichEdit(RichEdit1, WordList, P);
  End else
  IF SpacePressed then
  Begin
   SpacePressed := FALSE;
   Dec(P.x);
   ScanRichEdit(RichEdit1, WordList, P);
  End;

  //Set Old Position, normal Color, Style

  SelStart  := OldSel;
  SelLength := OldSelLen;

  SelAttributes.Style := [];
  SelAttributes.color := clblack;
 End;
// richedit1.Perform(EM_HIDESELECTION,Integer(False),0);
 lockwindowupdate(0);
end;

procedure TForm1.RichEdit1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 IF Key = vk_Return then EnterPressed := TRUE;
 IF Key = vk_Space  then SpacePressed := TRUE;
end;
0
 
LVL 1

Author Comment

by:bakry99
ID: 6181431
it's a good answer but i have some notes
there is a delay , it work only while typing in RichEdit... i mean if you paste atext from other memo it doesn't work (or LoadFromFile).

thanks full
bakry
0

Featured Post

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Delphi selector screen 2 84
Unique identifier on a terminal server (rdp) 4 67
how can i search if string exist in array ? 3 63
Microsoft Access 97 and Delphi XE2 9 53
Creating an auto free TStringList The TStringList is a basic and frequently used object in Delphi. On many occasions, you may want to create a temporary list, process some items in the list and be done with the list. In such cases, you have to…
Introduction Raise your hands if you were as upset with FireMonkey as I was when I discovered that there was no TListview.  I use TListView in almost all of my applications I've written, and I was not going to compromise by resorting to TStringGrid…
Two types of users will appreciate AOMEI Backupper Pro: 1 - Those with PCIe drives (and haven't found cloning software that works on them). 2 - Those who want a fast clone of their boot drive (no re-boots needed) and it can clone your drive wh…
I've attached the XLSM Excel spreadsheet I used in the video and also text files containing the macros used below. https://filedb.experts-exchange.com/incoming/2017/03_w12/1151775/Permutations.txt https://filedb.experts-exchange.com/incoming/201…

808 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