V skratke povedané je to telefónny zoznam s jednoduchým textovým menu, no zato má rozne funkcie ako vyhľadávanie, mazanie položiek, vkladanie a kopírovanie

{ GLOBAL_PHONE.PAS                                                  }
{ V skratke povedane je to tel. zoznam s jednoduchym textovym menu, }
{ no zato ma rozne funkcie ako vyhladavanie, mazanie poloziek,      }
{ vkladanie a kopirovanie...                                        }
{                                                                   }
{ Author: Unknown                                                   }
{ Datum: 23.02.2009                            http://www.trsek.com }
 
Program Global_Phone_Devastator;
uses  crt , dos;
type TZaznam = packed record
               Polozka_cislo     : Integer;
               Meno              : String[20];
               Priezvisko        : String[20];
               Cislo_Mobil       : String[14];
               Cislo_Pevna       : String[10];
               Mesto             : String[20];
               Cislo_domu        : String[25];
               EMail             : String[30];
               PSC               : String[7];
     end;
var Subor1                       : file of TZaznam;
    Subor2                       : File of Tzaznam;
    Nazov_Zoznamu                : string;
    Nazov_Zoznamu2               : string;
    hodnota , volba_menu         : char;
    Zaznam                       : TZaznam;
 
 Procedure Vytvor_Zoznam(var Nazov : string);
  begin
   write('Zadaj nazov zoznamu : ');
   readln(Nazov);
   assign(Subor1 , Nazov);
   rewrite(Subor1);
   close(Subor1);
  end;
 
 Procedure Zrus_Zoznam(var Nazov : string);
  begin
   write('Zadaj nazov zoznamu na vymazanie : ');
   readln(Nazov);
   assign(Subor1 , Nazov);
   {$I-}
   reset(Subor1);
   {$I+}
   if IOResult <> 0 then
    begin
     writeln('Subor neexistuje...');
     readkey;
     end;
   {$I-};
   erase(Subor1);
   {$I+};
   if IOResult <> 0
    then
     begin
      writeln('Subor nebol zmazany...');
      readkey;
      exit;
     end
    else
     begin
      writeln('Subor bol zmazany...');
      readkey;
      exit;
     end;
 end;
 
 Procedure Pridaj_Polozku(var Nazov : String);
  var pom , pom2 , i   : integer;
      znak             : char;
  begin
   write('Zadaj nazov zoznamu na otvorenie : ');
   readln(Nazov);
   assign(Subor1 , Nazov);
   {$I-}
   reset(Subor1);
   {$I+}
    if IOResult <> 0 then
     begin
      writeln('Subor neexistuje...');
      readkey;
      exit;
     end
    else
     begin
      pom := filesize(Subor1) + 1;
      write('Zadaj meno : ');
      readln(Zaznam.meno);
       if Zaznam.meno = '' then
          Zaznam.meno := 'Neuvedene';
      write('Zadaj priezvisko : ');
      readln(Zaznam.priezvisko);
       if Zaznam.priezvisko = '' then
          Zaznam.priezvisko := 'Neuvedene';
      write('Zadaj cislo mobilu : ');
      readln(Zaznam.Cislo_Mobil);
       if Zaznam.Cislo_Mobil = '' then
          Zaznam.Cislo_Mobil := 'Neuvedene';
      write('Zadaj cislo pevnej linky : ');
      readln(Zaznam.Cislo_Pevna);
       if Zaznam.Cislo_Pevna = '' then
          Zaznam.Cislo_Pevna := 'Neuvedene';
      write('Zadaj meno mesta : ');
      readln(Zaznam.Mesto);
       if Zaznam.Mesto = '' then
          Zaznam.Mesto := 'Neuvedene';
      write('Zadaj cislo domu : ');
      readln(Zaznam.Cislo_domu);
       if Zaznam.Cislo_domu = '' then 
          Zaznam.Cislo_domu := 'Neuvedene';
      write('Zadaj E-Mail : ');
      readln(Zaznam.EMail);
       if Zaznam.EMail = '' then 
          Zaznam.EMail := 'Neuvedene';
      write('Zadaj PSC : ');
      readln(Zaznam.PSC);
       if Zaznam.PSC = '' then
          Zaznam.PSC := 'Neuvedene';
      Zaznam.Polozka_cislo := pom;
       seek(Subor1 , Filesize(Subor1));
       write(Subor1 , Zaznam);
     close(Subor1);
    end;
   end;
 
 Procedure Zrus_Polozku(var Nazov : string);
  var pom , pom2 , pom3 : integer;
  begin
   write('Zadaj nazov zoznamu : ');
   readln(Nazov);
   assign(Subor1 , Nazov);
   {$I-};
   reset(Subor1);
   {$I+};
   if IOResult <> 0 then
     begin
      writeln('Subor neexistuje...');
      readkey;
      exit;
     end;
    if filesize(Subor1) = 0 then
     begin
      writeln('Subor je prazdny...');
      readkey;
      close(Subor1);
      exit;
     end;
   while not Eof(Subor1) do
    begin
     clrscr;
     textcolor(red);
     writeln('Prehlad zaznamov na vymaznie : ');
     textcolor(white);
     read(Subor1 , Zaznam);
     writeln('Zaznam cislo             : ', Zaznam.Polozka_cislo);
     writeln('Meno                     : ', Zaznam.meno);
     writeln('Priezvisko               : ', Zaznam.Priezvisko);
     writeln('Cislo mobilneho telefonu : ', Zaznam.Cislo_Mobil);
     writeln('Cislo pevnej linky       : ', Zaznam.Cislo_Pevna);
     writeln('Nazov mesta              : ', Zaznam.Mesto);
     writeln('Cislo domu               : ', Zaznam.Cislo_Domu);
     writeln('E-Mail                   : ', Zaznam.EMail);
     writeln('PSC                      : ', Zaznam.PSC);
     readkey;
    end;
   pom2 := filesize(Subor1);
   write('Zadaj cislo polozky na vymazanie : ');
   readln(pom);
   if pom > pom2 then
    begin
     writeln('Bolo zadane vacsie cislo ako poloziek v subore...');
     readkey;
     close(Subor1);
     exit;
    end;
   if pom = pom2 then
    begin
     seek(Subor1 , pom2 - 1);
     truncate(Subor1);
    end;
   if pom < filesize(Subor1) then
    begin
     seek(Subor1 , pom2 - 1);
     read(Subor1 , Zaznam);
     seek(Subor1 , pom - 1);
     Zaznam.Polozka_cislo := pom;
     write(Subor1 , Zaznam);
     seek(Subor1 , pom2 - 1);
     truncate(Subor1);
    end;
    close(Subor1);
   end;
 procedure Vypis_Zoznam(var Nazov : string);
  begin
   write('Zadaj nazov zoznamu : ');
   readln(Nazov);
   assign(Subor1 , Nazov);
   {$I-};
   reset(Subor1);
   {$I+};
   if IOResult <> 0 then
    begin
     writeln('Subor neexistuje...');
     readkey;
     exit;
    end
    else
     begin
      if filesize(Subor1) = 0 then
       begin
        writeln('Zaznam neobsakuje ziadne polozky...');
        readkey;
        close(Subor1);
        exit;
       end;
      while not Eof(Subor1) do
       begin
        clrscr;
        textcolor(red);
        writeln('Prehlad zoznamu : ');
        textcolor(white);
        read(Subor1 , Zaznam);
        writeln('Zaznam cislo             : ', Zaznam.Polozka_cislo);
        writeln('Meno                     : ', Zaznam.meno);
        writeln('Priezvisko               : ', Zaznam.Priezvisko);
        writeln('Cislo mobilneho telefonu : ', Zaznam.Cislo_Mobil);
        writeln('Cislo pevnej linky       : ', Zaznam.Cislo_Pevna);
        writeln('Nazov mesta              : ', Zaznam.Mesto);
        writeln('Cislo domu               : ', Zaznam.Cislo_Domu);
        writeln('E-Mail                   : ', Zaznam.EMail);
        writeln('PSC                      : ', Zaznam.PSC);
        textcolor(Red);
        writeln('Celkovy pocet zaznamov   : ', Filesize(Subor1));
        textcolor(White);
        readkey;
       end;
    end;
    Zaznam.Polozka_cislo := 0;
   close(Subor1);
  end;
 
 Procedure Najdi_Zaznam(var Nazov : string);
  var Hladane : string;
      i       : integer;
  begin
   i := 0;
   write('Zadaj zoznam v ktorom sa bude vyhladavat : ');
   readln(Nazov);
   write('Zadaj hladane priezvisko : ');
   readln(Hladane);
   assign(Subor1 , Nazov);
   {$I-}
   reset(Subor1);
   {$I+}
    if IOResult <> 0  then
     begin
      writeln('Subor neexistuje...');
      readkey;
      exit;
     end
    else
     begin
      while not EOF(Subor1) do
          begin
           read(Subor1 , Zaznam);
           if hladane = Zaznam.Priezvisko then
            begin
             clrscr;
             i:=i+1;
             writeln('Zaznam cislo             : ', Zaznam.Polozka_cislo);
             writeln('Meno                     : ', Zaznam.meno);
             writeln('Priezvisko               : ', Zaznam.Priezvisko);
             writeln('Cislo mobilneho telefonu : ', Zaznam.Cislo_Mobil);
             writeln('Cislo pevnej linky       : ', Zaznam.Cislo_Pevna);
             writeln('Nazov mesta              : ', Zaznam.Mesto);
             writeln('Cislo domu               : ', Zaznam.Cislo_Domu);
             writeln('E-Mail                   : ', Zaznam.EMail);
             writeln('PSC                      : ', Zaznam.PSC);
             readkey;
            end;
          end;
      writeln('Najdene polozky celkovo : ', i);
     readkey;
    end;
   close(Subor1);
  end;
 
 Procedure Presun_Na_Poziciu(Nazov : String);
  var pozicia , pom : integer;
  begin
   write('Zadaj zoznam na otvorenie : ');
   readln(Nazov);
   write('Zadaj od ktorej pozicie chces vypisat zoznam : ');
   readln(pozicia);
   assign(Subor1 , Nazov);
   {$I-};
   reset(Subor1);
   {$I+};
    if IOResult <> 0 then
     begin
      writeln('Subor neexistuje...');
      readkey;
      exit;
     end;
   pom := filesize(Subor1);
   seek(Subor1 , pozicia - 1);
   if pozicia > pom then
    begin
     writeln('Zaznam ma len ' , pom , ' poloziek...');
     readkey;
     close(Subor1);
     exit;
    end;
    repeat
     read(Subor1 , Zaznam);
       begin
        clrscr;
        writeln('Zaznam cislo             : ', Zaznam.Polozka_cislo);
        writeln('Meno                     : ', Zaznam.meno);
        writeln('Priezvisko               : ', Zaznam.Priezvisko);
        writeln('Cislo mobilneho telefonu : ', Zaznam.Cislo_Mobil);
        writeln('Cislo pevnej linky       : ', Zaznam.Cislo_Pevna);
        writeln('Nazov mesta              : ', Zaznam.Mesto);
        writeln('Cislo domu               : ', Zaznam.Cislo_Domu);
        writeln('E-Mail                   : ', Zaznam.EMail);
        writeln('PSC                      : ', Zaznam.PSC);
        readkey;
       end;
    until eof(Subor1);
    close(Subor1);
  end;
 
 Procedure Vycisti_Zoznam(var Nazov : string);
  begin
   write('Zadaj nazov suboru na vycistenie : ');
   readln(Nazov);
   assign(Subor1 , Nazov);
   {$I-};
   reset(Subor1);
   {$I+};
    if IOResult <> 0 then
     begin
      writeln('Subor neexistuje...');
      readkey;
      exit;
     end;
    writeln('Zaznam obsahoval  ' , Filesize(Subor1) , ' poloziek...');
     repeat
      truncate(Subor1);
     until filesize(Subor1) = 0;
    readkey;
   close(Subor1);
  end;
 
 Procedure Vycisti_Zoznam_POZICIA(var Nazov : string);
  var pozicia : integer;
      pom     : integer;
  begin
   write('Zadaj nazov suboru na vycistenie : ');
   readln(Nazov);
   write('Zadaj od ktorej pozicie sa ma zaznam zmazat : ');
   readln(Pozicia);
   assign(Subor1 , Nazov);
   {$I-};
   reset(Subor1);
   {$I+};
    if IOResult <> 0 then
     begin
      writeln('Subor neexistuje...');
      readkey;
      exit;
     end;
    if Pozicia > filesize(Subor1) then
     begin
      writeln('Zaznam neobsahuje tolko poloziek...');
      readkey;
      close(Subor1);
      exit;
     end;
 
    writeln('Zaznam obsahoval  ' , Filesize(Subor1) , ' poloziek...');
     repeat
      begin
       seek(Subor1 , pozicia - 1);
       truncate(Subor1);
       pom := filesize(Subor1);
      end;
     until pom = Pozicia - 1;
    writeln('Teraz zaznam obsahuje ' , Filesize(Subor1) , ' poloziek...');
    readkey;
   close(Subor1);
  end;
 
 Procedure Kopirovanie_Zaznamu(var Nazov , Nazov2 : string);
  var pom , i : integer;
  begin
   writeln('Nazov zoznamu na nacitanie poloziek : ');
   readln(Nazov);
   writeln('Nazov 2. zoznamu na zapisanie poloziek : ');
   readln(Nazov2);
   if Nazov = Nazov2 then
     begin
      writeln('Bol zadany 2X ten isty subor...');
      readkey;
      exit;
     end;
   assign(Subor1 , Nazov);
   assign(Subor2 , Nazov2);
   {$I-};
   reset(Subor1);
   {$I+};
    if IOResult <> 0 then
     begin
      writeln('Subor 1 neexistuje...');
     end;
    {$I-}
    reset(Subor2);
    {$I+}
     if IOResult <> 0 then
     begin
      writeln('Subor 2 neexistuje...');
      readkey;
      close(Subor1);
      exit;
     end;
   while not EOF(Subor1) do
    begin
     seek(Subor2 , filesize(Subor2));
     read(Subor1 , Zaznam);
     Zaznam.polozka_Cislo := filesize(Subor2) + 1;
     write(Subor2 , Zaznam);
     If eof(Subor1) then
      begin
       writeln('Kopirovanie skoncilo...');
       readkey;
      end;
    end;
  close(Subor1);
  close(Subor2);
 end;
 Procedure Kopirovanie_Poloziek(var Nazov , Nazov2 : string);
  var Pozicia : integer;
  begin
   writeln('Nazov zoznamu na nacitanie polozky : ');
   readln(Nazov);
   writeln('Nazov 2. zoznamu na zapisanie polozky : ');
   readln(Nazov2);
   if Nazov = Nazov2 then
     begin
      writeln('Bol zadany 2X ten isty subor...');
      readkey;
      exit;
     end;
   assign(Subor1 , Nazov);
   assign(Subor2 , Nazov2);
   {$I-};
   reset(Subor1);
   {$I+};
    if IOResult <> 0 then
     begin
      writeln('Subor 1 neexistuje...');
     end;
    {$I-}
    reset(Subor2);
    {$I+}
     if IOResult <> 0 then
     begin
      writeln('Subor 2 neexistuje...');
      readkey;
      exit;
     end;
     write('Zadaj poziciu zaznamu v zozname na skopirovanie :');
     readln(Pozicia);
     if pozicia > filesize(Subor1) then
      begin
       writeln('Bolo zadane vacsie cislo ako je pocet poloziek v zazname...');
       readkey;
       close(Subor1);
       close(Subor2);
       exit;
      end;
     seek(Subor1 , Pozicia - 1);
     read(Subor1 , Zaznam);
     Zaznam.polozka_Cislo := filesize(Subor2) + 1;
     seek(Subor2 , filesize(Subor2));
     write(Subor2 , Zaznam);
  close(Subor1);
  close(Subor2);
 end;
begin
 textcolor(white);
 repeat
 clrscr;
  writeln('Pre vytvorenie noveho zoznamu stlac..........."V"');
  writeln('Pre ukoncenie programu stlac.................."K"');
  writeln('Pre vymazanie zoznamu stlac..................."D"');
  writeln('Pre pridanie polozky stlac...................."P"');
  writeln('Pre zrusenie polozky stlac...................."Z"');
  writeln('Pre vypisanie zoznamu stlac..................."J"');
  writeln('Pre hladanie kontaktu stlac..................."F"');
  writeln('Pre vypis kontaktov od pozicie stlac.........."C"');
  writeln('Pre vycistenie zoznamu stlac.................."B"');
  writeln('Pre vycistenie zaznamu od pozicie stlac......."I"');
  writeln('Pre skopirovanie zoznamu stlac................"L"');
  writeln('Pre skopirovanie poloziek stlac..............."O"');
   repeat volba_menu:=upcase(readkey);
   until  volba_menu in ['V' , 'K' , 'D' , 'P' , 'Z' , 'J' ,
                         'F' , 'C' , 'B' , 'I' , 'L' , 'O'];
   clrscr;
   case volba_menu of
    'V': Vytvor_Zoznam(Nazov_Zoznamu);
    'D': Zrus_Zoznam(Nazov_Zoznamu);
    'K': exit;
    'P': Pridaj_Polozku(Nazov_Zoznamu);
    'Z': Zrus_Polozku(Nazov_Zoznamu);
    'J': Vypis_Zoznam(Nazov_Zoznamu);
    'F': Najdi_Zaznam(Nazov_Zoznamu);
    'C': Presun_Na_Poziciu(Nazov_Zoznamu);
    'B': Vycisti_Zoznam(Nazov_Zoznamu);
    'I': Vycisti_Zoznam_POZICIA(Nazov_Zoznamu);
    'L': Kopirovanie_Zaznamu(Nazov_Zoznamu , Nazov_Zoznamu2);
    'O': Kopirovanie_Poloziek(Nazov_Zoznamu , Nazov_Zoznamu2);
   end;
 until volba_menu='K';
end.