Avatar of rincewind666
rincewind666 asked on

Color words in richedit (500 points)

Whenever a certain sequence of characters appears in a richedit, I want to color it red.  The richedit contains text such as:
$db = "yes";
$prenum='no';
$prefix = 'ABC';

I am using the following code which turns every "$" in the text red.  I just want to turn all text in the same line red if it has a $, = and either a ' or " in it such as above.  Note that sometimes there  is a space before/after = and sometimes there isn't. Ignore any other times $ appears.

I am using Delphi 6.

I am giving 500 points as this is urgent.  Many thanks for your help.

CODE:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure colorword(ARichedit : TRichedit; AWord : String; AColor : TColor; whole:Boolean; aChar:String);          //  baby123
var
  foundAt,
  oldSelStart,
  oldSelLength,
  first,last : Integer;
begin

  oldSelStart := ARichedit.SelStart;
  oldSelLength := ARichedit.SelLength;
  try
    foundAt := -1;
    repeat
      if whole then begin
        foundAt := ARichEdit.FindText(AWord,foundAt+1,length(ARichEdit.Text),[stWholeWord]);
        if foundAt < 0 then break;
        ARichedit.SelStart := foundAt;
        ARichEdit.SelLength := length(AWord);
        ARichEdit.SelAttributes.Color := AColor;
        ARichEdit.SelAttributes.Style := [fsBold];
      end
      else begin
        foundAt := ARichEdit.FindText(AWord,foundAt+1,length(ARichEdit.Text),[]);
        if foundAt < 0 then break;
        first:=foundAt;
        while (ARichEdit.Text[first] in ['a'..'z']) or (ARichEdit.Text[first] in ['A'..'Z']) do begin
           Dec(first);
        end;
        ARichedit.SelStart := first;
        last:=foundAt+length(AWord)+1;
        while (ARichEdit.Text[last] in ['a'..'z']) or (ARichEdit.Text[last] in ['A'..'Z']) or
              (ARichEdit.Text[last]=aChar) do begin
           Inc(last);
        end;
        ARichedit.SelLength := last-first;
        ARichEdit.SelAttributes.Color := AColor;
        ARichEdit.SelAttributes.Style := [fsBold];
      end;
    until foundAt = -1;
  finally
    ARichedit.SelStart := oldSelStart;
    ARichedit.SelLength := oldSelLength;
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
colorword(RichEdit1,'$', clRed, false, '');
end;

end.

FORM:

