close
دانلود فیلم
سورس 118 در پاسکال

دوستان عزیز می تونید سورس دفترچه تلفن ۱۱۸ رو از ادامه مطلب دریافت کنید

uses crt,dos;
type
   tel=record
  name:string[25];
  family:string[30];
  tel:string[20];
  email:string[70];
  address:string;
  end;
label newadd;
var op,v,a,s,sn,sf,sp,o,d,don:byte;
pop:array[1..6] of string[15];
mview:array[1..3] of string[15];
madd:array[1..3] of string[15];
msearch:array[1..4] of string[15];
msn:array[1..2] of string[15];
mdell:array[1..3] of string[15];
mdellon:array[1..4] of string[15];
{  meno  }
procedure color(f,b:byte);
begin
textcolor(f);
textbackground(b);
gotoxy(3,op+1);
write(pop[op]);
end;
{  meno view  }
procedure colorv(f,b:byte);
begin
textcolor(f);
textbackground(b);
gotoxy(4,v+1);
write(mview[v]);
end;
{  meno add  }
procedure colora(f,b:byte);
begin
textcolor(f);
textbackground(b);
gotoxy(4,a+1);
write(madd[a]);
end;
{  meno search  }
procedure colors(f,b:byte);
begin
textcolor(f);
textbackground(b);
gotoxy(4,s+1);
write(msearch[s]);
end;
{  meno search by name }
procedure colorsn(f,b:byte);
begin
textcolor(f);
textbackground(b);
gotoxy(4,sn+1);
write(msn[sn]);
end;
{  meno search by family  }
procedure colorsf(f,b:byte);
begin
textcolor(f);
textbackground(b);
gotoxy(4,sf+1);
write(msn[sf]);
end;
{  meno search by phone  }
procedure colorsp(f,b:byte);
begin
textcolor(f);
textbackground(b);
gotoxy(4,sp+1);
write(msn[sp]);
end;
{  meno delete  }
procedure colord(f,b:byte);
begin
textcolor(f);
textbackground(b);
gotoxy(4,d+1);
write(mdell[d]);
end;
{  meno delete one by one  }
procedure colordon(f,b:byte);
begin
textcolor(f);
textbackground(b);
gotoxy(4,don+1);
write(mdellon[don]);
end;
var f:file of tel;
    i,j,sv,k,l,m,ssn,n,p,q,eras:byte;
    key,vkey,akey,skey,ne,snkey,sfkey,spkey,dkey,donkey:char;
    re:registers;
    te:tel;
    addre,na,name,family,phone:string;
