?
Solved

Change a word Color in RichEdit

Posted on 2001-06-10
12
Medium Priority
?
1,090 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
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 400 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

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

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…
In my programming career I have only very rarely run into situations where operator overloading would be of any use in my work.  Normally those situations involved math with either overly large numbers (hundreds of thousands of digits or accuracy re…
Do you want to know how to make a graph with Microsoft Access? First, create a query with the data for the chart. Then make a blank form and add a chart control. This video also shows how to change what data is displayed on the graph as well as form…
In this video, Percona Solution Engineer Dimitri Vanoverbeke discusses why you want to use at least three nodes in a database cluster. To discuss how Percona Consulting can help with your design and architecture needs for your database and infras…
Suggested Courses

765 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