// Es wurde eine Routine gesucht, mit welcher man in einem TRichedit Textstellen
// finden, zählen und/oder markieren kann. Es kann auch der Hintergrund einer
// gefundenen Zeichenkette eingefärbt werden.


// Getestet mit RS 10.4 unter Win11

uses Winapi.RichEdit; 
 
type 
  MySt = (mfsBold, mfsItalic, mfsUnderline, mfsStrikeOut, mfsNo); 
  MStyle = set of MySt; 
  // Erweiterung von TFontStyles: 
  // Bei mfsNo wird keine Veränderung an Font.Style vorgenommen 
 
Procedure Marking(RE: TRichEdit; Back: TColor; Art: Integer); 
var 
  fmt: TCharFormat2; 
begin 
  Zeromemory(@fmt, SizeOf(fmt)); 
  fmt.cbSize := SizeOf(fmt); 
  fmt.dwMask := CFM_BACKCOLOR; 
  fmt.crBackColor := Back; 
  RE.Perform(EM_SETCHARFORMAT, Art, LongInt(@fmt)); 
end; 
 
Function HighLight(RE: TRichEdit; Txt, FName: String; Farbe, BackColor: PColor; 
  FSize, Start, Ende: Integer; FStyle: MStyle; STyp: TSearchTypes; 
  Nur1x, NurSuch: Boolean; out Fund: Integer): Integer; 
var 
  X, Lg: Integer; 
  C: TColor; 
begin 
  RE.Lines.BeginUpdate; 
  Result := Start; 
  RE.SelStart := Result; 
  Lg := Length(Txt); 
  Fund := 0; 
  Repeat 
    X := RE.FindText(Txt, Start, Ende, STyp); 
    if X < 0 Then 
      Break; 
    Inc(Fund); 
    RE.SelStart := X; 
    RE.SelLength := Lg; 
    Start := X + Lg; 
    if not NurSuch then 
    begin 
      if BackColor <> nil then 
      begin 
        C := BackColor^; 
        Marking(RE, ColorToRGB(C), SCF_SELECTION); 
      end; 
      With RE.SelAttributes Do 
      begin 
        if Farbe <> nil then 
          Color := Farbe^; 
        if FSize > 0 then 
          Size := FSize; 
        if FStyle <> [mfsNo] then 
          Style := TFontStyles(FStyle); 
        if FName <> '' then 
          Name := FName; 
      end 
    end; 
  until Nur1x; 
  Result := X; 
  RE.Lines.EndUpdate; 
end; 
 
 
 
 
// ********** Beispiele ********** 
 
// Wörter hervorheben 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  SuchText, FontName, S: String; 
  Hintergrund, Farbe: PColor; 
  Hlpf, Hlph: TColor; 
  FontStyle: MStyle; 
  FontSize, StartPosition, Hervorgehoben, SuchLaenge: Integer; 
  EinzelneFundstelle, NurZaehlen: Boolean; 
  SuchTyp: TSearchTypes; 
