برنامه دفتر تلفن به زبان پاسکال همراه سورس کامل

عکس اجرای اول برنامه :

عکس صفحه اصلی برنامه :

ذخیره نام و شماره :

جستجوی نام برای دریافت شماره :

جستجوی شماره برای دریافت نام و فامیلی :

نمایش لیست همه شماره های ذخیره شده :

نمایش مشخصات برنامه :

تغییر پسورد برنامه :

همه داده ها به صورت کد شده در فایل ذخیره می شود و دسترسی مستقیم به داده ذخیره شده مقدور نیست

سورس دفتر تلفن به زبان پاسکال به صورت کامل :

uses crt;
var a,o,b,i:integer;c:char;f:text;x,n:string;ax,az:array[1..20]of char;
{**************************************************************************}
procedure asle;
begin
     textcolor(15);
     window(1,1,80,25);textbackground(1);clrscr;
     writeln;
     writeln('                              bename khoda');
     textcolor(15);gotoxy(1,24);writeln(' asghar.kohi');gotoxy(70,24);write('asghar.kohi');
     window(61,6,77,20);textbackground(0);clrscr;
     window(60,5,75,19);textbackground(2);clrscr;
     window(61,6,74,6);textbackground(5);clrscr;write(' add name,tel');
     window(61,8,74,8);textbackground(5);clrscr;write(' serch name');
     window(61,10,74,10);textbackground(5);clrscr;write('  serch tel');
     window(61,12,74,12);textbackground(5);clrscr;write(' namayehe kol');
     window(61,14,74,14);textbackground(5);clrscr;write(' cheng pass');
     window(61,16,74,16);textbackground(5);clrscr;write(' tamas ba ma');
     window(61,18,74,18);textbackground(5);clrscr;write('     exit');
end;
{**************************************************************************}
procedure mm;
begin
     textcolor(14);
     if a=1 then begin window(61,6,74,6);textbackground(4);clrscr;write(' add name,tel');end;
     if a=2 then begin window(61,8,74,8);textbackground(4);clrscr;write(' serch name');end;
     if a=3 then begin window(61,10,74,10);textbackground(4);clrscr;write('  serch tel');end;
     if a=4 then begin window(61,12,74,12);textbackground(4);clrscr;write(' namayehe kol');end;
     if a=5 then begin window(61,14,74,14);textbackground(4);clrscr;write(' cheng pass');end;
     if a=6 then begin window(61,16,74,16);textbackground(4);clrscr;write(' tamas ba ma');end;
     if a=7 then begin window(61,18,74,18);textbackground(4);clrscr;write('     exit');end;
end;
{**************************************************************************}
procedure add;
var ad,name,tel:string;i:integer;
begin
     assign(f,'asghar_ko.dat');
     textcolor(15);
     append(f);
     window(11,6,46,16);textbackground(0);clrscr;
     window(10,5,45,15);textbackground(6);clrscr;
     textcolor(8);
     writeln('  name va famili khod ra ba fasele ');
     writeln('        yek khane benevisid');
     textcolor(4);writeln('         mesle: asghar kohi');textcolor(15);
     textcolor(15);
     writeln(' name:');
     textcolor(8);
     writeln('   shomare ra ake kod ham darad');
     writeln(' bayad gabl az shomare vared konid');
     textcolor(4);
     writeln('         mesle : 0451*******');
     textcolor(15);
     writeln(' tel:');
     textcolor(13);
     window(16,8,42,8);textbackground(1);clrscr;
     window(16,12,42,12);textbackground(1);clrscr;
     window(16,8,42,8);textbackground(1);clrscr;write(' ');readln(name);write(' ',name);
     for i:=1 to length(name) do
     write(f,chr(ord(name[i])+100));writeln(f);
     window(16,12,42,12);textbackground(1);clrscr;write(' ');readln(tel);write(' ',tel);
     for i:=1 to length(tel) do
     write(f,chr(ord(tel[i])+100));
     writeln(f);
     close(f);
end;
{**************************************************************************}
procedure sena;
var n,name,w:string;xx,yy,aa:array[1..20]of char;i,w1,j,u:integer;
begin
     assign(f,'asghar_ko.dat');
     reset(f);
     textcolor(11);
     window(11,6,46,17);textbackground(0);clrscr;
     window(10,5,45,16);textbackground(6);clrscr;
     writeln(' << name ra bede shomare ra bekir >>');
     textcolor(15);w1:=0;
     writeln(' name :');
     writeln;
     writeln(' shomare:');
     window(18,7,42,7);textbackground(1);clrscr;
     window(18,9,42,15);textbackground(1);clrscr;
     window(18,7,42,7);textbackground(1);clrscr;write(' ');readln(name);write(' ',name);
     for i:=1 to length(name) do
     xx[i]:=(chr(ord(name[i])+100));
     j:=length(name);
     window(18,9,42,15);textbackground(1);clrscr;
     while not eof(f) do
          begin
          u:=0;
          readln(f,n);
          for i:=1 to length(N) do
          yy[i]:=n[i];
          for i:=1 to length(name) do
          if xx[i]=yy[i] then
          u:=u+1;
          if u=j then