object Form1: TForm1
  Left = 237
  Top = 316
  Width = 652
  Height = 215
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -13
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnShow = FormShow
  PixelsPerInch = 120
  TextHeight = 16
  object RichEdit1: TRichEdit
    Left = 0
    Top = 0
    Width = 644
    Height = 105
    Align = alTop
    Lines.Strings = (
      'session_start(); '

        'if ($_POST["vercode"] != $_SESSION["vercode"] OR $_SESSION["verc' +
        'ode"]=='''')  {'
      '     echo  ''<strong>Incorrect verification code.</strong><br>'';'
      '} else {'
      '$email = $_POST[''email''] ;'
      '$name = $_POST[''sendername''] ;'
      '$subject = $_POST[''subject''] ;'
      '$message = $_POST[''mesbody''] ;'
      '$db = "yes";'
      '$prenum=''no'';'
      '$prefix = ''ABC'';'
      '$count_my_page = ("hitcounter.txt");'
      '$hits = file($count_my_page);'
      '$hits[0] ++;'
      '$fp = fopen($count_my_page , "w");'
      'fputs($fp , "$hits[0]");'
      'fclose($fp);'
      '//sets number for subject'
      '$subnum = $hits[0];')
    ScrollBars = ssVertical
    TabOrder = 0
  end
end
Editors IDEsDelphi

Avatar of undefined
Last Comment
rincewind666

8/22/2022 - Mon
ASKER
rincewind666

Almost forgot, if possible, the richedit should scroll to this text when opened.  Don't worry if this extra feature is too difficult.  I will accept just the colored text.  Thanks.
wd123

Better use TSynEdit  - http://synedit.sourceforge.net
ASKER
rincewind666

Is TSynEdit compatable with Vista?
I started with Experts Exchange in 2004 and it's been a mainstay of my professional computing life since. It helped me launch a career as a programmer / Oracle data analyst
William Peck
TheRealLoki

ahhh. that code looks familiar ;-)
so let me get this straight. You wish to highlight the entire line in red when you find
$, = and '
o $, = and "

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, (*Variants, *)Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, RichEdit;
 
type TColorWhat = (cw_Text, cw_Word, cw_Line);
 
type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    Button1: TButton;
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
procedure DetermineCurrentWord(ARichEdit: TRichEdit);
procedure DetermineCurrentLinePos(ARichEdit: TRichEdit);
procedure FindAndColorRichEdit(ARichEdit: TRichEdit; AText: string;
  AColor: TColor; FindWholeWord_: boolean; MatchCase_: boolean; ColorWhat: TColorWhat);
procedure FindAndColorLinesIfContainsAllThese(ARichEdit: TRichEdit; ATextCommaList: string;
  AColor: TColor; MatchCase_: boolean);
 
implementation
 
{$R *.dfm}
 
 
procedure colorword(ARichedit : TRichedit; AWord : String; AColor : TColor; whole:Boolean; aChar:String);          //  baby123
var
  foundAt,
  oldSelStart,
  oldSelLength,
  first,last : Integer;
begin
 
  oldSelStart := ARichedit.SelStart;
  oldSelLength := ARichedit.SelLength;
  try
    foundAt := -1;
    repeat
      if whole then begin
        foundAt := ARichEdit.FindText(AWord,foundAt+1,length(ARichEdit.Text),[stWholeWord]);
        if foundAt < 0 then break;
        ARichedit.SelStart := foundAt;
        ARichEdit.SelLength := length(AWord);
        ARichEdit.SelAttributes.Color := AColor;
        ARichEdit.SelAttributes.Style := [fsBold];
      end
      else begin
        foundAt := ARichEdit.FindText(AWord,foundAt+1,length(ARichEdit.Text),[]);
        if foundAt < 0 then break;
        first:=foundAt;
        while (ARichEdit.Text[first] in ['a'..'z']) or (ARichEdit.Text[first] in ['A'..'Z']) do begin
           Dec(first);
        end;
        ARichedit.SelStart := first;
        last:=foundAt+length(AWord)+1;
        while (ARichEdit.Text[last] in ['a'..'z']) or (ARichEdit.Text[last] in ['A'..'Z']) or
              (ARichEdit.Text[last]=aChar) do begin
           Inc(last);
        end;
        ARichedit.SelLength := last-first;
        ARichEdit.SelAttributes.Color := AColor;
        ARichEdit.SelAttributes.Style := [fsBold];
      end;
    until foundAt = -1;
  finally
    ARichedit.SelStart := oldSelStart;
    ARichedit.SelLength := oldSelLength;
  end;
end;
 
procedure DetermineCurrentWord(ARichEdit: TRichEdit);
var
  startpos, endpos: integer;
begin
  endpos := ARichEdit.SelStart;
  startpos := SendMessage( ARichEdit.Handle, EM_FINDWORDBREAK, WB_MOVEWORDLEFT, endpos + 1);
  endpos := SendMessage( ARichEdit.Handle, EM_FINDWORDBREAK, WB_MOVEWORDRIGHT, endpos);
// does not work with @
 
  ARichEdit.SelStart := startpos;
  ARichEdit.SelLength := (endpos - startpos);
end;
 
procedure DetermineCurrentLinePos(ARichEdit: TRichEdit);
var
  startpos, endpos, templine, currentline, len, i: integer;
begin
  startpos := ARichEdit.SelStart;
  endpos := startpos + 1;
  len := length(ARichEdit.Lines.Text);
  currentline := SendMessage( ARichEdit.Handle, EM_EXLINEFROMCHAR, 0, startpos);
  templine := currentline;
// find start of line
  while ( (startpos > 0) and (templine = currentline) ) do
  begin
    i := SendMessage( ARichEdit.Handle, EM_FINDWORDBREAK, WB_MOVEWORDLEFT, startpos);
    templine := SendMessage( ARichEdit.Handle, EM_EXLINEFROMCHAR, 0, i);
    if (templine = currentline) then
      startpos := i-1;
  end;
  if startpos < 0 then startpos := 0;
// find end of line
  templine := currentline;
 
  while ( (endpos < pred(len)) and (templine = currentline) ) do
  begin
    i := SendMessage( ARichEdit.Handle, EM_FINDWORDBREAK, WB_MOVEWORDRIGHT, endpos);
    templine := SendMessage( ARichEdit.Handle, EM_EXLINEFROMCHAR, 0, i);
    if (templine = currentline) then
      endpos := i + 1;
  end;
  if endpos >= len then endpos := len-1;
 
  ARichEdit.SelStart := startpos;
  ARichEdit.SelLength := (endpos - startpos);
end;
 
procedure FindAndColorRichEdit(ARichEdit: TRichEdit; AText: string;
  AColor: TColor; FindWholeWord_: boolean; MatchCase_: boolean; ColorWhat: TColorWhat);
var
  FoundAt: LongInt;
  StartPos, ToEnd: Integer;
  Searchtype: TSearchTypes;
  refind: TFindDialog;
begin
  refind := TFindDialog.Create(nil);
  try
    SearchType := [];
    if FindWholeWord_ then SearchType := SearchType + [stWholeWord];
    if MatchCase_ then SearchType := SearchType + [stMatchCase];
 
    refind.FindText := AText;
    with ARichEdit do
    begin
      StartPos := 0;
      { ToEnd is the length from StartPos to the end of the text in the rich edit control }
      ToEnd := Length(Text) - StartPos;
      FoundAt := FindText(refind.FindText, StartPos, ToEnd, SearchType);
      while FoundAt <> -1 do
      begin
        SetFocus;
        SelStart := FoundAt;
        SelLength := Length(refind.FindText);
 
        if ColorWhat = cw_Line then
        begin
          DetermineCurrentLinePos(ARichEdit);
          SelAttributes.Color := clRed;
          StartPos := ARichEdit.SelStart + ARichEdit.SelLength;
        end
        else if ColorWhat = cw_Word then
        begin
          DetermineCurrentWord(ARichEdit);
          SelAttributes.Color := clRed;
          StartPos := ARichEdit.SelStart + ARichEdit.SelLength;
        end
        else
        begin
          SelAttributes.Color := clRed;
          StartPos := SelStart + SelLength; // ready to search for the next
        end;
 
        ToEnd := Length(Text) - StartPos;
        FoundAt := FindText(refind.FindText, StartPos, ToEnd, SearchType);
      end;
      SelStart := 0; // unselect
      Sellength := 0;
    end;
  finally
    refind.Free;
  end;
end;
 
procedure FindAndColorLinesIfContainsAllThese(ARichEdit: TRichEdit; ATextCommaList: string;
  AColor: TColor; MatchCase_: boolean);
var
  FoundAt: LongInt;
  StartPos, ToEnd: Integer;
  Searchtype: TSearchTypes;
  refind: TFindDialog;
  sl: TStringList;
  AText, s: string;
  i: integer;
  matchedcount: integer;
begin
  sl := TStringList.Create;
  refind := TFindDialog.Create(nil);
  try
    sl.commatext := ATextCommaList;
    AText := sl[0];
    SearchType := [];
// not using yet - TODO    if FindWholeWord_ then SearchType := SearchType + [stWholeWord];
    if MatchCase_ then SearchType := SearchType + [stMatchCase];
 
    refind.FindText := AText;
    with ARichEdit do
    begin
      StartPos := 0;
      { ToEnd is the length from StartPos to the end of the text in the rich edit control }
      ToEnd := Length(Text) - StartPos;
      FoundAt := FindText(refind.FindText, StartPos, ToEnd, SearchType);
      while FoundAt <> -1 do
      begin
        SetFocus;
        SelStart := FoundAt;
        SelLength := Length(refind.FindText);
        DetermineCurrentLinePos(ARichEdit);
        s := ARichEdit.SelText;
        matchedcount := 0;
        for i := 0 to pred(sl.count) do
        begin
          if MatchCase_ and (pos(sl[i], s) > 0) then
            inc(matchedcount)
          else if (not MatchCase_) and (pos(uppercase(sl[i]), uppercase(s)) > 0) then
            inc(matchedcount);
        end;
        if matchedcount = sl.count then
        begin
          SelStart := FoundAt;
          DetermineCurrentLinePos(ARichEdit);
          StartPos := ARichEdit.SelStart + ARichEdit.SelLength;
          SelAttributes.Color := clRed;
        end
        else
          StartPos := FoundAt + Length(refind.FindText);
 
 
        ToEnd := Length(Text) - StartPos;
        FoundAt := FindText(refind.FindText, StartPos, ToEnd, SearchType);
      end;
      SelStart := 0; // unselect
      Sellength := 0;
    end;
  finally
    refind.Free;
    sl.clear;
    sl.free;
  end;
end;
 
procedure TForm1.FormShow(Sender: TObject);
begin
//  colorword(RichEdit1,'$', clRed, false, '');
//  FindAndColorRichEdit(RichEdit1, '$', clRed, false, false, cw_Line);
//$, = and '
    FindAndColorLinesIfContainsAllThese(RichEdit1, '$,=,''', clRed, false);