begin
textmode(co80);
textmode(co80);
with re do
begin
ah:=1;
ch:=$20;
cl:=$20;
end;
intr($10,re);
clrscr;
textbackground(3);
clrscr;
textcolor(blue);
write('                        this program write by Hasanpor- 874101603 ');
readkey;
clrscr;
{  meno  }
pop[1]:='<< new  >>';
pop[2]:='<< view >>';
pop[3]:='<< add  >>';
pop[4]:='<<search>>';
pop[5]:='<<delete>>';
pop[6]:='<< quit >>';op:=1;
{  view meno  }
mview[1]:=' <back ';
mview[2]:='  next> ';
mview[3]:=' cancel ';v:=1;
{  add meno  }
madd[1]:='  new  ';
madd[2]:='  add  ';
madd[3]:=' cancel ';a:=1;
{  search meno  }
msearch[1]:='by name ';
msearch[2]:='by family ';
msearch[3]:='by phone ';
msearch[4]:='cancel  ';s:=1;
{ search by name family phone meno}
msn[1]:='continue';
msn[2]:=' cancel ';sn:=1;sf:=1;sp:=1;
{ dellete meno }
mdell[1]:='   all  ';
mdell[2]:='one by one';
mdell[3]:='  cancel ';d:=1;
{ dellete meno one by one }
mdellon[1]:=' erase ';
mdellon[2]:=' <back ';
mdellon[3]:='  next> ';
mdellon[4]:=' cancel ';don:=1;
repeat
textbackground(3);clrscr;
window(65,1,79,24);
textbackground(0);
clrscr;
window( 65,1,78,23);
textbackground(7);
clrscr;
textcolor(1);
sv:=0;
for i:=1 to 6 do
begin
gotoxy(3,i+1);
write(pop[i]);
end;
color(14,1);
repeat
repeat
key:=readkey;
if key=#0 then key:=readkey;
until key in [#13,#71,#72,#79,#80];
color(1,7);
case key of
#71:op:=1;
#79:op:=6;
#72:if op>1 then dec(op)
else op:=6;
#80:if op<6 then inc(op)
else
op:=1;
end;
color(14,1);
until key=#13;
window(1,1,80,25);
textbackground(3);clrscr;
gotoxy(30,12);
case op of
1:begin
  assign(f,'c:tel.bat');
  {$i-}
  reset(f);
  {$i+}
  if ioresult<>0 then
  begin
  assign(f,'c:tel.dat');
  rewrite(f);
   window(4,3,61,12);
   textbackground(black);
   clrscr;
   window(4,3,60,11);
   textbackground(white);
   clrscr;
   textcolor(blue);
   writeln;
   writeln(' first name : ');
   writeln(' last name  : ');
   writeln(' phone      : ');
   writeln(' email      : ');
   writeln(' address    : ');
   with te do
   begin
   window(4,4,60,4);
   textbackground(white);
   clrscr;
   write(' first name : ');readln(name);
   write(' first name : ',name);
   window(4,5,60,5);
   textbackground(white);
   clrscr;
   write(' last name  : ');readln(family);
   write(' last name  : ',family);
    window(4,6,60,6);
   textbackground(white);
   clrscr;
   write(' phone      : ');readln(tel);
   write(' phone      : ',tel);
   window(4,7,60,7);
   textbackground(white);
   clrscr;
   write(' email      : ');readln(email);
   write(' email      : ',email);
   window(4,8,60,8);
   textbackground(white);
   clrscr;
   write(' address    : ');readln(address);
   write(' address    : ',address);
   end;
  write(f,te);
  close(f);
  end
  else
  begin
  close(f);
  repeat
  window(6,7,40,11);
  textbackground(white);
  clrscr;
  textcolor(blue);
  writeln(' there are tel.dat in drive C ');
  write(' are you sure make new file [y/n]:');
  ne:=readkey;writeln(ne);
  until (upcase(ne)='Y') or (upcase(ne)='N');
  if upcase(ne)='Y' then
  begin
  assign(f,'c:tel.dat');
  rewrite(f);
   window(4,3,61,12);
   textbackground(black);
   clrscr;
   window(4,3,60,11);
   textbackground(white);
   clrscr;
   textcolor(blue);
   writeln;
   writeln(' first name : ');
   writeln(' last name  : ');
   writeln(' phone      : ');
   writeln(' email      : ');
   writeln(' address    : ');
   seek(f,filesize(f));
   with te do
   begin
   window(4,4,60,4);
   textbackground(white);
   clrscr;
   write(' first name : ');readln(name);
   write(' first name : ',name);
   window(4,5,60,5);
   textbackground(white);
   clrscr;
   write(' last name  : ');readln(family);
   write(' last name  : ',family);
    window(4,6,60,6);
   textbackground(white);
   clrscr;
   write(' phone      : ');readln(tel);
   write(' phone      : ',tel);
   window(4,7,60,7);
   textbackground(white);
   clrscr;
   write(' email      : ');readln(email);
   write(' email      : ',email);
   window(4,8,60,8);
   textbackground(white);
   clrscr;
   write(' address    : ');readln(address);
   write(' address    : ',address);
   end;
   write(f,te);
   close(f);
  end
  else break;
  end;
  end;
2:begin
   assign(f,'c:tel.dat');
   {$i-}
   reset(f);
   {$i+}
   if ioresult<>0 then
     begin
     repeat
     window(6,7,40,11);
     textbackground(15);
     clrscr;
     textcolor(blue);
     writeln('  can not find tel.dat in c: ');
     writeln('  please enter address tel.dat ');
     write('  ');
     readln(addre);
     until addre<>'';
   assign(f,addre);
   {$i-}
   reset(f);
   {$i+}
   if ioresult<>0 then
     begin
     window(6,7,40,11);
     textbackground(15);
     clrscr;
     textcolor(red);
     writeln('  can not find tel.dat in c: ');
     writeln('  please make new file ');
     readkey;
     halt;
     end;
     end;
   repeat
   window(4,3,61,12);
   textbackground(black);
   clrscr;
   window(4,3,60,11);
   textbackground(white);
   clrscr;
   textcolor(blue);
   seek(f,sv);
   read(f,te);
   with te do
   begin
   writeln;
   writeln(' first name : ',name);
   writeln(' last name  : ',family);
   writeln(' phone      : ',tel);
   writeln(' email      : ',email);
   writeln(' address    : ',address);
   {write('    ',filesize(f),'    ',filepos(f));}
   end;
   {textbackground(3);clrscr;}
   window(65,2,79,12);
   textbackground(0);
   clrscr;
   window( 65,2,78,11);
   textbackground(7);
   clrscr;
   textcolor(1);
   for j:=1 to 3 do
   begin
   gotoxy(4,j+1);
   write(mview[j]);
   end;
   colorv(14,1);
   repeat
   repeat
   vkey:=readkey;
   if vkey=#0 then vkey:=readkey;
   until vkey in [#13,#71,#72,#79,#80];
   colorv(1,7);
   case vkey of
   #71:v:=1;
   #79:v:=3;
   #72:if v>1 then dec(v)
   else v:=3;
   #80:if v<3 then inc(v)
   else
   v:=1;
   end;
   colorv(14,1);
   until vkey=#13;
   window(1,1,80,25);
   textbackground(3);clrscr;
   case v of
   1:if sv>0 then dec(sv)
   else sv:=0;
   2:if sv<filesize(f)-1 then inc(sv);
   end;
   until v=3;
   close(f);
end;
3:begin
   assign(f,'c:tel.dat');
   {$i+}
   reset(f);
   {$i+}
    if ioresult<>0 then
     begin
     repeat
     window(6,7,40,11);
     textbackground(15);
     clrscr;
     textcolor(blue);
     writeln('  can not find tel.dat in c: ');
     writeln('  please enter address tel.dat ');
     write('  ');
     readln(addre);
     until addre<>'';
   assign(f,addre);
   {$i-}
   reset(f);
   {$i+}
   if ioresult<>0 then
     begin
     window(6,7,40,11);
     textbackground(15);
     clrscr;
     textcolor(red);
     writeln('  can not find tel.dat in c: ');
     writeln('  please make new file ');
     readkey;
     halt;
     end;
     end;
   newadd: window(4,3,61,12);
   textbackground(black);
   clrscr;
   window(4,3,60,11);
   textbackground(white);
   clrscr;
   textcolor(blue);
   writeln;
   writeln(' first name : ');
   writeln(' last name  : ');
   writeln(' phone      : ');
   writeln(' email      : ');
   writeln(' address    : ');
   seek(f,filesize(f));
   with te do
   begin
   window(4,4,60,4);
   textbackground(white);
   clrscr;
   write(' first name : ');readln(name);
   write(' first name : ',name);
   window(4,5,60,5);
   textbackground(white);
   clrscr;
   write(' last name  : ');readln(family);
   write(' last name  : ',family);
    window(4,6,60,6);
   textbackground(white);
   clrscr;
   write(' phone      : ');readln(tel);
   write(' phone      : ',tel);
   window(4,7,60,7);
   textbackground(white);
   clrscr;
   write(' email      : ');readln(email);
   write(' email      : ',email);
   window(4,8,60,8);
   textbackground(white);
   clrscr;
   write(' address    : ');readln(address);
   write(' address    : ',address);
   end;
   repeat
   window(65,2,79,12);
   textbackground(0);
   clrscr;
   window( 65,2,78,11);
   textbackground(7);
   clrscr;
   textcolor(1);
   for k:=1 to 3 do
   begin
   gotoxy(4,k+1);
   write(madd[k]);
   end;
   colora(14,1);
   repeat
   repeat
   akey:=readkey;
   if akey=#0 then akey:=readkey;
   until akey in [#13,#71,#72,#79,#80];
   colora(1,7);
   case akey of
   #71:a:=1;
   #79:a:=3;
   #72:if a>1 then dec(a)
   else a:=3;
   #80:if a<3 then inc(a)
   else
   a:=1;
   end;
   colora(14,1);
   until akey=#13;
   window(1,1,80,25);
   textbackground(3);clrscr;
   case a of
   1:goto newadd;
   2:write(f,te);
   end;
   until a=3;
   close(f);
   end;
4:begin
    assign(f,'c:tel.dat');
   {$i+}
   reset(f);
   {$i+}
    if ioresult<>0 then
     begin
     repeat
     window(6,7,40,11);
     textbackground(15);
     clrscr;
     textcolor(blue);
     writeln('  can not find tel.dat in c: ');
     writeln('  please enter address tel.dat ');
     write('  ');
     readln(addre);
     until addre<>'';
   assign(f,addre);
   {$i-}
   reset(f);
   {$i+}
   if ioresult<>0 then
     begin
     window(6,7,40,11);
     textbackground(15);
     clrscr;
     textcolor(red);
     writeln('  can not find tel.dat in c: ');
     writeln('  please make new file ');
     readkey;
     halt;
     end;
     end;
    repeat
    window(65,2,79,12);
   textbackground(0);
   clrscr;
   window( 65,2,78,11);
   textbackground(7);
   clrscr;
   textcolor(1);
    for k:=1 to 4 do
   begin
   gotoxy(4,k+1);
   write(msearch[k]);
   end;
   colors(14,1);
   repeat
   repeat
   skey:=readkey;
   if skey=#0 then skey:=readkey;
   until skey in [#13,#71,#72,#79,#80];
   colors(1,7);
   case skey of
   #71:s:=1;
   #79:s:=4;
   #72:if s>1 then dec(s)
   else s:=4;
   #80:if s<4 then inc(s)
   else
   s:=1;
   end;
   colors(14,1);
   until skey=#13;
   window(1,1,80,25);
   textbackground(3);clrscr;
   case s of
   1:begin
         window(1,1,80,25);
         textbackground(3);
         clrscr;
         window(4,4,60,8);
         textbackground(white);
         clrscr;
         textcolor(blue);
         writeln;
         write(' please enter name for searching : ');readln(name);
         repeat
         window(65,2,79,12);
         textbackground(0);
         clrscr;
        window( 65,2,78,11);
        textbackground(7);
        clrscr;
        textcolor(1);
        for m:=1 to 2 do
        begin
        gotoxy(4,m+1);
        write(msn[m]);
        end;
        colorsn(14,1);
        repeat
        repeat
        snkey:=readkey;
        if snkey=#0 then snkey:=readkey;
        until snkey in [#13,#71,#72,#79,#80];
        colorsn(1,7);
        case snkey of
        #71:sn:=1;
        #79:sn:=2;
        #72:if sn>1 then dec(sn)
        else sn:=2;
        #80:if sn<2 then inc(sn)
        else
        sn:=1;
        end;
        colorsn(14,1);
        until snkey=#13;
        window(1,1,80,25);
        textbackground(3);clrscr;
        case sn of
        1:begin
          ssn:=0;
          while  ssn<filesize(f) do
          begin
          seek(f,ssn);
          read(f,te);
          if name=te.name then
          begin
          with te do
          begin
          window(4,3,61,12);
          textbackground(black);
          clrscr;
          window(4,3,60,11);
          textbackground(white);
          clrscr;
          textcolor(blue);
          writeln;
          writeln(' first name : ',name);
          writeln(' last name  : ',family);
          writeln(' phone      : ',tel);
          writeln(' email      : ',email);
          writeln(' address    : ',address);
          readkey;
          end;
        end;
        inc(ssn);
        end;
        end;
        end;
        until sn=2;
end;
2:begin
         ssn:=0;
         window(1,1,80,25);
         textbackground(3);
         clrscr;
         window(4,4,60,8);
         textbackground(white);
         clrscr;
         textcolor(blue);
         writeln;
         write(' please enter family for searching : ');readln(family);
         repeat
         window(65,2,79,12);
         textbackground(0);
         clrscr;
        window( 65,2,78,11);
        textbackground(7);
        clrscr;
        textcolor(1);
        for n:=1 to 2 do
        begin
        gotoxy(4,n+1);
        write(msn[n]);
        end;
        colorsf(14,1);
        repeat
        repeat
        sfkey:=readkey;
        if sfkey=#0 then sfkey:=readkey;
        until sfkey in [#13,#71,#72,#79,#80];
        colorsf(1,7);
        case sfkey of
        #71:sf:=1;
        #79:sf:=2;
        #72:if sf>1 then dec(sf)
        else sf:=2;
        #80:if sf<2 then inc(sf)
        else
        sf:=1;
        end;
        colorsf(14,1);
        until sfkey=#13;
        window(1,1,80,25);
        textbackground(3);clrscr;
        case sf of
        1:begin
          ssn:=0;
          while  ssn<filesize(f) do
          begin
          seek(f,ssn);
          read(f,te);
          if family=te.family then
          begin
          with te do
          begin
          window(4,3,61,12);
          textbackground(black);
          clrscr;
          window(4,3,60,11);
          textbackground(white);
          clrscr;
          textcolor(blue);
          writeln;
          writeln(' first name : ',name);
          writeln(' last name  : ',family);
          writeln(' phone      : ',tel);
          writeln(' email      : ',email);
          writeln(' address    : ',address);
          readkey;
          end;
        end;
        inc(ssn);
        end;
        end;
        end;
        until sf=2;

end;
3:begin
         ssn:=0;
         window(1,1,80,25);
         textbackground(3);
         clrscr;
         window(4,4,60,8);
         textbackground(white);
         clrscr;
         textcolor(blue);
         writeln;
         write(' please enter phone for searching : ');readln(phone);
         repeat
         window(65,2,79,12);
         textbackground(0);
         clrscr;
        window( 65,2,78,11);
        textbackground(7);
        clrscr;
        textcolor(1);
        for o:=1 to 2 do
        begin
        gotoxy(4,o+1);
        write(msn[o]);
        end;
        colorsp(14,1);
        repeat
        repeat
        spkey:=readkey;
        if spkey=#0 then spkey:=readkey;
        until spkey in [#13,#71,#72,#79,#80];
        colorsp(1,7);
        case spkey of
        #71:sp:=1;
        #79:sp:=2;
        #72:if sp>1 then dec(sp)
        else sp:=2;
        #80:if sp<2 then inc(sp)
        else
        sp:=1;
        end;
        colorsp(14,1);
        until spkey=#13;
        window(1,1,80,25);
        textbackground(3);clrscr;
        case sp of
        1:begin
          ssn:=0;
          while  ssn<filesize(f) do
          begin
          seek(f,ssn);
          read(f,te);
          if phone=te.tel then
          begin
          with te do
          begin
          window(4,3,61,12);
          textbackground(black);
          clrscr;
          window(4,3,60,11);
          textbackground(white);
          clrscr;
          textcolor(blue);
          writeln;
          writeln(' first name : ',name);
          writeln(' last name  : ',family);
          writeln(' phone      : ',tel);
          writeln(' email      : ',email);
          writeln(' address    : ',address);
          readkey;
          end;
        end;
        inc(ssn);
        end;
        end;
        end;
        until sp=2;

end;

 

end;
until s=4;
close(f);
end;
5:begin
   repeat
   window(65,2,79,12);
   textbackground(0);
   clrscr;
   window( 65,2,78,11);
   textbackground(7);
   clrscr;
   textcolor(1);
   for p:=1 to 3 do
   begin
   gotoxy(4,p+1);
   write(mdell[p]);
   end;
   colord(14,1);
   repeat
   repeat
   dkey:=readkey;
   if dkey=#0 then dkey:=readkey;
   until dkey in [#13,#71,#72,#79,#80];
   colord(1,7);
   case dkey of
   #71:d:=1;
   #79:d:=3;
   #72:if d>1 then dec(d)
   else d:=3;
   #80:if d<3 then inc(d)
   else
   d:=1;
   end;
   colord(14,1);
   until dkey=#13;
   window(1,1,80,25);
   textbackground(3);clrscr;
   case d of
1:begin
  assign(f,'c:tel.dat');
   {$i-}
   reset(f);
   {$i+}
   if ioresult<>0 then
     begin
     repeat
     window(6,7,40,11);
     textbackground(15);
     clrscr;
     textcolor(blue);
     writeln('  can not find tel.dat in c: ');
     writeln('  please enter address tel.dat ');
     write('  ');
     readln(addre);
     until addre<>'';
   assign(f,addre);
   {$i-}
   reset(f);
   {$i+}
   if ioresult<>0 then
     begin
     window(6,7,40,11);
     textbackground(15);
     clrscr;
     textcolor(red);
     writeln('  can not find tel.dat in c: ');
     writeln('  please make new file ');
     readkey;
     halt;
     end;
     end;
    repeat
  window(6,7,40,11);
  textbackground(white);
  clrscr;
  textcolor(blue);
  writeln('  are you sure you erase all ');
  write('  information![y/n]: ');
  ne:=readkey;writeln(ne);
  until (upcase(ne)='Y') or (upcase(ne)='N');
  if upcase(ne)='Y' then
  begin
  truncate(f);
  window(1,1,80,25);
  textbackground(3);
  clrscr;
  end
  else
  begin
  window(1,1,80,25);
  textbackground(3);
  clrscr;
  break;
  end;
  end;
2:begin
     assign(f,'c:tel.dat');
     {$i-}
     reset(f);
     {$i+}
     if ioresult<>0 then
     begin
     repeat
     window(6,7,40,11);
     textbackground(15);
     clrscr;
     textcolor(blue);
     writeln('  can not find tel.dat in c: ');
     writeln('  please enter address tel.dat ');
     write('  ');
     readln(addre);
     until addre<>'';
     assign(f,addre);
     {$i-}
     reset(f);
     {$i+}
     if ioresult<>0 then
     begin
     window(6,7,40,11);
     textbackground(15);
     clrscr;
     textcolor(red);
     writeln('  can not find tel.dat in c: ');
     writeln('  please make new file ');
     readkey;
     halt;
     end;
     end;

     repeat
     window(4,3,61,12);
     textbackground(black);
     clrscr;
     window(4,3,60,11);
     textbackground(white);
     clrscr;
     textcolor(blue);
     seek(f,sv);
     read(f,te);
     with te do
     begin
     writeln;
     writeln(' first name : ',name);
     writeln(' last name  : ',family);
     writeln(' phone      : ',tel);
     writeln(' email      : ',email);
     writeln(' address    : ',address);
     end;

     window(65,2,79,12);
     textbackground(0);
     clrscr;
     window( 65,2,78,11);
     textbackground(7);
     clrscr;
     textcolor(1);
     for q:=1 to 4 do
     begin
     gotoxy(4,q+1);
     write(mdellon[q]);
     end;
     colordon(14,1);
     repeat
     repeat
     donkey:=readkey;
     if donkey=#0 then donkey:=readkey;
     until donkey in [#13,#71,#72,#79,#80];
     colordon(1,7);
     case donkey of
     #71:don:=1;
     #79:don:=4;
     #72:if don>1 then dec(don)
     else don:=4;
     #80:if don<4 then inc(don)
     else
     don:=1;
     end;
     colordon(14,1);
     until donkey=#13;
     window(1,1,80,25);
     textbackground(3);clrscr;
     case don of
     1:begin
       for eras:=filepos(f) to filesize(f)-1 do
       begin
       seek(f,eras);read(f,te);
       seek(f,filepos(f)-2);write(f,te);
       end;
       truncate(f);
       end;
     2:if sv>0 then dec(sv)
     else sv:=0;
     3:if sv<filesize(f)-1 then inc(sv);
     end;
     {case don of}
     until don=4;
end;
{end of case}end;
{rep6}  until d=3;
end;
end;
window(1,1,80,25);
textbackground(3);
clrscr;
until op=6;
end.

 

لینک کوتاه پست
مطالب مرتبط با پست جاری
  • نکات مهم
    1- لطفا نظر خود را با زبان فارسی بیان کنید
    2- رایتم نظرات اسپم و تبلیغی شما را تایید نمی کند
    3- لطفا نظرات شما بدون ابهام و واضح باشد
  • نام
    ایمیل (منتشر نمی‌شود) (لازم)
    وبسایت
    :):(;):D;)):X:?:P:*=((:O@};-:B/:):S
    نظر خصوصی
    مشخصات شما ذخیره شود ؟[حذف مشخصات] [شکلک ها]
    کد امنیتی
به کانال تلگرام سایت ما بپیوندید