DBR Delphi-Ecke

// Getestet mit D4 unter XP

// Falls elektronische Listen (oder auch Datenbanken) schlampig geführt werden
// (oder von mehreren Personen, die sich nicht untereinander absprechen),
// kann das zu den unterschiedlichsten Schreibweisen für ein und den selben
// Begriff führen. Neben der Unübersichtlichkeit kann das auch zu Fehlern
// bei Auswertungen führen. Wenn man nun solche Datenbestände "auf Vordermann"
// bringen soll, muss man im schlimmsten Fall jeden Begriff einzeln ändern.
// Beispielsweise stand ich vor dem Problem die Begriffe
// deutsch
// Deutsch
// deutsch.
// Deutschl.
// Deutschl .
// deutschland
// Deutschlan
// deutschland
// deutschland.
// Deutschlnd.
// in Deutschland zu überführen. Das bedeutete 10 Läufe durch den Datenbestand,
// um jede Schreibweise aufzuspüren (mit der Ungewissheit, vielleicht eine
// Schreibweise doch noch übersehen zu haben). Aus diesem Grund entstand der
// folgende Code, der alles in einem Rutsch erledigt.

Variante 1:

Erläuterungen der Parameter:

Gesamt
Der String, in dem etwas ersetzt werden soll.

Such
Zu suchender Begriff. Er und (meistens) weitere Buchstaben werden ersetzt.

Ersatz
Dieser Begriff wird eingefügt.

IgnoreCase (normalerweise TRUE)
Bezieht sich nur auf den Such-Begriff und legt fest, ob Groß- und Kleinschreibung
bei der Suche ignoriert wird.

IgnoreVocal (normalerweise TRUE)
Bezieht sich nur auf den Ersatz-Begriff und legt fest, ob beim Vergleich der
Schreibweise die Vokale übergangen werden. Damit ist es beispielsweise möglich
bei der Suche nach "deutsch" auch "Deutschlnd." (fehlendes "a") gegen
"Deutschland" auszutauschen. Wäre dieser Parameter FALSE, bekäme man das
Ergebnis "Deutschlandnd.".
Weggelassene Konsonanten werden jedoch nicht beachtet. So wäre bei dem
Begriff "Deutschld." (fehlendes "n") das Ergebnis "Deutschlandd.".

DeleteSpace (normalerweise TRUE)
Bei manchen Begriffen findet man zwischen Wort und Punkt noch ein
(aus Versehen) eingeschobenes Leerzeichen (z.B. "deutschl ."), welches
normalerweise auch noch entfernt werden muss. Setzt man diesen Parameter
auf FALSE, wird das Leerzeichen als Beginn eines neuen Begriffes aufgefasst
und des Ersetzen abgebrochen. Somit bleibt das Leerzeichen und der Punkt erhalten.
Es werden aber immer nur (ein oder mehrere) Leerzeichen beachtet, auf die ein
Punkt folgt.

function Ersetzen(Gesamt, Such, Ersatz: string; 
  IgnoreCase, IgnoreVocal, DeleteSpace: boolean): string; 
const 
  vc = ['a', 'e', 'i', 'o', 'u', 'ä', 'ö', 'ü']; 