begin
     w1:=w1+1;readln(f,n);for i:=1 to length(n) do write(chr(ord(n[i])-100));writeln;end;
end;
    if w1=0 then begin window(21,21,42,24);textbackground(0);clrscr;
    window(20,20,41,23);textbackground(2);clrscr;writeln(' shomareiy ba in name');writeln('   vojod nadarad');
    window(29,22,32,22);textbackground(4);clrscr;write(' ok');end;readln;
end;
{**************************************************************************}
procedure te;
var sh,s,n:string;i,u,j,w1:integer;xx,yy:array[1..20]of char;
begin
     assign(f,'asghar_ko.dat');
     reset(f);
     window(11,6,46,17);textbackground(0);clrscr;
     window(10,5,45,16);textbackground(6);clrscr;
     writeln(' << shomare ra bede name ra bekir >>');
     textcolor(15);
     writeln(' shomare:');
     writeln;w1:=0;
     writeln(' name :');
     window(19,7,42,7);textbackground(1);clrscr;
     window(19,9,42,15);textbackground(1);clrscr;
     window(19,7,42,7);textbackground(1);clrscr;write(' ');readln(sh);write(' ',sh);for i:=1 to length(sh) do
     xx[i]:=chr(ord(sh[i])+100);
     window(19,9,42,15);textbackground(1);clrscr;
     while not eof(f) do
     begin
          readln(f,n);readln(f,s);
          u:=length(s);
          j:=0;
          for i:=1 to length(s) do
          yy[i]:=s[i];
          for i:=1 to length(sh) do
          if xx[i]=yy[i] then j:=j+1;
          if j=u then begin w1:=w1+1;for i:=1 to length(n) do write(chr(ord(n[i])-100));writeln;end;
     end;
     if w1=0 then begin window(21,21,42,24);textbackground(0);clrscr;
    window(20,20,41,23);textbackground(2);clrscr;writeln(' namiy ba in shomare');writeln('   vojod nadarad');
    window(29,22,32,22);textbackground(4);clrscr;write(' ok');end;readln;
end;
{**************************************************************************}
procedure kol;
var n,a:string;i,b,c:integer;
begin
     assign(f,'asghar_ko.dat');
     window(11,6,46,18);textbackground(0);clrscr;
     textcolor(15);
     window(10,5,45,5);textbackground(5);clrscr;write(' << namayesh mohtvaye kole file >>');
     window(10,17,45,17);textbackground(5);clrscr;write('  baraye payan kelidi ra bezanid ');
     window(10,6,45,16);textbackground(6);clrscr;
     i:=14;
     b:=0;
     reset (f);
repeat
     begin
     b:=b+1;if b=3 then begin b:=1;i:=i-3;if i=8 then i:=14;end;
     textcolor(i);
     delay(30000);delay(30000);
     readln(f,n);
     write(' ');
     for c:=1 to length(n) do
     write(chr(ord(n[c])-100));writeln;
     end;
until keypressed;
end;
{**************************************************************************}
procedure bama;
var i:integer;
begin
     window(11,6,47,17);textbackground(0);clrscr;
     window(10,5,45,16);textbackground(5);clrscr;
     for i:=11 downto 1 do
     begin
     delay(30000);delay(20000);clrscr;textcolor(15);
     gotoxy(7,i);
     write('ba salam hkedmat shoma');
     end;
     textcolor(10);
     window(10,6,45,16);textbackground(5);clrscr;
     writeln;
     writeln('   in barname dar tarikh 84/12/1');
     writeln(' tavasote asghar.kohi neveshte shode');
     writeln('ast omidvaram az barname razi bashid');
     writeln;
     writeln('  Emile : asghar.kohi@gmail.com');
     writeln('  web : www.ArtaRoyan.ir');
     writeln;
     textcolor(31);
     write('   Enter ra bezanid :');
     readln;
