// Es geht darum ein anderes Stringreplace einzusetzen, bei dem man angeben
// kann, dass das neue Wort in der Schreibweise an das alte Wort angepasst
// wird, und auch wieviele Mal eine Zeichenfolge ersetzt werden soll.
 

// Alte Version
// Getestet mit D4 unter WinME

type 
  TMyReplaceType = set of (IgnoreCase, SameSpelling); 
 
function MyReplace(const s, OldPattern, NewPattern: string; Number: integer; 
  Way: TMyReplaceType): string; 
var 
  mq, mz: TStringStream; 
  x, z, lga, lgn, lgs: integer; 
  c, v: string; 
  procedure withcomparison; 
  var i, j: integer; 
  begin 
    if lga <= lgn then begin 
      j := lgn - lga; 
      for i := 1 to lga do 
        if isCharUpper(c[i]) then 
          charupperbuff(@mz.datastring[i + x + z * j], 1) 
        else charlowerbuff(@mz.datastring[i + x + z * j], 1); 
      if lgn > lga then begin 
        if isCharUpper(c[lga]) then 
          charupperbuff(@mz.datastring[x + lga + z * j + 1], j) else
          charlowerbuff(@mz.datastring[x + lga + z * j + 1], j);
      end; 
    end else begin 
      j := lga - lgn; 
      for i := 1 to lgn do 
        if isCharUpper(c[i]) then 
          charupperbuff(@mz.datastring[i + x - z * j], 1) 
        else charlowerbuff(@mz.datastring[i + x - z * j], 1); 
    end; 
  end; 
begin 
  lga := length(OldPattern); 
  if (lga > 0) then begin 
    lgn := length(NewPattern); 
    z := 0; 
    v := ansilowercase(OldPattern); 
    lgs := length(s); 
    setlength(c, lga); 
    mq := TStringStream.create(s); 
    mz := TStringStream.create(result); 
    try 
      x := 0; 
      while x <= mq.size - lga do begin 
        mq.position := x; 
        mq.readbuffer(c[1], lga); 
        if (c = OldPattern) or ((IgnoreCase in Way) and (ansilowercase(c) = v)) 
          then begin 
          if lgn > 0 then begin 
            mz.writebuffer(NewPattern[1], lgn); 
            if SameSpelling in Way then withcomparison; 
          end; 
          inc(z); 
          inc(x, lga); 
          if z = Number then break; 
        end else begin 
          mz.writebuffer(c[1], 1); 
          inc(x); 
        end; 
      end; 
      mq.position := x; 
      if x < lgs then 
        mz.copyfrom(mq, lgs - x); 
      result := mz.datastring; 
    finally 
      mz.free; 
      mq.free; 
    end; 
  end else result := s; 
end; 
 
// Beispielaufruf: Vergleich StringReplace mit MyReplace 
procedure TFormx.BitBtn2Click(Sender: TObject); 
begin 
  richedit1.lines.add(MyReplace('Ich bin im Nebenhaus', 'Haus', 'GEBÄUDE', -1, 
    [SameSpelling, Ignorecase])); 
  richedit1.lines.add(StringReplace('Ich bin im Nebenhaus', 'Haus', 'GEBÄUDE', 
    [rfIgnorecase, rfReplaceall])); 
end; 

Ergebnis Myreplace:     Ich bin im Nebengebäude
Ergebnis StringReplace: Ich bin im NebenGEBÄUDE

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

// Neue Version
// Getestet mit RS 10.4 unter W11

// Zusätzlich kann man jeden Buchstabe einzeln an die Schreibweise anpassen.
 

type 
  TMyReplaceType = set of (IgnoreCase, SameSpelling, EachLetter); 
 
function NewReplace(const s, OldPattern, NewPattern: string; Number: Integer; 
  Way: TMyReplaceType): string; 
var 
  x, z, lga, lgn, lgs: Integer; 
  c, v: string; 
  b: Boolean; 
 
  function withcomparison(ac: String; lg: Integer): String; 
  var 
    i: Integer; 
    rs: string; 
  begin 
    if b then 
    begin 
      rs := ''; 
      for i := lg + 1 to lg + lgn do 
        if isCharLower(s[i]) then 
          rs := rs + LowerCase(NewPattern[i - lg]) 
        else 
          rs := rs + UpperCase(NewPattern[i - lg]); 
      Result := rs; 
    end 
    else if isCharLower(ac[1]) and (SameSpelling in Way) then 
    begin 
      Result := AnsiLowercase(NewPattern); 
    end 
    else 
      Result := NewPattern; 
  end; 
 
begin 
  try 
    lga := length(OldPattern); 
    if lga = 0 then 
    begin 
      Result := s; 
      exit; 
    end; 
    b := EachLetter in Way; 
    lgn := length(NewPattern); 
    if b and (lga <> lgn) then 
    begin 
      showmessage('Bei EachLetter müssen OldPattern and NewPattern ' + 
        'die gleiche Länge haben'); 
      Result := s; 
      exit; 
    end; 
    z := 0; 
    v := LowerCase(OldPattern); 
    lgs := length(s); 
    x := 1; 
    while x <= lgs do 
    begin 
      c := copy(s, x, lga); 
      if (c = OldPattern) or ((IgnoreCase in Way) and (AnsiLowercase(c) = v)) 
      then 
      begin 
        if lgn > 0 then 
        begin 
          Result := Result + withcomparison(Ansilastchar(Result), 
            length(Result)); 
        end; 
        inc(z); 
        inc(x, lga); 
        if z = Number then 
          break; 
      end 
      else 
      begin 
        Result := Result + copy(c, 1, 1); 
        inc(x); 
      end; 
    end; 
    Result := Result + copy(s, x, lgs - pred(x)); 
  except 
    Result := s; 
    showmessage('Unerwarteter Fehler'); 
  end; 
end; 
 
// Alle Begriffe ersetzen 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  RichEdit1.Clear; 
  RichEdit1.lines.add 
    (NewReplace('Ich bin im Nebenhaus, Vorderhaus oder Hinterhaus', 'Haus', 
    'GEBÄUDE', -1, [SameSpelling, IgnoreCase])); 
end; 
 
Ergebnis: Ich bin im Nebengebäude, Vordergebäude oder Hintergebäude 

 
 
// Nur die ersten zwei Begriffe ersetzen 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  RichEdit1.Clear; 
  RichEdit1.lines.add 
    (NewReplace('Ich bin im Nebenhaus, Vorderhaus oder Hinterhaus', 'Haus', 
    'GEBÄUDE', 2, [SameSpelling, IgnoreCase])); 
end; 
 
Ergebnis Ich bin im Nebengebäude, Vordergebäude oder Hinterhaus 

 
 
// Ersetzung buchstabenweise vornehmen 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  RichEdit1.Clear; 
  RichEdit1.lines.add(NewReplace('Test TEST test tESt ', 'test', 'Jazz', -1, 
    [EachLetter, IgnoreCase])); 
end; 
 
Ergebnis: Jazz JAZZ jazz jAZz