How to color a word from all my text?

alexandreq · Post by **alexandreq** » Mon Feb 20, 2012 3:24 pm

Hello

How could I do this?

I have a long text and 1 word, for example: "House" , I want to find this word "HOUSE" in all my text and change the color of its font.

Is there any function that I can do this? How is the better way to do this?

Thanks
Alex

j&b · Post by **j&b** » Tue Feb 21, 2012 4:30 pm

I use this code. It runs fine, but I don' t know if it's too complicated.
If there ist something strange know it's a part of a program. Perhaps it helps you.

write in red 'Huhn' (if found in memo)

Code: Select all

procedure TForm1.sbTesten1Click(Sender: TObject);
var StyleNo,suColor, ItemNo1,Offs1,ItemNo2,Offs2: Integer;
begin
  //if query1.state in [dsEdit, dsInsert] then query1.Post;
  s:= 'Huhn'; suColor:= clRed;
  fid.FindText := s;

  Memo.SetFocus; einSuWo:='';
  //if einSuWo='ja' then fidFind(fid)
  //else begin
    RVSetLinearCaretPos(memo,0);
    while memo.SearchText(fid.FindText, [rvseoDown]) do begin
      fidFind(fid);
      mt_pause(1);  //for looking what happens
      StyleNo := memo.TopLevelEditor.CurItemStyle;
      if (StyleNo>=0) then begin
        if (rvs.TextStyles[StyleNo].color<>clBlack) then cd.color:=clBlack else cd.color:= suColor;   //cd --> TColorDialog
        version_jb:=true;
        Memo.ApplyStyleConversion(rv_COLOR);  
                  //rv_color ist set under
                  //implementation
                  //$R *.DFM}
                  //const
                  //...
                  //rv_COLOR= 11;
        version_jb:=false;
      end;
    end;
  //end;

  memo.GetSelectionBounds(ItemNo1, Offs1, ItemNo2, Offs2, True);
  if ItemNo1<0 then exit;
  memo.RVData.Item2DrawItem(ItemNo1, Offs1, ItemNo1, Offs1);
  memo.ScrollTo(memo.RVData.DrawItems[ItemNo1].Top);

  //if query1.state in [dsEdit, dsInsert] then query1.Post;
end;

procedure Tform1.Mt_pause(zeit:real);
var zeit1:real;
begin
   zeit:=zeit*1000; zeit1:=GetTickCount;
   repeat Application.ProcessMessages; until (GetTickCount-zeit1>zeit);
end;

