// Eine Textdatei wird nach Vorkommen einer Zeichenfolge durchsucht.
// Dabei kann festgelegt werden, ob die exakte Schreibweise beachtet
// werden soll, ob nur nach ganzen Wörtern gesucht werden soll und ob
// jedesmal, wenn der Begriff gefunden wurde, "Weitersuchen" abgefragt
// werden soll. Das Ergebnis liegt als String vor und kann beispielsweise
// in einem Label angezeigt werden.
// Querverweis: eine Datei nach bestimmten Zeichen durchsuchen
 

// Getestet mit RS 10.4 unter W11

// Variante für ANSI, UTF-8, UTF-8 mit BOM, UTF-16 LE, UTF-16 BE

var 
  zeilen: array of integer; 
 
function finde_in(Datei, wort: string; gleicheSchreibweise, nurGanzesWort, 
  Einzelabfrage: boolean): integer; 
var 
  sl: TStringList; 
  x, lg, kml, zl, stelle: integer; 
  z: String; 
 
  function box(txt: string; bttn: uint): integer; 
  begin 
    result := application.messagebox(pchar(txt), 
      pchar('Textsuche in ' + extractfilename(Datei)), bttn); 
  end; 
  function buchst(c: char): boolean; 
  begin 
    result := CharInSet(c, ['A' .. 'Z', 'a' .. 'z', '0' .. '9', 'Ä', 'Ö', 'Ü', 
      'ä', 'ö', 'ü', 'ß']); 
  end; 
  function davor(i: integer): boolean; 
  begin 
    if i = 1 then 
    begin 
      result := true; 
      exit; 
    end; 
    result := not buchst(sl[x][i - 1]); 
  end; 
  function danach(i: integer): boolean; 
  begin 
    inc(i, lg); 
    if i > length(sl[x]) then 
    begin 
      result := true; 
      exit; 
    end; 
    result := not buchst(sl[x][i]); 
  end; 
  function da(ss: string): integer; 
  var 
    y: integer; 
  begin 
    result := 0; 
    kml := 0; 
    repeat 
      y := pos(wort, ss); 
      if y > 0 then 
      begin 
        if nurGanzesWort then 
        begin 
          kml := kml + y; 
          if davor(kml) and danach(kml) then 
            inc(result); 
        end 
        else 
          inc(result); 
        ss := copy(ss, y + lg, length(ss)); 
        kml := kml + lg - 1; 
      end; 
    until y = 0; 
  end; 
 