//$, = and "
    FindAndColorLinesIfContainsAllThese(RichEdit1, '$,=,""""', clRed, false);
end;
 
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  FindAndColorRichEdit(RichEdit1, '$', clRed, false, false, cw_Line);
end;
 
end.

Open in new window

TheRealLoki

og, and to scroll to it is just
    ARichEdit.Perform(em_ScrollCaret, 0, 0);
ASKER CERTIFIED SOLUTION
Russell Libby

Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
See how we're fighting big data
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
ask a question
wd123

>Is TSynEdit compatable with Vista?
Yes
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.
ASKER
rincewind666

Sorry.  This isn't what I need.  I just want the line in red for this pattern ($word =) such as

$db = "yes";
$prenum='no';
$prefix = 'ABC';

Thanks for your help.
ASKER
rincewind666

rllibby, I am getting the following error:
[Error] Unit1.pas(28): Undeclared identifier: 'TRegExpr'
Russell Libby

Did you download the RegExprEx.pas unit, and add it to your uses clause?

uses
  Windows, SysUtils, ... etc ..., RegExprEx;

Experts Exchange has (a) saved my job multiple times, (b) saved me hours, days, and even weeks of work, and often (c) makes me look like a superhero! This place is MAGIC!
Walt Forbes
ASKER
rincewind666

