Quitar dos espacios en cadena dejar uno

[roman]

A ver si ésta (recorre una sóla vez la cadena):

Código Delphi [-]
function ComprimeEspacios(S: String): String;
var
  I: Integer;

begin
  I := 1;

  while I <= Length(S) do
  begin
    while (I <= Length(S)) and (S[i] <> ' ') do
      Inc(I);

    Inc(I);

    while (I <= Length(S)) and (S[i] = ' ') do
      Delete(S, I, 1);

    Inc(I);
  end;

  Result := S;
end;

// Saludos