String intelligent Kürzen

[himitsu]

Wenn man Code blind schreibt und nicht prüft
- waren eigentlich nur 2 Fehler ' ' wurde als ungültiges Zeichen mit gelöscht
- und beim Zahlenentfernen war ein NOT zuviel (sei froh, daß keine Zahl vorkam, sonst wären alle -buchstaben gelöscht wurden )
> hab's im Post #10 geändert

Delphi-Quellcode:

type TKueDatErlaubt = function(S: String): Boolean;
// type TKueDatErlaubt = function(S: String): Boolean of object;  // für Objektmethoden
// type TKueDatErlaubt = reference to function(S: String): Boolean;  // ab D2010 für Alles

function KuerzeDateiname(S: String; Len: Integer; Erlaubt: TKueDatErlaubt): String;
var
  i, i2, u: Integer;
  SL: TStrings;
  US: record
    case Integer of
      0: (i: Int64);
      1: (s: Set of 0..63);
  end;
begin
  // ungültige Zeichen entfernen
  for i := Length(S) downto 1 do
    if not (S[i] in [' ', 'a'..'z', 'A'..'Z', '0'..'9']) then
      Delete(S, i, 1);
  // ungültige Zahlen entfernen
  while (i > 0) and (S[i] in ['0'..'9']) do
    Dec(i);
  for i := i downto 1 do
    if (S[i] in ['0'..'9']) then
      Delete(S, i, 1);
  //
  SL := TStringList.Create;
  try
    US.s := [];
    repeat
      U := 0;
      // String aufsplitten
      SL.LineBreak := '';
      SL.Delimiter := ' ';
      SL.StrictDelimiter := True;
      SL.DelimitedText := S;
      // längstes Wort suchen + Capitalize
      i2 := 0;
      for i := SL.Count -1 downto 0 do begin
        SL[i] := UpperCase(Copy(SL[i], 1, 1)) + LowerCase(Copy(SL[i], 2));
        i2 := Max(i2, Length(SL[i]));
      end;
      // Anzahl der zu entfernenden Zeichen
      Len := Length(SL.Text) - Len;
      // kurze Wörter (Einzelbuchstaben) entfernen
      i := SL.Count - 1;
      while (Len > 0) and (i >= 0) do begin
        if Length(SL[i]) = 1 then begin
          if not (U in US.s) then begin
            SL.Delete(i);
            Dec(Len);
          end;
          Inc(U);
        end;
        Dec(i);
      end;
      // Wörter kürzen
      i := -1;
      while (Len > 0) do begin
        if i < 0 then begin
          i := SL.Count - 1;
          Dec(i2);
        end;
        if Length(SL[i]) > i2 then begin
          if not (U in US.s) then begin
            SL[i] := Copy(SL[i], 1, i2) + Copy(SL[i], i2 + 2);
            Dec(Len);
          end;
          Inc(U);
        end;
        Dec(i);
      end;
      // nächstes Set, für's Überspringen
      Inc(US.i);
      // Text zusammensetzen und ausgeben
      Result := SL.Text;
    until Erlaubt(Result);
  finally
    SL.Free;
  end;
end;