program mas1;
type
mas = array [1..20] of string;
mass = array [1..20] of integer;
procedure check(const a: mas; var b: mas; var c: mass;
const n: integer; var p: integer);
var
i, T, start, finish: integer;
begin
p := 0;
for i := 1 to n do begin
start := pos('/*', a[i]);
finish := pos('*/', a[i]);
if start * finish > 0 then begin
if start > finish then begin
T := finish; finish := start; start := T
end;
writeln('debug: start = ', start, ' finish = ', finish);
inc(p);
b[p] := copy(a[i], start + 2, finish - start - 2);
c[p] := i;
end;
end;
end;
var
a, b: mas;
c: mass;
n,k,i,u:integer;
y,x:string;
begin
write('k = '); readln(k);
for i := 1 to k do
readln(a[i]);
check(a, b, c, k, u);
for i := 1 to u do
writeln(b[i], '':5, c[i]);
readln;
end.
procedure check(const a: mas; var b: mas; var c: mass;
const n: integer; var p: integer);
var
i, T, start, finish: integer;
begin
p := 0;
for i := 1 to n do begin
finish := -1;
repeat
inc(finish, 2);
start := finish + pos('/*', copy(a[i], finish, 255)) - 1;
finish := finish + pos('*/', copy(a[i], finish, 255)) - 1;
if start <> finish then begin
if start > finish then begin
T := finish; finish := start; start := T
end;
inc(p);
b[p] := copy(a[i], start + 2, finish - start - 2);
c[p] := i;
end;
until start = finish;
end;
end;
Должно работать...uses crt;
type
TType = string;
TArray = array [1..100] of TType;
procedure Input(var arr : TArray; n : byte);
var
i : byte;
begin
for i := 1 to n do begin
write('s[',i,']=');
readln(arr[i]);
end;
writeln;
end;
procedure CheckStr(s : TType; var arr : TArray; size : byte; var i : byte);
const
open = '/*';
close = '*/';
begin
while (length(s) > 0) and (pos(open,s) <> 0) do begin
delete(s,1,pos(open,s)+1);
if (pos(close,s) < pos(open,s)) or ((pos(close,s) <> 0) and (pos(open,s) = 0)) then begin
inc(i);
arr[i] := copy(s,1,pos(close,s)-1);
delete(s,1,pos(close,s)+1);
end;
end;
end;
var
_in,_out : TArray;
size,size1,j : byte;
begin
clrscr;
write('n = '); readln(size);
Input(_in, size);
size1 := 0;
for j := 1 to size do CheckStr(_in[j], _out, size, size1);
for j := 1 to size1 do writeln(_out[j]);
readln;
end.
но мне еще надо чтобы она выводила символ (с наименьшим кодом) из получившихся строк и чтобы в исходных строках она удаляла пробелы в начале строки 
uses crt;
type
TType = string;
TArray = array [1..100] of TType;
mass=array [1..20] of integer;
procedure Input(var arr : TArray; n : byte);
var
i : byte;
begin
for i := 1 to n do begin
write('s[',i,']=');
readln(arr[i]);
end;
writeln;
end;
procedure CheckStr(s : TType; var arr : TArray;var rew:mass; size : byte; var i : byte;var j:integer);
const
open = '/*';
close = '*/';
var
k:integer;
e:integer;
q:integer;
begin
while (length(s) > 0) and (pos(open,s) <> 0) do begin
delete(s,1,pos(open,s)+1);
if (pos(close,s) < pos(open,s)) or ((pos(close,s) <> 0) and (pos(open,s) = 0)) then begin
inc(i);
arr[i] := copy(s,1,pos(close,s)-1);
rew[i]:=j;
delete(s,1,pos(close,s)+1);
end;
end;
end;
procedure tri(var s:tarray;var n:byte);
var j,q,e,k:integer;
x:string;
begin
k:=0;
e:=0;
for q:=1 to n do
begin
x:=s[q];
begin
for j:=1 to length(s[q]) do
begin
if copy(x,j,1)=' ' then
begin
k:=k+1;
end;
end;
for e:=k to length(s[q]) do
begin
write(x[e]);
end;
end;
end;
end;
var
_in,_out : TArray;
rew:mass;
size,size1,i,n : byte;
j:integer;
begin
clrscr;
write('n = '); readln(size);
Input(_in, size);
begin
tri(_in,size);
end;
size1 := 0;
for j := 1 to size do
CheckStr(_in[j], _out,rew, size, size1,j);
for j := 1 to size1 do
begin
writeln(_out[j],' ',rew[j]);
end;
readln;
end.
Надоел !!!