Delphi & Pascal (èeská wiki)
{ FAX.PAS Copyright (c) TrSek alias Zdeno Sekerak } { Rutiny pre pracu s faxom. Posielanie objednavok. } { } { Datum:19.06.1995 http://www.trsek.com } function getfax(meno:string):longint; var f:text; s:string; begin assign(f,meno); {$I-} reset(f); {$I+} { Nenasiel cislo subor s poslednym cislom faxu } if ioresult<>0 then begin rewrite(f); writeln(f,'0'); getfax:=0; end else begin readln(f,s); getfax:=vali(s); end; close(f); end; procedure putfax(meno:string;cislo:integer); var f:text; s:string; begin assign(f,meno); rewrite(f); writeln(f,stri(cislo,1)); close(f); end; function vytried(cfax:integer;pfax:string):longint; const meno_sub='zaluzie.dat'; var cis,mcis:integer; err:integer; akt,kolko:longint; s,meno_o:string; i:longint; f:text; fza:file of tzaluz; fza1:file of fzaluz; zaluz:tzaluz; zaluf:fzaluz; bo:boolean; begin if cfax=0 then begin vytried:=0;exit;end; hlaska('Hladam dane formulare pre FAX ',-1); assign(f,pfax+'.$$$'); rewrite(f); opendbase(subor); { vyberie vsetky FAX pre danne cislo } for i:=1 to poc do begin cit_vety(subor,i); if (base[realy_find('ZMAZ')][1]<>'A') then if vali(base[realy_find('FAX')])=cfax then writeln(f,base[realy_find('ZALUZIA')],':',base[realy_find('S')],base[realy_find('SYMC')]); end; writeln(f,'0'); close(f); assign(f,pfax+'.$$$'); reset(f);readln(f,s);close(f); if vali(s)=0 then begin hlaska('Nen jdenì §iaden FAXovì vstup pod >¡slom '+stri(cfax,6)+'.',-1); vytried:=0; exit; end; { Vybera zname zaluzie } hlaska('Selektujem objednan §al£zie ',-1); assign(f,pfax+'.$$$'); reset(f); { zo suboru zaluz.dat } assign(fza,meno_sub); {$I-} reset(fza); err:=ioresult; if err<>0 then begin rewrite(fza); err:=ioresult; end; {$I+} if err<>0 then begin hlaska('Chyba z pisu na disk. Pracovnì disk chr nenì proti z pisu.',0);exit;end; assign(fza1,pfax+'.$$1'); { Vyberie vsetky zaluzie } rewrite(fza1); readln(f,s);kolko:=0; while (not (eof(f)) ) do begin akt:=vali(copy(s,1,pos(':',s)-1));meno_o:=copy(s,pos(':',s)+1,text_obj); repeat seek(fza,akt);read(fza,zaluz); if not((zaluz.sirka=0) and (zaluz.vyska=0)) and not(zaluz.del) then begin with zaluf do begin meno_f:=meno_o;porad:=1;farba:=zaluz.farba; sirka:=zaluz.sirka;vyska:=zaluz.vyska; end; kolko:=kolko+1; seek(fza1,kolko);write(fza1,zaluf); end; akt:=zaluz.zani; until (akt=0); with zaluf do begin meno_f:=meno_o;farba:=nothing(SizeOf(zaluf.farba)); sirka:=0;vyska:=0;porad:=0; end; kolko:=kolko+1; seek(fza1,kolko);write(fza1,zaluf); readln(f,s); bo:=eof(f); end; close(f); prikaz('del '+pfax+'.$$$'); { miesto erase } close(fza1); close(fza); vytried:=kolko; end; procedure zapis_fax(pfax:string); var f:text; i:integer; begin assign(f,pfax); append(f); fzoz:=prvy; for i:=1 to dlzpap do begin writeln(f,fzoz^.text); if i<>dlzpap then fzoz:=fzoz^.zani; end; writeln(f,chr(12)); close(f); fzoz:=prvy; for i:=1 to dlzpap do begin fzoz^.text:=nothing(sirpap); if i<>dlzpap then fzoz:=fzoz^.zani; end; end; procedure fgotoxy(x,y:integer); begin fgx:=x;fgy:=y; end; procedure fwrite(s:string); var i:integer; begin fzoz:=prvy; for i:=2 to fgy do if fzoz^.zani<>NIL then fzoz:=fzoz^.zani; for i:=fgx to fgx+length(s)-1 do if i<=sirpap then fzoz^.text[i]:=s[i-fgx+1]; end; procedure fwriteln(s:string); begin fwrite(s); fgy:=fgy+1; end; procedure hlavicka(x,y,typ_fa:integer); begin case typ_fa of 1: begin fgotoxy(x,y );fwriteln('ÚÄÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÂÄÄÄÄÄ¿'); fgotoxy(x,y+1);fwriteln('³ ç¡rka³ vìçka³ ks³color³'); fgotoxy(x,y+2);fwriteln('ÃÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÅÄÄÄÄÄ´'); end; 2: begin fgotoxy(x,y );fwriteln('ÚÄÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÂÄÄÄÄÄ¿'); fgotoxy(x,y+1);fwriteln('³objed ³ ç¡rka³ vìçka³ ks³color³'); fgotoxy(x,y+2);fwriteln('ÃÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÅÄÄÄÄÄ´'); end; end; fgx:=x; end; procedure paticka(x,y,typ_fa,stred:integer); begin fgotoxy(x,y); if (y+3)>dlzpap then begin if stred in [1,2,3] then stred:=2 else stred:=5; end; case stred of 1:case typ_fa of 1: fwriteln('ÃÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÅÄÄÄÄÄ´'); 2: fwriteln('ÃÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÄÄÄÅÄÄÄÅÄÄÄÄÄ´'); end; 2:case typ_fa of 1: fwriteln('ÀÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÁÄÄÄÄÄÙ'); 2: fwriteln('ÀÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÁÄÄÄÄÄÙ'); end; 3:case typ_fa of 1: fwriteln('ÃÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÁÄÄÄÄÄ´'); 2: fwriteln('ÃÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÁÄÄÄÄÄ´'); end; 4:case typ_fa of 1: fwriteln('ÃÄÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÂÄÄÄÄÄ´'); 2: fwriteln('ÃÄÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÂÄÄÄÄÄ´'); end; 5:case typ_fa of 1: fwriteln('ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ'); 2: fwriteln('ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ'); end; end; end; procedure new_page(cfax,typ_fa,sir:integer;var str:integer;var zavri:boolean;prod:string); begin if zavri then paticka(fgx,fgy,typ_fa,2); fgx:=fgx+sir;fgy:=3;zavri:=false; if fgx+sir>sirpap then begin zapis_fax(prod);fgx:=1;fgy:=1;str:=str+1; fwriteln('FAXovì vìstup >.'+stri(cfax,0)+' objedn vky §al£zi¡. Zo dåa '+get_realy_date(1)+' strana:'+stri(str,0)); fgy:=fgy+1; end; hlavicka(fgx,fgy,typ_fa);zavri:=true; end; procedure fax_text(zdroj,prod:string;cfax,typ_fa:integer); var f:text; fza:file of fzaluz; zaluf:fzaluz; sir,str:integer; i,in_far:integer; meno_o:string; poc:array[0..vcisla] of integer; ploch:array[0..vcisla] of double; in_ploch:array[0..vcisla] of double; in_poc:array[0..vcisla] of integer; zavri:boolean; { pisat paticku a/n } begin case typ_fa of 1: sir:=length('ÀÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÁÄÄÄÄÄÙ')+1; 2: sir:=length('ÀÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÁÄÄÄÄÄÙ')+1; end; fzoz:=NIL; fzoz:=zarad(fzoz^,nothing(sirpap));prvy:=fzoz; fgx:=1;fgy:=1;str:=1;zavri:=true; for i:=2 to dlzpap do fzoz:=zarad(fzoz^,nothing(sirpap)); assign(f,prod); rewrite(f); close(f); assign(fza,zdroj); reset(fza); for i:=0 to vcisla do ploch[i]:=0; for i:=0 to vcisla do poc[i]:=0; for i:=0 to vcisla do in_ploch[i]:=0; for i:=0 to vcisla do in_poc[i]:=0; fwriteln('FAXovì vìstup >.'+stri(cfax,0)+' objedn vky §al£zi¡. Zo dåa '+get_realy_date(1)+' strana:'+stri(str,0)); fgy:=fgy+1;meno_o:=nothing(text_obj); hlavicka(fgx,fgy,typ_fa); read(fza,zaluf);in_far:=vali(zaluf.farba); while ( not (eof(fza)) ) do begin if (fgy+2) > dlzpap then new_page(cfax,typ_fa,sir,str,zavri,prod); fgotoxy(fgx,fgy); case typ_fa of 1: fwrite('³'+strr(zaluf.sirka,6)+'³'+strr(zaluf.vyska,6)+'³'+ stri(zaluf.porad,3)+'³'+strsi(zaluf.farba,farba_sir)+'³'); 2: if meno_o<>zaluf.meno_f then fwrite('³'+zaluf.meno_f+'³'+strr(zaluf.sirka,6)+'³'+strr(zaluf.vyska,6)+'³'+ stri(zaluf.porad,3)+'³'+strsi(zaluf.farba,farba_sir)+'³') else fwrite('³'+nothing(text_obj)+'³'+strr(zaluf.sirka,6)+'³'+strr(zaluf.vyska,6)+'³'+ stri(zaluf.porad,3)+'³'+strsi(zaluf.farba,farba_sir)+'³'); end; inc(fgy);zavri:=true; { Scitavaj podla farieb Ak sirka*vyska<0.5 potom plocha=0.5 } { Oprava 27.3.96 bolo iba 5000 a pri vacsich cislach nad 32000 blbol } { Predpokladal Integer } if ( zaluf.sirka * zaluf.vyska ) < 5000.0 then begin ploch[ in_far ] := ploch[ in_far ] + ( 5000.0 * zaluf.porad ); in_ploch[ in_far ] := in_ploch[ in_far ] + ( 5000.0 * zaluf.porad ); end else begin ploch[ in_far ] := ploch[ in_far ] + zaluf.sirka * zaluf.vyska * zaluf.porad; in_ploch[ in_far ] := in_ploch[ in_far ] + zaluf.sirka * zaluf.vyska * zaluf.porad; end; in_poc[ in_far ] := in_poc[ in_far ] + zaluf.porad; poc[ in_far ] := poc[ in_far ] + zaluf.porad; meno_o:=zaluf.meno_f; read(fza,zaluf);in_far:=vali(zaluf.farba); if meno_o<>zaluf.meno_f then begin { Pre jednu objednavku vypis farby } if zavri then paticka(fgx,fgy,typ_fa,3); zavri:=false; for i:=3 to vcisla do in_ploch[2] := in_ploch[2] + in_ploch[i]; for i:=3 to vcisla do in_poc[2] := in_poc[2] + in_poc[i]; in_ploch[2] := in_ploch[2] + in_ploch[0]; in_poc[2] := in_poc[2] + in_poc[0]; if (fgy+2)>dlzpap then new_page(cfax,typ_fa,sir,str,zavri,prod); case typ_fa of 1: fwriteln('³Col='+strri(in_ploch[2]/10000,7,3)+'m2 po>='+stri(in_poc[2],3)+'ks³'); 2: fwriteln('³ Col='+strri(in_ploch[2]/10000,7,3)+' m2 po>et='+stri(in_poc[2],3)+'ks ³'); end; { Ak je pre farbu 1 } if in_ploch[1]<>0 then case typ_fa of 1: fwriteln('³Al='+strri(in_ploch[1]/10000,7,3)+' m2 po>='+stri(in_poc[1],3)+'ks³'); 2: fwriteln('³ Al='+strri(in_ploch[1]/10000,7,3)+' m2 po>et='+stri(in_poc[1],3)+'ks ³'); end; { Znuluj polia s kumulativnou sumou } for i:=0 to vcisla do in_ploch[i]:=0; for i:=0 to vcisla do in_poc[i]:=0; if fgy+2>=dlzpap then paticka(fgx,fgy,typ_fa,5) else paticka(fgx,fgy,typ_fa,4); zavri:=false; end; end; close(fza); { miesto erase(fza); } prikaz('del '+zdroj); if zavri then begin paticka(fgx,fgy,typ_fa,3); for i:=3 to vcisla do in_ploch[2] := in_ploch[2] + in_ploch[i]; for i:=3 to vcisla do in_poc[2] := in_poc[2] + in_poc[i]; in_ploch[2]:=in_ploch[2]+in_ploch[0]; in_poc[2]:=in_poc[2]+in_poc[0]; case typ_fa of 1: fwriteln('³Col='+strri(in_ploch[2]/10000,7,3)+'m2 po>='+stri(in_poc[2],3)+'ks³'); 2: fwriteln('³ Col='+strri(in_ploch[2]/10000,7,3)+' m2 po>et='+stri(in_poc[2],3)+'ks ³'); end; if in_ploch[1]<>0 then case typ_fa of 1: fwriteln('³Al='+strri(in_ploch[1]/10000,7,3)+' m2 po>='+stri(in_poc[1],3)+'ks³'); 2: fwriteln('³ Al='+strri(in_ploch[1]/10000,7,3)+' m2 po>et='+stri(in_poc[1],3)+'ks ³'); end; if not((fgy+1) > dlzpap) and zavri then paticka(fgx,fgy,typ_fa,5); end; fgotoxy(1,dlzpap); { Nakoniec vypis globalne pre kumulovane sumy farieb } for i:=3 to vcisla do ploch[2] := ploch[2] + ploch[i]; ploch[2]:=ploch[2]+ploch[0]; for i:=3 to vcisla do poc[2] := poc[2] + poc[i]; poc[2]:=poc[2]+poc[0]; fwrite(' Al ='+strri(ploch[1]/10000,7,3)+' m2 po>et='+stri(poc[1],6)+' ks '+ ' Col='+strri(ploch[2]/10000,7,3)+' m2 po>et='+stri(poc[2],6)+' ks '); zapis_fax(prod); fzoz:=prvy; { Vycisti po sebe pamat } repeat fzoz:=vyrad(fzoz^); until (fzoz=NIL); end; function fax(cfax,typ_fa:integer):string; var cis,err:integer; kolko:longint; fza,fza1:file of fzaluz; zaluz,zalu2:fzaluz; pfax:string; prv,dru:longint; f:text; i:word; begin farba(ptlac,ftlac);pfax:='f'+get_realy_date(2); hlaska('',-2); okno(5,10,75,15,' Podmienka ','',ptlac); writeln(' ( BuÔ zad ç existuj£ce >¡slo, alebo 0 vytvor Ôalç¡ z nezaradenìch.) '); writeln(' Zadaj >¡slo faxu : Poslednì mal >¡slo :'+stri(getfax(nfax+'.dat'),6)); if cfax=0 then cfax:=vali('0'+tread(30,3,5,stri(cfax,5),'',#0,#0)); if cfax=0 then begin { Ak je nula tak vytvori novy FAX } cis:=getfax(nfax+'.dat')+1; hlaska('Priradzujem nov, >¡slo FAXu = '+stri(cis,5)+' ',-1); opendbase(subor); i:=0; repeat i:=i+1; cit_vety(subor,i); if vali(base[realy_find('FAX')])=0 then begin base[realy_find('FAX')]:=stri(cis,hlavy[realy_find('FAX')].size); zap_vety(subor,i); end; until (i>=poc); end else cis:=cfax; kolko:=vytried(cis,pfax); { Najdi vsetky pre danny FAX } if kolko=0 then begin {$I-} assign(f,pfax+'.txt'); reset(f); {$I+} if IoResult=0 then prikaz('del '+pfax+'.txt'); exit; end; { Vytriedy zhodne } hlaska('H-ad m, ktor m"§em posp ja? !?! ',-1); assign(fza,pfax+'.$$1'); reset(fza); prv:=1;dru:=1; seek(fza,prv);read(fza,zaluz); repeat dru:=dru+1; seek(fza,dru);read(fza,zalu2); { Nasiel co mu vyhovuje dve zhodne !!! } if (zaluz.sirka=zalu2.sirka) and (zaluz.vyska=zalu2.vyska) and (zaluz.farba=zalu2.farba) and (zaluz.porad<>0) then begin zaluz.porad:=zaluz.porad+1; zalu2.porad:=0; seek(fza,prv);write(fza,zaluz); seek(fza,dru);write(fza,zalu2); end; { Presiel vsetky kontroly } if (vali(zalu2.farba)=0) then begin prv:=prv+1; seek(fza,prv);read(fza,zaluz); while ( (zaluz.farba=nothing( SizeOf(zalu2.farba))) and not(eof(fza)) ) do begin prv:=prv+1; seek(fza,prv);read(fza,zaluz); end; dru:=prv; end; { Je koniec suboru zaluzii } until ( (eof(fza) )); close(fza); { Prefiltruj zaluzie } hlaska('Filtrujem n jdene ... ',-1); assign(fza,pfax+'.$$1'); reset(fza); assign(fza1,pfax+'.$$2'); rewrite(fza1); seek(fza,1); read(fza,zaluz); while ( not (eof(fza)) ) do begin if (zaluz.porad<>0) then write(fza1,zaluz); read(fza,zaluz); end; write(fza1,zaluz); close(fza); { miesto erase(fza);} prikaz('del '+pfax+'.$$1'); close(fza1); { Vytvor textovy subor } hlaska('Vytv ram textov£ zostavu.',40); fax_text(pfax+'.$$2','faxy\'+pfax+'.txt',cis,typ_fa); hlaska('',-2); if getfax(nfax+'.dat')<cis then putfax(nfax+'.dat',cis); view_text('faxy\'+pfax+'.txt',lav_kraj,ftlac,ptlac,prin); end;