Mehrfaches suchen und ersetzen in einem Druchlauf

[BlueStarHH]

Ich möchte in einem String verschiedene Substrings durch andere Substrings ersetzen. Mit StringReplace() geht das. Was ist zusätzlich möchte ist, dass ich in der Replace-Funktion mehrere Substrings angeben kann. Es soll also in einem Druchlauf auf das Vorhandensein eines Substrings aus allen Substrings geprüft werden und dieser ersetzt werden.

Beispiel:
StringReplaceEx(SourceString, [OldPatternA, OldPatternB, OldPatternC], [NewPatternA, NewPatternB, NewPatternC]);

OldPatternA soll durch NewPatternA und OldPatternB durch NewPatternB uws ersetzt werden. Man könnte jetzt einfach die normale StringReplace mehrdach hintereinander aufrufen. Das möchte ich aus Performance-Gründen aber nicht.

Wer hat eine Idee? Danke!

[xaromz]

Hallo,

hier hab' ich eine Routine gepostet, die genau das kann.

Gruß
xaromz

[BlueStarHH]

Zitat:

Zitat von xaromz

Hallo,

hier hab' ich eine Routine gepostet, die genau das kann.

Gruß
xaromz

Danke, das sieht schonmal ganz gut aus. Nur benötige ich die Unterscheitung der Groß-/Kleinschreibung nicht. Könnte jemand die Funktion noch so abändern, dass wahlweise die Groß-/Kleinschreibung berücksichtig wird oder nicht? Asembler kann ich leider nicht, sonst hätte ich es gemacht. Danke!

[xaromz]

Hallo,

ich hab' mal meine Routine etwas überarbeitet. Jetzt kann man einstellen, ob Groß-/Kleinschreibung beachtet werden soll.

Delphi-Quellcode:

function StringReplaceMultiple(const Source: AnsiString;
  const OldPatterns, NewPatterns: array of AnsiString;
  CaseSensitive: Boolean = True): AnsiString;
// Replace every occurrence

type
  TFoundPos = record
    Position: Integer;
    PatternNum: Integer;
  end;

var
  C: Integer;
  FoundCount: Integer;
  SourcePosition: Integer;
  PatternCount: Integer;
  Positions: array of TFoundPos;
  PositionLength: Integer;

  PatternNum: Integer;
  SourceLength, OldPatternLength, NewPatternLength: Integer;
  OldLengths, NewLengths: array of Integer;
  DeltaOld: Integer;

  Delta: Integer;

  PSource, PDest, PNew: PAnsiChar;

  SearchSource: AnsiString;
  CasePatterns: array of AnsiString;

  I: Integer;
begin
  if (Source = '') or (Length(OldPatterns) <> Length(NewPatterns)) then
  begin
    Result := Source;
    Exit;
  end;

  try
    // Initialize some variables
    PatternCount := Length(OldPatterns);
    SourceLength := Length(Source);
    SetLength(OldLengths, PatternCount);
    SetLength(NewLengths, PatternCount);
    Delta := 0;
    DeltaOld := 0;
    for C := 0 to PatternCount - 1 do
    begin
      OldLengths[C] := Length(OldPatterns[C]);
      NewLengths[C] := Length(NewPatterns[C]);
      Inc(DeltaOld, OldLengths[C]);
    end;
    DeltaOld := Round(DeltaOld / PatternCount);

    SetLength(CasePatterns, PatternCount);
    if CaseSensitive then
    begin
      SearchSource := Source;
      for C := 0 to PatternCount - 1 do
        CasePatterns[C] := OldPatterns[C];
    end else
    begin
      SearchSource := AnsiLowerCase(Source);
      for C := 0 to PatternCount - 1 do
        CasePatterns[C] := AnsiLowerCase(OldPatterns[C]);
    end;

    FoundCount := 0;

    // ----------------------------------
    // Check the amount of replaces
    // ----------------------------------

    // We *should* range check here, but who has strings > 2GB ?
    PositionLength := SourceLength div DeltaOld + 1;
    SetLength(Positions, PositionLength);

    C := 1;
    while C <= SourceLength do
    begin
      for PatternNum := 0 to PatternCount - 1 do
      begin
        if (SearchSource[C]) = (CasePatterns[PatternNum][1]) then // Check first char before we waste a jump to CompareMem
        begin
          if CompareMem(@SearchSource[C], @CasePatterns[PatternNum][1], OldLengths[PatternNum]) then
          begin
            if FoundCount >= PositionLength then
            begin
              Inc(PositionLength, 4);
              SetLength(Positions, PositionLength);
            end;

            Positions[FoundCount].Position := C; // Store the found position
            Positions[FoundCount].PatternNum := PatternNum;
            Inc(FoundCount);
            Inc(C, OldLengths[PatternNum] - 1); // Jump to after OldPattern
            Inc(Delta, NewLengths[PatternNum] - OldLengths[PatternNum]);
            Break;
          end;
        end;
      end;
      Inc(C);
    end;

    SetLength(CasePatterns, 0);

    // ----------------------------------
    // Actual replace
    // ----------------------------------

    if FoundCount > 0 then // Have we found anything?
    begin
      // We know the length of the result
      // Again, we *should* range check here...
      SetLength(Result, SourceLength + Delta);

      // Initialize some variables
      SourcePosition := 1;
      PSource := PAnsiChar(Source);
      PDest := PAnsiChar(Result);

      // Replace...

      for C := 0 to FoundCount - 1 do
      begin
        // Copy original and advance resultpos
        PNew := PAnsiChar(NewPatterns[Positions[C].PatternNum]);

        Move(PSource^, PDest^, Positions[C].Position - SourcePosition);
        Inc(PDest, Positions[C].Position - SourcePosition);

        // Append NewPattern and advance resultpos
        Move(PNew^, PDest^, NewLengths[Positions[C].PatternNum]);
        Inc(PDest, NewLengths[Positions[C].PatternNum]);

        // Jump to after OldPattern
        Inc(PSource, Positions[C].Position - SourcePosition + OldLengths[Positions[C].PatternNum]);
        SourcePosition := Positions[C].Position + OldLengths[Positions[C].PatternNum];
      end;

      // Append characters after last OldPattern
      Move(PSource^, PDest^, SourceLength - SourcePosition + 1);
    end else
      Result := Source; // Nothing to replace

    // Clean up
    Finalize(Positions);
  except
  end;
end;

Die Routine benötigt jeztt die Unit SysUtils.

Gruß
xaromz

[BlueStarHH]

Danke, das funktioniert wunderbar!