Удалить лишние пробелы

[Иван 883]

Помогите исправить ошибку. В файле удаляется вся первая строка, а остальные строки даже не программа не считывает Вот код:

procedure DeleteSpaces(p:byte; S:string);
begin
  repeat
    p:=Pos('  ',S);
    if p>0 then Delete (S,p,1);
  until p=0;
  if S[1]=' ' then
    Delete(S,1,1);
  if S[length(S)]=' ' then
    Delete(S,length(S),1);
end;

procedure InputData(var NameFile,S:string; var p:byte);
var FileIn:text;
begin
  write('Введите имя входного файла ');
  readln(NameFile);
  assign(FileIn,NameFile);
  {$I-}
  reset(FileIn);
  {$I+}
    if IOResult<>0 then
      begin
        writeln('Ошибка!Файл ',NameFile,' не найден!');
        readln;
        exit;
      end;
    while not Eof(FileIn) do
      begin
        readln(FileIn,S);
        DeleteSpaces(p,S);
      end;
    Close(FileIn);
end;

procedure OutputData(NameFile:string; var FileOut:text; S:string; p:byte);
var FileIn:text;
begin
  write('Введите имя выходного файла ');
  readln(NameFile);
  assign(FileOut,NameFile);
  rewrite(FileOut);
  writeln(FileOut,S);  
  Close(FileOut);
end;

var FileIn,FileOut:text;
    S,NameFile:string;
    p:byte;
begin
  InputData(NameFile,S,p);
  OutputData(NameFile,FileOut,S,p);
end.

Препод сказал, что в основной программе должнен быть только вывов процедур.

[Sazary]

Нет ) Так работать не будет.
Зачем вы передаете процедурам p, S и прочее? Определите их прямо в процедуре.
Дальше:

procedure DeleteSpaces(p:byte; S:string);

Строку-то вы изменяете, но только внутри процедуры.
А это вообще кошмар:

rewrite(FileOut);
  writeln(FileOut,S);  
  Close(FileOut);

В общем, вот:

uses crt;

procedure DeleteSpaces(var S:string);
var p : integer;
begin
  repeat
    p:=Pos('  ',S);
    if p>0 then Delete (S,p,1);
  until p=0;
  if S[1]=' ' then
    Delete(S,1,1);
  if S[length(S)]=' ' then
    Delete(S,length(S),1);
end;
{---------}

procedure InputData;
var NameFile,S:string;
FileIn:text;
FileOut : text;
begin
  write('Введите имя входного файла ');
  readln(NameFile);
  assign(FileIn,NameFile);
  {$I-}
  reset(FileIn);
  {$I+}
    if IOResult<>0 then
      begin
        writeln('Ошибка!Файл ',NameFile,' не найден!');
        readln;
        exit;
      end;
  write('Введите имя выходного файла ');
  readln(NameFile);
  assign(FileOut,NameFile);
  rewrite(FileOut);

    while not Eof(FileIn) do
      begin
        readln(FileIn,S);
        DeleteSpaces(S);
        writeln(FileOut,S);
      end;
    Close(FileIn);
    Close(FileOut);
end;


begin
  clrscr;
  InputData;
end.

[Иван 883]

Спасибо Sazary. А вообще возможно разбить процедуру InputData на 2, т.е. что б в одной процедуре учавствовал входной файл и действия над ним, а в другой выходной файл?

[Sazary]

А вообще возможно разбить процедуру InputData на 2, т.е. что б в одной процедуре учавствовал входной файл и действия над ним, а в другой выходной файл?

Тогда придется заводить массив строк. Заполнять его в первой процедуре и писать из него во второй. А иначе-то как?
Действия-то тут какие? Запись из первого файла во второй (с некоторыми преобразованиями). Поэтому и в процедуре должны участвовать оба файла.
Смысла разбивать не вижу.

[Иван 883]

К сожалению препод сказал, что нужно разбить процедуру на 2. Вот некоторые соображения:

type Mas=array[1..50] of string;

function InputData(var a:Mas):integer;
var FileIn:text;
    NameFile:string;
    i:integer;
begin
  write('Введите имя входного файла ');
  readln(NameFile);
  assign(FileIn,NameFile);
  {$I-}
  reset(FileIn);
  {$I+}
    if IOResult<>0 then
      begin
        writeln('Ошибка!Файл ',NameFile,' не найден!');
        readln;
        exit;
      end;
    i:=0;
    while not Eof(FileIn) do
      begin
        inc(i);
        readln(FileIn,a[i]);
      end;
  Close(FileIn);
  InputData:=i;
end;

procedure DeleteSpaces(var a:Mas; SizeOfFile:integer);
var p,i:integer;
begin
  for i:=1 to SizeOfFile do
    repeat
      p:=Pos('  ',a[i]);
      if p>0 then Delete (a[i],p,1);
    until p=0;
    if a[1]=' ' then
      Delete(a[i],1,1);
    if a[length(a[i])]=' ' then
      Delete(a[i],length(a[i]),1);
end;
function OutputData(a:Mas):integer;
var NameFile:string;
    FileOut:text;
    i:integer;
begin
  write('Введите имя выходного файла ');
  readln(NameFile);
  assign(FileOut,NameFile);
  rewrite(FileOut);
  inc(i);
  writeln(FileOut,a[i]);
  Close(FileOut);
  OutputData:=i;
end;

var a:Mas;
    SizeOfFile:integer;
begin
  clrscr;
  InputData(a);
  DeleteSpaces(a,SizeOfFile);
  OutputData(a);
  readln;
end.

Но я не зная как в таком случае организовать вывод данных. Помогите пожалуйста

Спасибо Sazary. К сожалению не могу оставить Вам отзыв, т.к. Вы были последним кому я его оставлял.

[Sazary]

Ваш код не смотрел, т.к. проще сориентироваться в том, что было.
Рабочий вариант:

uses crt;

type Mas=array[1..50] of string;

procedure DeleteSpaces(var a : mas; n : integer);
var p,i : integer;
begin
for i:=1 to n do
 begin
  repeat
    p:=Pos('  ',a[i]);
    if p>0 then Delete (a[i],p,1);
  until p=0;
  if a[i][1]=' ' then
    Delete(a[i],1,1);
  if a[i][length(a[i])]=' ' then
    Delete(a[i],length(a[i]),1);
 end;
end;
{---------}

procedure InputData(var a : mas; var n : integer);
var NameFile:string;
FileIn:text;
begin
  write('Введите имя входного файла ');
  readln(NameFile);
  assign(FileIn,NameFile);
  {$I-}
  reset(FileIn);
  {$I+}
    if IOResult<>0 then
      begin
        writeln('Ошибка!Файл ',NameFile,' не найден!');
        readln;
        exit;
      end;
    n := 0;
    while not Eof(FileIn) do
      begin
      inc(n);
      readln(FileIn,a[n]);
      end;
    Close(FileIn);
end;
{-----------}
procedure OutputData(a : mas; n : integer);
var
FileOut : text;
NameFile:string;
i : integer;
begin
write('Введите имя выходного файла ');
readln(NameFile);
assign(FileOut,NameFile);
rewrite(FileOut);

for i:=1 to n do
 writeln(FileOut,a[i]);

close(FileOut);
end;
{----------}
var M : mas;
n : integer;

begin
  clrscr;
  InputData(M,n);
  DeleteSpaces(M,n);
  OutputData(M,n);
end.