Код:
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils,
windows;
const n=20;
type
tstudent = record
name:string[10];
kurs:Byte;
group:Byte;
spec:string[10];
mark:String[5];
end;
tmas=array [1..n] of tstudent;
tfile=file of tstudent;
var a:tmas;
f,f1,f3:Text;
f2:tfile;
s:String;
//-----------------------------------------------------------------
procedure vvoddannuh;
var i:Integer;
p:tstudent;
begin
Rewrite(f);
writeln (f,'------------------------------------------------------------');
writeln (f,' фио /к/г/ спец-ть /оценки ');
writeln (f,'------------------------------------------------------------');
for i:=1 to n do
with p do
begin
Write('введи фамилию');
Readln(name);
Write('введи курс');
Readln(kurs);
Write('введи группу');
Readln(group);
Write('введи специальность');
Readln(spec);
Write('введи результат последней сессии');
Readln(mark);
writeln(f,name:10,kurs:1,group:1,spec:10,mark:5);
writeln
end;
Close(f)
end;
//------------------------------------------------------------------------------
Procedure printdannuh(a:tmas);
var i:Integer;
begin
Rewrite(f1);
//Rewrite(f2);
writeln (f1,'------------------------------------------------------------');
writeln (f1,' фио /к/г/ спец-ть /оценки ');
writeln (f1,'------------------------------------------------------------');
for i:=1 to n do
With a[i] Do
begin
writeln(f1,name,kurs,group,spec,mark);
// write(f2,a[i])
end;
Close(f1);
//Close(f2);
end;
//-----------------------------------------------
procedure read_info( a:tmas);
var i:integer;
begin
Reset(f);
readln(f);
readln(f);
readln(f);
for i:=1 to n do
//With a[i] Do
begin
Readln(f,a[i].name,a[i].kurs,a[i].group,a[i].spec,a[i].mark);
//Здесь нужно убрать лишние пробелы ...
// name:=TrimLeft(name);
// spec:=TrimLeft(spec)
end;
Close(f)
end;
procedure sort(var a:tmas);
var x:tstudent; i,j:integer;
begin
for i:=1 to n-1 do
for j:=1 to n-i do
begin
if a[j].kurs>a[j+1].kurs then
begin
x:=a[j]; a[j]:=a[j+1]; a[j+1]:=x;
end;
if a[j].kurs=a[j+1].kurs then
if a[j].group>a[j+1].group then
begin
x:=a[j]; a[j]:=a[j+1]; a[j+1]:=x;
end;
end;
end;
//------------------------------------------------------------------------------
procedure Odnofam (r:byte; a:tmas);
var i,j,kk,k: byte; aa:tmas; s,ss: string; f3: Text; f2:tfile;
begin
Assign(f3,'list3.txt');
assign(f2,'list_3.dat');
Rewrite(f3);
Rewrite(f2);
Seek(f2,FileSize(f2)); //Указатель в конец файла
Writeln(f3);
s:='Список групп, в которых есть однофамильцы: ';
k:=0;
for i:=1 to r do
for j:=i+1 to r do
with a[i] do
if a[i].name=a[j].name then
begin
inc(k);
kk:=0;
str(a[i].group,ss);
ss:=' '+ss+' ';
if pos(ss,s)=0 then s:=s+ss;
if kk=0 then
aa[k]:=a[i]
end;
if k>=1 then
for i:=1 to k do
with aa[i] do
begin
Writeln(f3,'Фио', name);
Writeln(f3,'к', kurs);
Writeln(f3,'г', group);
Writeln(f3,'спец-ть', spec);
Writeln(f3,'оценки',mark);
Writeln(f3);
Write(f2,aa[i])
end
else
writeln('таких групп нет');
writeln(s);
Close(f3);
Close(f2);
readln;
end;
//------------------------------------------------------------------------------
begin
setconsoleoutputcp(1251);
SetConsoleCP(1251);
Assign(f,'list_1.txt');
Assign(f1,'list_2.txt');
Assign(f2,'list_3.dat');
if FileExists('list_1.txt') then
begin
read_info(a);
Reset(f);
while not Eof(f) do
begin
Readln(f,s);
Writeln(s)
end;
Close(f);
sort(a);
writeln('список отсортирован');
printdannuh(a);
Odnofam(n,a);
Reset(f1);
while not Eof(f1) do
begin
Readln(f1,s);
Writeln(s)
end;
Close(f1);
end
else
vvoddannuh;
Readln
end.
вот исправила вроде,но теперь вместо однофамильцев 0 выводит.может кто подскажет что исправить надо