Texte in RichEdit finden und markieren

[Amateurprofi]

Es wurde schon gelegentlich diskutiert, wie man in einem TRichEdit Texte finden und die Fundstellen kenntlich machen kann, zum Beispiel durch andere Farbe oder anderen Schriftstil.
Da ich bisher keine (mich) überzeugenden Vorschläge fand, habe ich eine Funktion geschrieben, die zu funktionieren scheint.
Vielleicht kann der/die eine oder andere etwas damit anfangen.
Kritik und/oder Änderungsvorschläge sind willkommen.

Code:

type
   TMarkStyle=(msBold,msItalic,msUnderline,msStrikeOut,msColor);
   TMarkStyles=Set of TMarkStyle;
   TTextKind=(tkText,tkTexts,tkWords,tkWordsBegin,tkWordsContain,tkWordsEnd);

FUNCTION MarkTexts(RE:TRichEdit; const S:String; ATextKind:TTextKind=tkText;
   AIgnoreCase:Boolean=True; AMarkCount:Integer=0;
   AMarkStyles:TMarkStyles=[msBold,msColor]; AColor:TColor=clRed):Integer;

Beschreibung der Parameter:
RE
   Das RichEdit
S
   Der zu suchende Text
ATextKind
   tkText
      S wird gesucht
   tkTexts
      S kann mehrere durch Kommas voneinander getrennte Texte enthalten.
      Blanks am Anfang oder Ende dieser Texte werden entfernt.
   tkWords
      S enthält ein Wort oder mehrere durch NonAlphaZeichen getrennte Worte
   tkWordsBegin,tkWordsEnd,tkWordsContain
      Wie tkWords, aber gefunden werden Worte, die mit einem der Suchtexte beginnen, enden oder ihn enthalten.
AIgnoreCase
   Wenn True, dann wird nicht zwischen Groß- und Kleinschreibung unterschieden.
AMarkCount
   Wenn < 0, dann werden nur die letzten Abs(AMarkCount) Fundstellen markiert.
   Wenn = 0, dann werden alle Fundstellen markiert.
   Wenn > 0, dann werden nur die ersten AMarkCount Fundstellen markiert.
   Falls S mehrere Texte oder Worte enthält, dann wird für jeden Text bzw. für jedes Wort separat gezählt.
AMarkStyles
   Die Fundstellen werden mit den in AMarkStyles enthaltenen Styles markiert, wobei msBold .. msStrikeOut in fsBold .. fsStrikeOut umgesetzt werden.
AColor
   Wenn msColor in AMarkStyles enthalten ist, werden die Fundstellen zusätzlich durch AColor markiert.

Funktionsergebnis:
   Die Funktion gibt die Anzahl der markierten Fundstellen zurück.

Delphi-Quellcode:

FUNCTION MarkTexts(RE:TRichEdit; const S:String; ATextKind:TTextKind=tkText;
   AIgnoreCase:Boolean=True; AMarkCount:Integer=0;
   AMarkStyles:TMarkStyles=[msBold,msColor]; AColor:TColor=clRed):Integer;
type
   TFoundRec=Record Pos,Last:Integer; end;
   TFound=Array of TFoundRec;
   TPFoundRec=^TFoundRec;
   TFSI=Array of TPFoundRec;
var
   Count,ActCount:Integer; SearchFor,SearchIn:String; Found:TFound; FSI:TFSI;
//------------------------------------------------------------------------------
FUNCTION GetTexts:Boolean;
var I,J:Integer;
begin
   if S='' then Exit(False);
   if AIgnoreCase then SearchFor:=AnsiUpperCase(S) else SearchFor:=S;
   SearchIn:=RE.Text;
   J:=0;
   for I:=1 to Length(SearchIn) do
     if SearchIn[I]<>#10 then begin
        Inc(J);
        SearchIn[J]:=SearchIn[I];
     end;
   if J<Length(SearchFor) then Exit(False);
   SetLength(SearchIn,J);
   if AIgnoreCase then SearchIn:=AnsiUpperCase(SearchIn);
   Result:=True;
end;
//------------------------------------------------------------------------------
FUNCTION Add(APos,ALen:Integer):Boolean;
var I,Len:Integer; NewRec:TFoundRec;
begin
   NewRec.Pos:=APos;
   NewRec.Last:=APos+ALen-1;
   if (AMarkCount<0) and (ActCount=Abs(AMarkCount)) then begin
      for I:=Count-ActCount to Count-2 do Found[I]:=Found[I+1];
      Found[Count-1]:=NewRec;
      Result:=True;
   end else begin
      Len:=Length(Found);
      if Len<=Count then SetLength(Found,Len+100);
      Found[Count]:=NewRec;
      Inc(Count);
      Inc(ActCount);
      Result:=(AMarkCount<=0) or (ActCount<AMarkCount);
   end;
end;
//------------------------------------------------------------------------------
PROCEDURE FindText(const S:String);
var Len,P:Integer;
begin
   if S<>'' then begin
      ActCount:=0;
      Len:=Length(S);
      P:=1;
      repeat
         P:=PosEx(S,SearchIn,P);
         if P=0 then Exit;
         if not Add(P,Len) then Exit;
         P:=P+Len;
      until False;
   end;