begin 
  // ------ z.B.: --------------- 
  NurZaehlen := False; // Bei TRUE würde keine Markierung erfolgen. 
  SuchText := 'End of'; 
  FontName := 'Courier New'; 
  Hlpf := clRed; 
  Farbe := @Hlpf; 
  // bei "Farbe = nil" wird die Buchstabenfarbe nicht geändert, 
  // somit kann man nur die Hintergrundfarbe beeinflussen. 
  Hlph := clyellow; 
  Hintergrund := @Hlph; 
  // bei "Hintergrund = nil" wird die Hinmtergrundfarbe nicht geändert, 
  FontSize := 0; // Keine Änderung der Buchstabengröße 
  StartPosition := 0; // von Vorn beginnend 
  SuchLaenge := RichEdit1.GetTextLen; 
  EinzelneFundstelle := False; // alle Stellen 
  FontStyle := [mfsNo]; 
  SuchTyp := [stWholeWord]; 
  // [stMatchCase] = Groß- u. Kleinschreibung beachten 
  // [stWholeWord] = nur ganze Begriffe 
  // [stWholeWord,stMatchCase] = beides beachten 
  // [] = alles was gefunden wird, egal wie geschrieben 
  // ----------------------------- 
  if NurZaehlen then 
  begin 
    S := 'gefunden'; 
    EinzelneFundstelle := False; 
  end 
  else 
    S := 'markiert'; 
  HighLight(RichEdit1, SuchText, FontName, Farbe, Hintergrund, FontSize, 
    StartPosition, SuchLaenge, FontStyle, SuchTyp, EinzelneFundstelle, 
    NurZaehlen, Hervorgehoben); 
  RichEdit1.SetFocus; 
  RichEdit1.SelLength := 0; 
  ShowMessage(IntToStr(Hervorgehoben) + #32 + S); 
end; 
 
// Hintergrund-Markierungen löschen 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  Marking(RichEdit1, ColorToRGB(RichEdit1.Color), SCF_All); 
end; 
 
 
// **************************************** 
 
 
// verschiedene Zeilen hervorheben 
// (ACHTUNG! Bei WordWrap-Wechsel wird wahrscheinlich anderer Text markiert) 
Type 
  ZL = Array [0 .. 2] of Integer; 
 
var 
  Zeilen: ZL = (12, 13, 24); 
  // aufsteigend (evtl. sortieren), sonst bleiben gleiche Zeilen unbeachtet. 
  // (Zeilen-Zählung beginnt bei 1) 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  Nix, I, X, L, FontGroesse: Integer; 
  CF: TColor; 
  S: String; 
begin 
  FontGroesse := 14; // z.B. 
  CF := clBlue; 
  X := 0; 
  for I := 0 to 2 do 
  begin 
    S := TrimRight(RichEdit1.Lines[pred(Zeilen[I])]); 
    L := Length(S); 
    X := HighLight(RichEdit1, S, 'Arial', @CF, nil, FontGroesse, X, 
      RichEdit1.GetTextLen, [mfsBold], [], True, False, Nix); 
    Inc(X, L); 
  end; 
  RichEdit1.SetFocus; 
  RichEdit1.SelLength := 0; 
end; 
 
 
// **************************************** 
 
 
// Suchen und bei Fundstellen anhalten 
var 
  NurSuchen: Boolean = True; 
  Abbruch, Weiter: Boolean; 
  Lauf: Boolean = False; 
 
  // Wort für Wort suchen 
procedure TForm1.Button4Click(Sender: TObject); 
var 
  SuchText, S: String; 
  Lang, Zahl, X, Lg, Nix: Integer; 
begin 
  if Lauf then 
  begin 
    Weiter := True; 
    exit; 
  end; 
  Lang := RichEdit1.GetTextLen; 
  SuchText := 'This'; 
  Lg := Length(SuchText); 
  Zahl := 0; 
  X := 0; 
  Abbruch := False; 
  Label1.Caption := ''; 
  repeat 
    Lauf := True; 
    Weiter := False; 
    X := HighLight(RichEdit1, SuchText, '', nil, nil, 0, X, Lang, [], 
      [stMatchCase], True, NurSuchen, Nix); 
    if X = -1 then 
    begin 
      Beep; 
      S := 'Bis zum Ende durchsucht.'#13#10; 
      Lauf := False; 
      Break; 
    end; 
    Inc(Zahl); 
    Inc(X, Lg); 
    Label1.Caption := IntToStr(Zahl) + ' gefunden.'; 
    RichEdit1.SetFocus; 
    repeat 
      Application.ProcessMessages; 
    until Abbruch or Weiter or Application.Terminated; 
    if Abbruch then 
    begin 
      Beep; 
      Lauf := False; 
      S := 'Suche abgebrochen.'#13#10'Bisher '; 
      Break; 
    end; 
  until Application.Terminated; 
  if Application.Terminated then 
    exit; 
  if Zahl = 0 then 
    Label1.Caption := 'Nichts gefunden.' 
  else 
    Label1.Caption := S + Label1.Caption; 
end; 
 
// Bearbeitung abbrechen 
procedure TForm1.Button5Click(Sender: TObject); 
begin 
  if not Lauf then 
    ShowMessage('Suchlauf ist nicht aktiv') 
  else 
    Abbruch := True; 
end;

Zugriffe seit 6.9.2001 auf Delphi-Ecke