{ 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.