Change a word Color in RichEdit

hi all
i want a simple procedure to change a word or wards color in RichEdit.
simple procedure or other:)
bakry
LVL 1
bakry99Asked:
Who is Participating?
 
bugrogerConnect With a Mentor Commented:
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
 
Mohammed NasmanSoftware DeveloperCommented:
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
 
bakry99Author Commented:
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
Upgrade your Question Security!

Your question, your audience. Choose who sees your identity—and your question—with question security.

 
alanwhincupCommented:
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
 
bugrogerCommented:
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
 
alanwhincupCommented:
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
 
lopemCommented:
listening
0
 
bakry99Author Commented:
ok guys
  a minute to Test your code

bakry
0
 
bakry99Author Commented:
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
 
bakry99Author Commented:
heeeeeeeeeeeeeey
where r u?
0
 
bugrogerCommented:
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
 
bakry99Author Commented:
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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.