begin 
  result := 0; 
  zeilen := nil; 
  stelle := 0; 
  lg := length(wort); 
  if lg = 0 then 
    exit; 
  if not gleicheSchreibweise then 
    wort := ansilowercase(wort); 
  sl := TStringList.create; 
  try 
    sl.LoadFromFile(Datei, TEncoding.UTF8); 
  except 
    sl.LoadFromFile(Datei); 
  end; 
  if sl.count > 0 then 
    for x := 0 to sl.count - 1 do 
    begin 
      if not gleicheSchreibweise then 
        sl[x] := ansilowercase(sl[x]); 
      zl := da(sl[x]); 
      if zl > 0 then 
      begin 
        result := result + zl; 
        setlength(zeilen, stelle + 1); 
        zeilen[stelle] := x + 1; 
        inc(stelle); 
        if zl = 1 then 
          z := '' 
        else 
          z := #32 + inttostr(zl) + 'x'; 
        if Einzelabfrage then 
          if box('"' + wort + '"' + z + ' in Zeile ' + inttostr(x + 1) + 
            ' gefunden'#13'Weiter suchen?', mb_yesno) = idno then 
          begin 
            sl.free; 
            exit; 
          end; 
      end; 
    end; 
  sl.free; 
  if Einzelabfrage then 
  begin 
    if stelle = 0 then 
      box('"' + wort + '" nicht gefunden', mb_ok) 
    else 
      box('Bis zum Ende durchsucht. '#13' "' + wort + '" ' + inttostr(result) + 
        ' mal gefunden.', mb_ok) 
  end; 
end; 
 
function suche_in(Datei, suchbegriff: string; 
  gleicheSchreibweise, nurGanzesWort, Einzelabfrage: boolean): string; 
var 
  i, j, k: integer; 
  s: string; 
begin 
  if fileexists(Datei) then 
  begin 
    i := finde_in(Datei, suchbegriff, gleicheSchreibweise, nurGanzesWort, 
      Einzelabfrage); 
    k := length(zeilen) - 1; 
    if k = 0 then 
      s := 'Zeile ' 
    else 
      s := 'den Zeilen '; 
    for j := 0 to k do 
    begin 
      s := s + inttostr(zeilen[j]); 
      if j = k - 1 then 
        s := s + ' und ' 
      else if j <> k then 
        s := s + ', '; 
    end; 
    case i of 
      0: 
        result := 'Nichts gefunden.'; 
      1: 
        result := 'Begriff einmal in ' + s + ' gefunden.'; 
    else 
      result := 'Begriff insgesamt ' + inttostr(i) + ' mal in ' + s + 
        ' gefunden.'; 
    end; 
  end 
  else 
    result := 'Datei nicht gefunden.'; 
end;

 
// ------ Beispielaufrufe ------------- 
 
// Das Gesamtsuchergebnis wird in Label1 angezeigt 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  suche_in('D:\Test1.txt', 'Zeichen', false, false, true); 
end; 
 
// Bei jedem gefundenen Begriff wird die entsprechende Zeile 
// angezeigt und "Weitersuchen" abgefragt 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  Label1.caption := suche_in('D:\Test2.txt', 'zeichen', false, false, false); 
end;

//------------------------------------------------------------

// Alte Variante (nur geringfügig anders)

// Getestet mit D4 unter WinME

var 
  zeilen: array of integer; 
 
function finde_in(datei, wort: string; 
  gleicheSchreibweise, nurGanzesWort, Einzelabfrage: boolean): integer; 
var 
  sl: TStringList; 
  x, lg, kml, zl, stelle: integer; 
  function box(txt: string; bttn: uint): integer; 
  begin 
    result := application.messagebox(pchar(txt), pchar('Textsuche in ' + 
      extractfilename(datei)), bttn); 
  end; 
  function buchst(c: char): boolean; 
  begin 
    result := c in ['A'..'Z', 'a'..'z', '0'..'9', 'Ä', 'Ö', 'Ü', 'ä', 'ö', 'ü', 'ß']; 
  end; 
  function davor(i: integer): boolean; 
  begin 
    if i = 1 then begin result := true; exit; end; 
    result := not buchst(sl[x][i - 1]); 
  end; 
  function danach(i: integer): boolean; 
  begin 
    inc(i, lg); 
    if i > length(sl[x]) then begin result := true; exit; end; 
    result := not buchst(sl[x][i]); 
  end; 
  function da(ss: string): integer; 
  var 
    y: integer; 
  begin 
    result := 0; 
    kml := 0; 
    repeat 
      y := pos(wort, ss); 
      if y > 0 then begin 
        if nurGanzesWort then begin 
          kml := kml + y; 
          if davor(kml) and danach(kml) then inc(result); 
        end else inc(result); 
        ss := copy(ss, y + lg, length(ss)); 
        kml := kml + lg - 1; 
      end; 
    until y = 0; 
  end; 
begin 
  result := 0; 
  zeilen := nil; 
  stelle := 0; 
  lg := length(wort); 
  if lg = 0 then exit; 
  if not gleicheschreibweise then wort := ansilowercase(wort); 
  sl := TStringList.create; 
  sl.loadfromfile(datei); 
  if sl.count > 0 then 
    for x := 0 to sl.count - 1 do begin 
      if not gleicheschreibweise then sl[x] := ansilowercase(sl[x]); 
      zl := da(sl[x]); 
      if zl > 0 then begin 
        result := result + zl; 
        setlength(zeilen, stelle + 1); 
        zeilen[stelle] := x + 1; 
        inc(stelle); 
        if Einzelabfrage then 
          if box('"' + wort + '" in Zeile ' + inttostr(x + 1) + 
            ' gefunden'#13'Weiter suchen?', mb_yesno) = idno 
            then begin sl.free; exit; end; 
      end; 
    end; 
  sl.free; 
  if Einzelabfrage then begin 
    if stelle = 0 then 
      box('"' + wort + '" nicht gefunden', mb_ok) else 
      box('Bis zum Ende durchsucht. '#13' "' + wort + '" ' + inttostr(result) + 
        ' mal gefunden.', mb_ok) 
  end; 
end; 
 
function suche_in(datei, suchbegriff: string; 
  gleicheSchreibweise, nurGanzesWort, Einzelabfrage: boolean): string; 
var 
  i, j, k: integer; 
  s: string; 
begin 
  if fileexists(datei) then begin 
    i := finde_in(datei, suchbegriff, gleicheSchreibweise, nurGanzesWort, Einzelabfrage); 
    k := length(zeilen) - 1; 
    if k = 0 then s := 'Zeile ' 
    else s := 'den Zeilen '; 
    for j := 0 to k do begin 
      s := s + inttostr(zeilen[j]); 
      if j = k - 1 then s := s + ' und ' 
      else if j <> k then s := s + ', '; 
    end; 
    case i of 
      0: result := 'Nichts gefunden.'; 
      1: result := 'Begriff einmal in ' + s + ' gefunden.'; 
    else result := 'Begriff insgesamt ' + inttostr(i) + ' mal in ' + s + ' gefunden.'; 
    end; 
  end else result := 'Datei nicht gefunden.'; 
end; 
 
 
// ------ Beispielaufrufe ------------- 
 
// Das Gesamtsuchergebnis wird in Label1 angezeigt 
procedure TForm1.Button7Click(Sender: TObject); 
begin 
  label1.caption := suche_in('c:\test.txt', 'der', false, false, false); 
end; 
 
// Bei jedem gefundenen Begriff wird die entsprechende Zeile 
// angezeigt und "Weitersuchen" abgefragt 
procedure TForm1.Button8Click(Sender: TObject); 
begin 
  suche_in('c:\autoexec.bat', 'SET', false, false, true); 
end;