var 
  p, lgs, lge: integer; 
  hlp, teil1: string; 
  procedure DeletePoint; 
  var 
    x, pp: integer; 
  begin 
    pp := 0; 
    for x := 1 to length(hlp) do 
      if hlp[x] = '.' then begin 
        pp := x - 1; 
        break; 
      end else 
        if (hlp[x] = #32) and DeleteSpace 
          then inc(pp) 
        else break; 
    inc(pp); 
    if (length(hlp) < pp) or (hlp[pp] <> '.') 
      then exit else delete(hlp, 1, pp); 
  end; 
begin 
  if Gesamt = '' then begin 
    if Such = '' then result := Ersatz 
    else result := ''; 
    exit; 
  end; 
  if IgnoreCase then begin 
    Such := AnsiLowerCase(Such); 
    hlp := AnsiLowerCase(Gesamt); 
  end else hlp := Gesamt; 
  p := pos(Such, hlp); 
  if p = 0 then begin 
    result := Gesamt; 
    exit; 
  end; 
  lgs := length(Such); 
  lge := length(Ersatz); 
  teil1 := copy(Gesamt, 1, p - 1); 
  hlp := copy(hlp, p + lgs, maxint); 
  DeletePoint; 
  if lge > lgs then begin 
    if not IgnoreCase then hlp := AnsiLowerCase(hlp); 
    Such := AnsiLowerCase(Ersatz); 
    while lgs <= lge do begin 
      if hlp = '' then break; 
      inc(lgs); 
      if IgnoreVocal and (Such[lgs] in vc) 
        then begin 
        if (Such[lgs] = hlp[1]) 
          then delete(hlp, 1, 1); 
        Continue; 
      end; 
      if (Such[lgs] <> hlp[1]) 
        then break 
      else delete(hlp, 1, 1); 
    end; 
    DeletePoint; 
  end; 
  result := 
    teil1 + Ersatz + copy(Gesamt, length(Gesamt) - length(hlp) + 1, maxint); 
end;

// ----------- Beispiel ---------------- 
 
// Listbox zwecks Test füllen 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  with Listbox1 do begin 
    clear; 
    Items.add('deutschl.'); 
    Items.add('Deutsch .'); 
    Items.add('Deutschlan'); 
    Items.add('deutschland .'); 
    Items.add('Mein deutschland lob ich mir.'); 
    Items.add('Staat: deutsch'); 
    Items.add('Thür .'); 
    Items.add('Thüring.'); 
    Items.add('in thüringen'); 
    Items.add('Thürng.'); 
    Items.add('Thüring. / deutschlnd.'); 
  end; 
end; 
 
// Listbox bearbeiten 

procedure TForm1.Button2Click(Sender: TObject); 
var x: integer; 
begin 
  with Listbox1 do begin 
    for x := 0 to Items.count - 1 do begin 
      Items[x] := Ersetzen(Items[x], 'deutsch', 'Deutschland', true, true, true); 
      Items[x] := Ersetzen(Items[x], 'Thür', 'Thüringen', true, true, true); 
    end; 
  end; 
end;

// vorher / nachher

deutschl.
Deutsch .
Deutschlan
deutschland .
Mein deutschland lob ich mir.
Staat: deutsch
Thür .
Thüring.
in thüringen
Thürng.
Thüring. / deutschlnd.

Deutschland
Deutschland
Deutschland
Deutschland
Mein Deutschland lob ich mir.
Staat: Deutschland
Thüringen
Thüringen
in Thüringen
Thüringen
Thüringen / Deutschland

Schlussbemerkung:
Der Code ist gedacht um Kurzschreibweisen in die Langform zu überführen. Sollten
Sie trotzdem den umgekehrten Weg gehen wollen, müssen Sie zur Fehlervermeidung
zunächst die Langform einsetzen und dann mit der Kurzform ersetzen. Beispiel:

with Listbox1 do begin
    for x := 0 to Items.count - 1 do begin
      Items[x] := Ersetzen(Items[x], 'Thür', 'Thüringen', true, true, true);
      Items[x] := Ersetzen(Items[x], 'Thüringen', 'Thürng.', true, true, true);
    end;
end;

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

Variante 2:

Da die Parameter IgnoreCase, IgnoreVocal und DeleteSpace aus Variante 1
normalerweise sowieso auf TRUE stehen, wurden sie hier gleich weggelassen.
Dafür wird mittels "maxlang" überprüft, ob das Ergebnis der Ersetzung nicht
etwa eine vorgegebene Länge überschreitet (für Datenbanken relevant), und
"erledigt" zeigt an, ob ein Begriff ersetzt wurde oder nicht.

function Ersetzen(Gesamt, Such, Ersatz: string; 
  maxlang: word; var erledigt: byte): string; 
const 
  vc = ['a', 'e', 'i', 'o', 'u', 'ä', 'ö', 'ü']; 
var 
  p, lgs, lge: integer; 
  hlp, teil1: string; 
  procedure DeletePoint; 
  var 
    x, pp: integer; 
  begin 
    pp := 0; 
    for x := 1 to length(hlp) do 
      if hlp[x] = '.' then begin 
        pp := x - 1; 
        break; 
      end else 
        if (hlp[x] = #32) 
          then inc(pp) 
        else break; 
    inc(pp); 
    if (length(hlp) < pp) or (hlp[pp] <> '.') 
      then exit else delete(hlp, 1, pp); 
  end; 
begin 
  erledigt := 0; 
  lge := length(Ersatz); 
  if lge > maxlang then exit; 
  if Gesamt = '' then begin 
    if Such = '' then begin 
      result := Ersatz; 
      erledigt := 1; 
    end else result := ''; 
    exit; 
  end; 
  Such := AnsiLowerCase(Such); 
  hlp := AnsiLowerCase(Gesamt); 
  p := pos(Such, hlp); 
  if p = 0 then begin 
    erledigt := 2; 
    result := Gesamt; 
    exit; 
  end; 
  lgs := length(Such); 
  teil1 := copy(Gesamt, 1, p - 1); 
  hlp := copy(hlp, p + lgs, maxint); 
  DeletePoint; 
  if lge > lgs then begin 
    Such := AnsiLowerCase(Ersatz); 
    while lgs <= lge do begin 
      if hlp = '' then break; 
      inc(lgs); 
      if (Such[lgs] in vc) 
        then begin 
        if (Such[lgs] = hlp[1]) 
          then delete(hlp, 1, 1); 
        Continue; 
      end; 
      if (Such[lgs] <> hlp[1]) 
        then break 
      else delete(hlp, 1, 1); 
    end; 
    DeletePoint; 
  end; 
  hlp := 
    teil1 + Ersatz + copy(Gesamt, length(Gesamt) - length(hlp) + 1, maxint); 
  if length(hlp) > maxlang then result := Gesamt 
  else begin 
    result := hlp; 
    erledigt := 1 + ord(hlp = Gesamt); 
  end; 
end; 
 
// ----------- Beispiel ---------------- 
 
// Listbox füllen 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  with listbox1 do begin 
    clear; 
    Items.add('deutschl.'); 
    Items.add('deutschlnd.'); 
    Items.add('Deutsch .'); 
    Items.add('Deutschla.'); 
    Items.add('deutschland .'); 
    Items.add('Mein deutschland lob ich mir.'); 
  end; 
end; 
 
// Listbox bearbeiten 
 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  s, such, erg: string; 
  rueckgabe: byte; 
  ts: TStringlist; 
  maxlang: word; 
  x: integer; 
begin 
  maxlang := 12; 
  such := 'deutsch'; 
  ts := TStringlist.create; 
  with Listbox1 do begin 
    for x := 0 to Items.count - 1 do begin 
      erg := Ersetzen(Items[x], such, 'Deutschland', maxlang, rueckgabe); 
      case rueckgabe of 
        0: s := '"' + Items[x] + '" konnte nicht ersetzt werden.'; 
        1: begin s := '"' + Items[x] + '" wurde ersetzt.'; 
            Items[x] := erg; 
          end; 
      else s := '"' + Items[x] + '" ist nicht betroffen.'; 
      end; 
      ts.add(formatfloat('Zeile 00000 : ', x) + s); 
    end; 
  end; 
  ts.savetofile('C:\Protokoll.txt'); 
  ts.free; 
end;