//Komponente TFindDialog (name: fid) with fid.Options:= [frDown]
procedure TForm1.fidFind(Sender: TObject);
begin //uses RVMisc  - RichViewEdit
  tagFidFind:= 0;
  if not Memo.SearchText(fid.FindText,GetRVESearchOptions(fid.Options)) then begin
    flagAbbr:= false; tagFidFind:= 1;
    if fid.findText='' then begin
      ShowMessage('Es lag kein Suchwort (nichts Markiertes) im Memo  vor.'+#10);
      suchen1.setfocus;
    end else begin
      RVSetLinearCaretPos(memo,0);
      if not Memo.SearchText(fid.FindText,GetRVESearchOptions(fid.Options)) then begin
        flagAbbr:= true; tagFidFind:= 1;
        ShowMessage(''''+fid.FindText+'''  liegt NICHT vor.'+#10#10);
      end else tagFidFind:= 2;            //Memoende wurde erreicht
    end;
  end;
end;

procedure TForm1.memoStyleConversion(Sender: TCustomRichViewEdit; StyleNo, UserData: Integer; AppliedToText: Boolean; var NewStyleNo: Integer);
  //.......................................
  function GetFontStyle(UserData: Integer): TFontStyle;
  begin
    Result := fsBold; // <-- avoiding warnings
    case UserData of
      rv_MAKEBOLD, rv_CLEARBOLD: Result := fsBold;
      rv_MAKEITALIC, rv_CLEARITALIC: Result := fsItalic;
      rv_MAKEUNDERLINE, rv_CLEARUNDERLINE: Result := fsUnderline;
      rv_STRIKEOUT, rv_CLEARSTRIKEOUT: Result := fsStrikeOut;
    end;
  end;
  //.......................................
var fs: TFontStyle;
    fi: TFontInfo; //für version_jb=true - dafür auch nur die Komponente cd
begin

if version_jb=true then begin //von mir eingefügt
  fi := TFontInfo.Create(nil);
  try
    fi.Assign(rvs.TextStyles[StyleNo]);
    case UserData of
      rv_COLOR        : fi.Color     := cd.Color;
      rv_BACKCOLOR    : fi.BackColor := cd.Color;
      rv_APPLYFONTNAME: fi.FontName  := FontName;
      rv_APPLYFONTSIZE: fi.Size      := FontSize;
      rv_SUBSCRIPT    : begin fi.VShift:= -25; fi.size:=8; end;
      rv_SUPERSCRIPT  : begin fi.VShift:= 50; fi.size:=8;  end;
      rv_NORMAL       : begin fi.VShift:= 0; fi.size:= rvs.TextStyles[0].Size; end;
                        //if fsBold in fi.style then fi.size:=10 else fi.size:=11;
    end;

    NewStyleNo := rvs.TextStyles.FindSuchStyle(StyleNo,fi,RVAllFontInfoProperties);
    if NewStyleNo=-1 then begin
      rvs.TextStyles.Add;
      NewStyleNo := rvs.TextStyles.Count-1;
      rvs.TextStyles[NewStyleNo].Assign(fi);
      rvs.TextStyles[NewStyleNo].Standard := False;
    end;
  finally
    fi.Free;  //version_jb:=false - darf HIER nicht gesetzt werden, daher nach Aufruf !!
  end;

end else begin
  case UserData of rv_MAKEBOLD, rv_MAKEITALIC, rv_MAKEUNDERLINE, rv_STRIKEOUT:
      begin
        fs := GetFontStyle(UserData);
        NewStyleNo := rvs.TextStyles.FindStyleWithFontStyle(StyleNo, [fs], [fs]);
        if NewStyleNo = -1 then begin
          rvs.TextStyles.Add;
          NewStyleNo := rvs.TextStyles.Count - 1;
          rvs.TextStyles[NewStyleNo].Assign(rvs.TextStyles[StyleNo]);
          rvs.TextStyles[NewStyleNo].Style := rvs.TextStyles[NewStyleNo].Style + [fs];
          rvs.TextStyles[NewStyleNo].Standard := False;
        end;
      end;
    rv_CLEARBOLD, rv_CLEARITALIC, rv_CLEARUNDERLINE, rv_CLEARSTRIKEOUT:
      begin
        fs := GetFontStyle(UserData);
        NewStyleNo := rvs.TextStyles.FindStyleWithFontStyle(StyleNo, [], [fs]);
        if NewStyleNo = -1 then begin
          rvs.TextStyles.Add;
          NewStyleNo := rvs.TextStyles.Count - 1;
          rvs.TextStyles[NewStyleNo].Assign(rvs.TextStyles[StyleNo]);
          rvs.TextStyles[NewStyleNo].Style := rvs.TextStyles[NewStyleNo].Style - [fs];
          rvs.TextStyles[NewStyleNo].Standard := False;
        end;
      end;
    rv_APPLYFONTNAME:
      begin
        NewStyleNo := rvs.TextStyles.FindStyleWithFontName(StyleNo, FontName);
        if NewStyleNo = -1 then begin
          rvs.TextStyles.Add;
          NewStyleNo := rvs.TextStyles.Count - 1;
          rvs.TextStyles[NewStyleNo].Assign(rvs.TextStyles[StyleNo]);
          rvs.TextStyles[NewStyleNo].FontName := FontName;
          rvs.TextStyles[NewStyleNo].Standard := False;
        end;
      end;
    rv_APPLYFONTSIZE:
      begin
        NewStyleNo := rvs.TextStyles.FindStyleWithFontSize(StyleNo, FontSize);
        if NewStyleNo = -1 then begin
          rvs.TextStyles.Add;
          NewStyleNo := rvs.TextStyles.Count - 1;
          rvs.TextStyles[NewStyleNo].Assign(rvs.TextStyles[StyleNo]);
          rvs.TextStyles[NewStyleNo].Size := FontSize;
          rvs.TextStyles[NewStyleNo].Standard := False;
        end;
      end;
    rv_APPLYFONT:
      begin
        NewStyleNo := rvs.TextStyles.FindStyleWithFont(StyleNo, fd.Font);
        if NewStyleNo = -1 then begin
          rvs.TextStyles.Add;
          NewStyleNo := rvs.TextStyles.Count - 1;
          rvs.TextStyles[NewStyleNo].Assign(rvs.TextStyles[StyleNo]);
          rvs.TextStyles[NewStyleNo].Assign(fd.Font);
          rvs.TextStyles[NewStyleNo].Standard := False;
        end;
      end;
  end;
end;
end;

Post by **Sergey Tkachenko** » Tue Feb 21, 2012 7:45 pm

Yes, the general idea is

Code: Select all

while memo.SearchText(fid.FindText, [rvseoDown]) do 
   Memo.ApplyStyleConversion(rv_COLOR);

+ implementation of rv_COLOR in memo.OnStyleConversion.

As for the rest of your code, I do not understand it. If you explain what you want to implement, I'll try to suggest a simple solution.

alexandreq · Post by **alexandreq** » Tue Feb 21, 2012 10:57 pm

Thank sergey and j&b for reply.

I have a text with 100 lines.
There are 20 word "HOUSE" in all my text, each one in separated line.
I want a way to look for all of them and colored them into red.

I want to highligh all the words HOUSE in my text so that I can identify where are there.

Did you get it? Let me know.

alexandreq · Post by **alexandreq** » Wed Feb 22, 2012 12:46 am

Sergey, I got it don't worry about!

j&b · Post by **j&b** » Wed Feb 22, 2012 11:54 am

Sergey Tkachenko wrote:Yes, the general idea is
Code: Select all
while memo.SearchText(fid.FindText, [rvseoDown]) do 
   Memo.ApplyStyleConversion(rv_COLOR);
+ implementation of rv_COLOR in memo.OnStyleConversion.

As for the rest of your code, I do not understand it. If you explain what you want to implement, I'll try to suggest a simple solution.

I wrote this code in 2005. All runs fine. For this reason I don't look for the code.
The procedure "memoStyleConversion" is only shown because I added a flag (version_jb:= true/false). It seems that this flag would be superfluous (even 2004?).

Now I changed procedure sbTesten1Click:

procedure TForm1.sbTesten1Click(Sender: TObject);
var StyleNo,suColor: Integer;
begin
suColor:= clRed; fid.FindText :=Edit1.text;
//fid.find muss vor RVSetLinearCaretPos stehen, sonst mehrere Klicks bevor Ergebnis
//Memo.SetFocus wird bei RVSetLinearCaretPos nicht benötigt
RVSetLinearCaretPos(memo,0);
while memo.SearchText(fid.FindText, [rvseoDown]) do begin
StyleNo := memo.TopLevelEditor.CurItemStyle;
//if styleNo>=0 then ... sucht nicht in Tabelle
if (rvs.TextStyles[StyleNo].color<>suColor) then cd.color:=suColor else cd.color:= clBlack; //cd --> TColorDialog
Memo.ApplyStyleConversion(rv_COLOR); //Es geht jetzt auch ohne version_jb:= true/false - aber schon immer (vor 2005 ?)
//end;
//mt_pause(1); //wartet nach Fund
end;
end;

alexandreq · Post by **alexandreq** » Wed Feb 22, 2012 12:08 pm

thanks sergey for your attention on my case.