Условие такое:
С помощью текстового редактора создать файл, содержащий текст, длина которого не превышает 700 символов (длина строки текста не должна превышать 70 символов).
Имя файла должно иметь расширение DAT. Написать программу, которая:
- выводит текст на экран дисплея;
- по нажатию произвольной клавиши поочередно выделяет в тексте заданные слова (за-данные слова вводить с клавиатуры).

вот.

uses crt;

Var
 ft:text;
 s:string[70];
 a,b:array[1..11] of string[70];
 m,n,  i,j,f:integer;
 ch:byte;
begin
 Assign(ft,'text700.dat');
 reset(ft);   i:=1;
 while not eof(ft) do begin
  readln(ft,s);
  a[i]:=s;
  inc(i);
 end;m:=i;
 close(Ft);
 write('n='); readln(n);
 writeln('new word - new line');
 for i:=1 to n do readln(b[i]); f:=1; j:=1;
 repeat
  clrscr;
  for i:=1 to m do  begin
   if pos(b[j],a[i])<>0 then begin
    for j:=1 to f do begin
     insert('_',a[i],pos(b[j],a[i]));insert('_',a[i],pos(b[j],a[i])+length(b[j]))
    end;
   end;
   writeln(a[i]);
  end;
  ch:=ord(readkey);
  inc(f);
 until (ch=27) or (f>n);;
 readln;
end.

и файл на котормо тестировал
Нажмите для просмотра прикрепленного файла

Спастбо!!! пошел тестить!!!

Блин не очень что-то во первых постоянно на два пробела увеличивает все слова.Хотелось чтобы цветом выделение шло.

uses crt;

Var
 ft:text;
 s:string[70];
 a,b,c:array[1..11] of string[70];
 m,n,i,j,f:integer;
 ch:byte;

begin
 clrscr;
 Assign(ft,'text700.dat');
 reset(ft);   i:=1;
 while not eof(ft) do begin
  readln(ft,s);
  a[i]:=s;
  inc(i);
 end;m:=i - 1;
 close(Ft);
 for i := 1 to m do
    writeln(a[i]);
 write('n='); readln(n);
 writeln('new word - new line');
 for i:=1 to n do readln(b[i]); f:=1; j:=1;
 repeat
  clrscr;
  c := a;
  for i:=1 to m do
     begin
        if pos(b[f],c[i])<>0 then
           begin
              insert('_',c[i],pos(b[f],c[i]));insert('_',c[i],pos(b[f],c[i])+length(b[f]))
           end;
        writeln(c[i]);
     end;
  ch:=ord(readkey);
  if ch = 0 then ch := ord(readkey);
  inc(f);
 until (ch=27) or (f>n);;
 readln;
end.

немного исправил прогу Altair'a. Единственно если например будет слово в тексте abcd ,то если искать в тексте слово bcd ,то оно найдется в этом слове.

Ребяты сделайте плиз цветом а то так чувствую у меня не примут!!!!

HeX, ну, цветом так цветом

uses crt;

const
  alpha = ['a'..'z', 'A'..'Z'];
var
  ft: text;
  s: string;

  a, b: array[1 .. 50] of string;

  line_count, n,  i,j,f:integer;
  ch:byte;

  p, len: byte;
  start: integer;
  st: string;
  isgray: boolean;

begin
  Assign(ft,'text700.dat');
  reset(ft);

  clrscr;

  line_count := 0;
  while not eof(ft) do begin
    readln(ft,s); writeln(s);
    inc(line_count);
    a[line_count]:=s;
  end;

  close(Ft);

  write('n='); readln(n);
  writeln('new word - new line');
  for i:=1 to n do readln(b[i]);

  clrscr;
  for i:=1 to line_count do begin
    p := 0; st := a[i];

    for j := 1 to n do { !!! }
      repeat
        start := p;
        p := start + pos(b[j], copy(st, start + 1, 255));
      if
        (
          (p <> start)
          and
          ((p = 1) or ( (p > 1) and not(st[p-1] in alpha)))
          and
          (
            (p + pred(length(b[j])) = length(st)) or
            ((p + pred(length(b[j])) < length(st)) and
            not(st[p+length(b[j])] in alpha))
          )
        ) then

        begin
          delete(st, p, length(b[j]));
          insert('~'+b[j]+'~', st, p);

          inc(p, length(b[j]));
        end;
      until p = start;
    a[i] := st;

    isgray := true; textcolor(lightgray);
    st := a[i];
    for len := 1 to length(a[i]) do
      if st[len] = '~' then begin
        if isgray then begin
          textcolor(lightred);
          isgray := false;
        end
        else begin
          textcolor(lightgray);
          isgray := true;
        end
      end
      else write(st[len]);

    writeln;

  end;
  readln;
end.

сам просил

Да........ Наворотил.......
Спасибо!!!

Спасибо но задание звучит так : поочередно выделять заданные слова в тексте!!!!

HeX
Вот возьми и исправь ПО ЗАДАНИЮ. Ясно? Тебе наверное лучше знать, что значит ПООЧЕРЕДНО? Я не являюсь телепатом.

Предупреждение: еще раз воспользуешься ссылкой "сообщить модератору" - приму меры. Эта ссылка НЕ для того, чтобы на себя обращать внимание

Вот тебе поочередно (Жми Enter для выделения следующего слова)...

P.S. Чтобы постов, подобных предыдущему, я больше никогда не видел. Ты что, кого-то нанял на работу, и тебе эту работу не сделали? Я кстати, просил объяснить, что значит "поочередно". Ты не захотел...

uses crt;

const
  alpha = ['a'..'z', 'A'..'Z'];
var
  ft: text;
  s: string;

  a, b: array[1 .. 50] of string;

  line_count, n,  i,j,f:integer;
  ch:byte;

  p, len: byte;
  start: integer;
  ss, st: string;
  isgray: boolean;

procedure print_all;
var i: integer;
begin
  clrscr;
  for i := 1 to line_count do begin
    isgray := true; textcolor(lightgray);
    st := a[i];
    for len := 1 to length(a[i]) do
      if st[len] = '~' then begin
        if isgray then begin
          textcolor(lightred);
          isgray := false;
        end
        else begin
          textcolor(lightgray);
          isgray := true;
        end
      end
      else write(st[len]);

    writeln;
  end;
  readln;
end;

begin
  Assign(ft,'text700.dat');
  reset(ft);

  clrscr;

  line_count := 0;
  while not eof(ft) do begin
    readln(ft,s); writeln(s);
    inc(line_count);
    a[line_count]:=s;
  end;

  close(Ft);

  write('n='); readln(n);
  writeln('new word - new line');
  for i:=1 to n do readln(b[i]);

  clrscr;
  for i:=1 to line_count do begin
    p := 0; st := a[i];

    for j := 1 to n do { !!! }
      repeat
        start := p;
        p := start + pos(b[j], copy(st, start + 1, 255));
      if
        (
          (p <> start)
          and
          ((p = 1) or ( (p > 1) and not(st[p-1] in alpha)))
          and
          (
            (p + pred(length(b[j])) = length(st)) or
            ((p + pred(length(b[j])) < length(st)) and
            not(st[p+length(b[j])] in alpha))
          )
        ) then

        begin
          ss := a[i];

          delete(st, p, length(b[j]));
          insert('~'+b[j]+'~', st, p);

          inc(p, length(b[j]));
          a[i] := st;
          print_all;

          a[i] := ss;
          st := ss;
        end;
      until p = start;
    a[i] := st;

  end;
  readln;
end.