AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren
Zurück Delphi-PRAXiS Programmierung allgemein Programmieren allgemein Texte in RichEdit finden und markieren
Thema durchsuchen
Ansicht
Themen-Optionen

Texte in RichEdit finden und markieren

Ein Thema von Amateurprofi · begonnen am 25. Dez 2015 · letzter Beitrag vom 25. Dez 2015
Antwort Antwort
Amateurprofi

Registriert seit: 17. Nov 2005
Ort: Hamburg
1.062 Beiträge
 
Delphi XE2 Professional
 
#1

Texte in RichEdit finden und markieren

  Alt 25. Dez 2015, 07:30
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;
Gruß, Klaus
Die Titanic wurde von Profis gebaut,
die Arche Noah von einem Amateur.
... Und dieser Beitrag vom Amateurprofi....
  Mit Zitat antworten Zitat
hathor
(Gast)

n/a Beiträge
 
#2

AW: Texte in RichEdit finden und markieren

  Alt 25. Dez 2015, 14:36
Funktioniert gut! DANKE!

Caption:= INTTOSTR(MarkTexts(RichEdit1,Edit1.Text,tkWords,TRUE,0,[msBold,msColor],clRed));
  Mit Zitat antworten Zitat
Antwort Antwort


Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 22:49 Uhr.
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024 by Thomas Breitkreuz