end;
{**************************************************************************}
procedure exit;
var i,x:integer;
begin
     x:=81;
     textcolor(0);
     for i:=1 to 40 do
     begin
     delay(3000);x:=x-1;
     window(1,1,i,25);textbackground(0);clrscr;
     window(x,1,x,25);textbackground(0);clrscr;
     end;
     b:=1;
     end;
{**************************************************************************}
procedure pas;
var k,p,m:string;g,z,mn:integer;www,eee:array[1..20]of char;
begin
     assign(f,'hi.dat');
     reset (f);
     g:=0;
     window(11,7,41,8);textbackground(0);clrscr;
     window(10,6,40,7);textbackground(2);clrscr;
     textcolor(4);write(' tole ramz nabayad kamtar az 6  khane bashad');
     window(11,11,41,15);textbackground(0);clrscr;
     window(10,10,40,14);textbackground(2);clrscr;
     textcolor(14);
     write('  password mojod:');
     writeln;
     writeln;
     write('  password delkhah:');
     window(11,11,39,11);textbackground(1);clrscr;
     window(11,13,39,13);textbackground(1);clrscr;
     window(11,11,39,11);textbackground(1);clrscr;write(' ');readln(k);write(' ',k);
     z:=0;
     for i:=1 to length(k) do
     www[i]:=k[i];
     readln(f,m);z:=length(m);
     for i:=1 to length(m) do
     eee[i]:=chr(ord(m[i])-122);
     for i:=1 to length(k) do
     if www[i]=eee[i] then g:=g+1;
     if g<>z then begin
     for i:=1 to 10 do begin sound(i*1000);delay(10000);nosound;end;
     window(20,18,42,20);textbackground(6);clrscr;write('  ramz eshtebah ast');
     window(29,19,32,19);textbackground(4);clrscr;write(' ok');readln;end;
     if g=z then
     begin
     window(11,13,39,13);textbackground(1);clrscr;write(' ');readln(p);write(' ',p);
     if length(p)>5 then begin
     close(f);rewrite(f);for i:=1 to length(p) do write(f,chr(ord(p[i])+122));
     close(f);
     mn:=length(p);
     window(20,17,30+mn,17);textbackground(6);clrscr;write(' << ',p,' >> ok');readln;
     end;
     if length(p)<=5 then begin
     for i:=1 to 10 do begin sound(i*1000);delay(10000);nosound;end;
     window(20,18,42,22);textbackground(0);clrscr; window(19,17,41,21);textbackground(4);clrscr;
     write(' tole ramz nabayad az');writeln(' 6 khane kamtar bashad');window(28,20,31,20);textbackground(2);clrscr;write(' ok')
     ;
     readln;
end;
end;
end;
{**************************************************************************}
procedure ent;
begin
     if a=1 then add;
     if a=2 then sena;
     if a=3 then te;
     if a=4 then kol;
     if a=5 then pas;
     if a=6 then bama;
     if a=7 then exit;
end;
{**************************************************************************}
procedure ww;
var i:integer;
begin
     for i:=1 to 10 do
     begin sound(i*100);delay(10000);nosound;end;
end;
{**************************************************************************}
procedure asghar;
begin
     window(1,1,80,25);textbackground(0);clrscr;
     window(20,10,60,10);textbackground(1);clrscr;
     for i:=1 to 10 do begin sound(i*1000);delay(10000);nosound;end;
     textcolor(15);
     write('  nabayad fileha ra dast kari mikardi');readln;
end;
{**************************************************************************}
begin
     assign(f,'hi.dat');
     reset(f);
     readln(f,n);
     o:=0;
     window(1,1,80,25);textbackground(0);clrscr;
     window(20,11,55,13);textbackground(2);clrscr;
     textcolor(14);
     write('  password avaliye ');textcolor(15);write('< asghar kohi >');
     window(21,12,54,12);textbackground(1);clrscr;
     textcolor(4);write(' ');readln(x);

         if length(n)<=5 then asghar;
         if length(x)<=5 then
         if length(n)<=5 then asghar;

     if length(X)>5 then begin
     for i:=1 to length(x) do ax[i]:=x[i];
     for i:=1 to length(n) do az[i]:=chr(ord(n[i])-122);
     for i:=1 to 20 do
     if az[i]=ax[i] then o:=o+1;
     if o=20 then
     begin
     ww;
     a:=1;
repeat
      asle;
      mm;
      c:=readkey;
      if c=#13 then ent;
      if c=#0 then c:=readkey;
      if c=#80 then begin a:=a+1;if a=8 then a:=1;end;
      if c=#72 then begin a:=a-1;if a=0 then a:=7;end;
until b=1;
end;
end;
end.

شرکت آرتا رویان نوین فرداد