end;
//------------------------------------------------------------------------------
PROCEDURE FindTexts(const S:String);
var P,LastP,Len:Integer;
begin
   LastP:=1;
   repeat
      P:=PosEx(',',S,LastP);
      if P=0 then Len:=MaxInt else Len:=P-LastP;
      FindText(Trim(Copy(S,LastP,Len)));
      LastP:=P+1;
   until P=0;
end;
//------------------------------------------------------------------------------
PROCEDURE FindWord(const S:String);
var Len,P,SILen:Integer; IsWord:Boolean;
//---------------------------------------------------------
FUNCTION WordFound:Boolean;
begin
   case ATextKind of
      tkWords:
         Result:=((P=1) or not IsCharAlpha(SearchIn[P-1])) and
                 ((P+Len>SILen) or not IsCharAlpha(SearchIn[P+Len]));
      tkWordsBegin:
         Result:=(P=1) or not IsCharAlpha(SearchIn[P-1]);
      tkWordsEnd:
         Result:=(P+Len>SILen) or not IsCharAlpha(SearchIn[P+Len]);
      tkWordsContain:
         Result:=True;
   end;
end;
//---------------------------------------------------------
begin
   if S<>'' then begin
      SILen:=Length(SearchIn);
      Len:=Length(S);
      ActCount:=0;
      P:=1;
      repeat
         P:=PosEx(S,SearchIn,P);
         if P=0 then Exit;
         if WordFound then
            if not Add(P,Len) then Exit;
         P:=P+Len;
      until False;
   end;
end;
//------------------------------------------------------------------------------
PROCEDURE FindWords(const S:String);
var PAct,PFirst,PStart:PChar;
begin
   PFirst:=PChar(S);
   PAct:=PFirst;
   while PAct^<>#0 do
      if IsCharAlpha(PAct^) then begin
         PStart:=PAct;
         Inc(PAct);
         while IsCharAlpha(PAct^) do Inc(PAct);
         FindWord(Copy(S,PStart-PFirst+1,PAct-PStart));
      end else begin
         Inc(PAct);
      end;
end;
//------------------------------------------------------------------------------
PROCEDURE SortFound;
var M,H:TPFoundRec;
//---------------------------------------------------------
FUNCTION Compare(A:TPFoundRec):Integer;
begin
   Result:=A.Pos-M.Pos;
   if Result=0 then Result:=A.Last-M.Last;
end;
//---------------------------------------------------------
PROCEDURE QSort(First,Last:Integer);
var I,J:Integer;
begin
   I:=First;
   J:=Last;
   M:=FSI[(First+Last) shr 1];
   repeat
      while Compare(FSI[I])<0 do Inc(I);
      while Compare(FSI[J])>0 do Dec(J);
      if I<=J then begin
         H:=FSI[I];
         FSI[I]:=FSI[J];
         FSI[J]:=H;
         Inc(I);
         Dec(J);
      end;
   until I>J;
   if J>First then QSort(First,J);
   if I<Last then QSort(I,Last);
end;
//---------------------------------------------------------
begin
   if (Length(FSI)>1) then QSort(0,High(FSI));
end;
//------------------------------------------------------------------------------
FUNCTION Overlaps(A,B:TPFoundRec):Boolean;
begin
   Result:=(A.Pos=B.Pos) or
           (A.Pos<B.Pos) and (A.Last>=B.Pos) or
           (A.Pos>B.Pos) and (A.Pos<=B.Last);
   if Result then begin
      A.Pos:=Min(A.Pos,B.Pos);
      A.Last:=Max(A.Last,B.Last);
   end;
end;
//------------------------------------------------------------------------------
FUNCTION ConsolidateFound:Integer;
var I,J,Last:Integer;
begin
   SetLength(FSI,Count);
   for I:=0 to Count-1 do FSI[I]:=@Found[I];
   SortFound;
   Last:=High(FSI);
   I:=0;
   if Last>0 then
      while I<Last do
         if Overlaps(FSI[I],FSI[I+1]) then begin
            for J:=I+1 to Last-1 do FSI[J]:=FSI[J+1];
            Dec(Last);
         end else begin
            Inc(I);
         end;
   Result:=Last;
end;
//------------------------------------------------------------------------------
var I,J,Last:Integer; NewStyle:TFontStyles; HasColor:Boolean;
begin
   Result:=0;
   if AMarkStyles=[] then Exit;
   if not GetTexts then Exit;
   Count:=0;
   case ATextKind of
      tkText   : FindText(SearchFor);
      tkTexts  : FindTexts(SearchFor);
      else       FindWords(SearchFor);
   end;
   if Count=0 then Exit;
   HasColor:=msColor in AMarkStyles;
   NewStyle:=TFontStyles(AMarkStyles*[msBold,msItalic,msUnderline,msStrikeOut]);
   Last:=ConsolidateFound;
   for I:=0 to Last do
      with RE, FSI[I]^ do begin
         SelStart:=Pos-1;
         SelLength:=Last-Pos+1;
         SelAttributes.Style:=NewStyle;
         if HasColor then SelAttributes.Color:=AColor;
      end;
   Result:=Last+1;
end;