// Hier eine schnelle Art und Weise, eine Zeichenkette in einem Text zu finden.
// Die Methode geht auf Boyer & Moore zurück und fußt darauf, dass man einen ganzen
// Block vorrücken kann, wenn kein Zeichen des Suchbegriffes im durchsuchten Textblock
// vorhanden ist. Somit werden Textstellen nicht mehrmals in die Suche einbezogen, was
// aber passieren kann, wenn man bei der Suche immer nur Zeichen für Zeichen im Text
// vorrückt.


// Getestet mit D4 unter XP

var 
  stelle: integer = 0; 
  Tabelle: array [0 .. $FFFE] of integer; 
 
function BoyerMooreSuche(SB, Txt: String): integer; 
var 
  SBLen, SBIdx, Posi, Idx, Diff: integer; 
begin 
  result := 0; 
  if SB = '' then 
    exit; 
  fillchar(Tabelle, sizeof(Tabelle), -1); 
  SBLen := Length(SB); 
  for SBIdx := 1 to SBLen do 
    Tabelle[Ord(SB[SBIdx])] := SBIdx; 
  Diff := Length(Txt) - SBLen; 
  SBIdx := 1; 
  Idx := 0; 
  while (SBIdx > 0) and (Idx <= Diff) do 
  begin 
    SBIdx := SBLen; 
    while (SB[SBIdx] = Txt[(Idx + SBIdx)]) and (SBIdx > 0) do 
      Dec(SBIdx); 
    if SBIdx > 0 then 
    begin 
      Posi := Tabelle[Ord(Txt[(Idx + SBIdx)])]; 
      if Posi = -1 then 
        Inc(Idx, SBIdx) 
      else if Posi > SBIdx then 
        Inc(Idx, 1) 
      else 
        Inc(Idx, SBIdx - Posi); 
    end; 
  end; 
  if SBIdx = 0 then 
    result := Idx + 1; 
end; 
 
procedure TextBoxSuche(cm: TCustomMemo; suche: String); 
var 
  lg, start: integer; 
begin 
  lg := Length(suche); 
  start := stelle + BoyerMooreSuche(suche, copy(cm.Text, stelle, maxint)) - 
    Ord(stelle > 0); 
  if start > 0 then 
  begin 
    if start <> stelle - 1 then 
    begin 
      stelle := start; 
      cm.selstart := stelle - 1; 
      cm.perform(em_scrollcaret, 0, 0); 
      cm.sellength := lg; 
      Inc(stelle, lg); 
    end 
    else 
    begin 
      stelle := 0; 
      cm.sellength := 0; 
      showmessage 
        ('Bis zum Ende durchsucht.'#13#10'Suche beginnt jetzt wieder am Anfang.'); 
    end; 
  end 
  else 
    showmessage('Suchbegriff nicht vorhanden.'); 
  cm.setfocus; 
end; 
 
// Beispielaufruf: Ein Memo durchsuchen. 
// Bei jedem Klick auf den Button wird 
// zur nächsten Fundstelle gesprungen 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  TextBoxSuche(Memo1, 'Ärger'); 
end;