rllibby

Opps1  I forgot to add it to my users clause.

Anyway, I am very pleased with this. Is there a help file available for the pattern?  I also want this if the line doesn't contain quotes:

$year = 2008;
$db = "yes";
$prenum='no';
$prefix = 'ABC';

Note that, in any event, all lines end with ;

If you can help me with this last little bit, I will appreciate it.  Thanks.
Russell Libby

1. Sorry, no help file per se. The syntax is loosely described in the header of the unit (comment section that details the syntax). Thats kind of why I asked what your comfort level was.  Some good tutorials can be found here:

http://www.regular-expressions.info/tutorial.html

2. Regarding matching it if it DOES not contain quotes, if you remove that restriction then almost all the lines would end up matching. Correct me if I'm wrong, but it looks like what you are trying to do is match lines with constant value assignments? If so, then we just update the pattern to match digits as well (" strings or ' strings or numeric values)

  regMatch:=TRegExpr.CreatePattern('@0\$[^=\r\n]+=\s*(''[^'']*''|"[^"]*"|\d+)[^\r\n]*@1');

A breakdown of what the pattern is doing:

  //    @0          =  Mark position and save as BeadPos[0]
  //    \$          =  Match literal '$'
  //    [^=\r\n]+   =  Iterate while not =, CR, LF, must match at least one char
  //    =           =  Match literal =
  //    \s*         =  Iterate past any white space zero or more times
  //    (           =  Start sub expression
  //    ''[^'']*''
  //       '        =  Match literal '
  //       [^']*    =  Iterate while not ', match zero or more times
  //       '        =  Match literal '
  //    |           =  or
  //    "[^"]*"
  //       "        =  Match literal "
  //       [^"]*    =  Iterate while not ", match zero or more times
  //       "        =  Match literal "
  //    |           =  or
  //    \d+         =  Match 1 or more digit chars
  //    )           =  End sub expression
  //    [^\r\n]*    =  Iterate while not CR or LF, match zero or more times
  //    @1          =  Mark position and save as BeadPos[1]
  //

The nice thing about regular expressions is that you don't have to recode any parsing logic when your requirements change; you only neeed to update the pattern value.

Hope this helps
Russell
ASKER
rincewind666

rllibby

Excellent!  I am awarding you the well deserved points, together with my grateful thanks.
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.