{ KNIZNIC.PAS Copyright (c) TrSek alias Zdeno Sekerak } { Rutiny pre jednoduchsiu pracu s oknami a retazcami. } { } { Datum:19.06.1995 http://www.trsek.com } unit kniznic; interface uses dos,crt; const map_mes:array[1..12] of integer = (0,31,59,90,120,151,181,212,243,273,304,334); var xw1,yw1,xw2,yw2:integer; z_sound:boolean; { zapnuty/vypnuty zvuk pre hlasku } procedure twindow(x1,y1,x2,y2:integer); procedure owindow(x1,y1,x2,y2:integer); procedure okno(x1, y1, x2, y2:integer; text,podpis:string; bar:integer); procedure vypln(s:string); procedure hlaska(s:string;del:integer); function vali(s:string):longint; function valr(s:string):real; function stri(i:longint;k:integer):string; function strr(i:real;k:integer):string; function strri(i:real;k:integer;p:integer):string; function strs(s:string;medzera:boolean):string; function strsi(s:string;p:integer):string; function nothing(i:integer):string; procedure prikaz(s:string); function ask_date(s:string):string; function poc_dni(s:string):LongInt; function get_date(pp:LongInt):string; function get_realy_date(typ:integer):string; function s_exist(s:string;velk:integer):boolean; procedure z_hlava(var strana,poc_y:integer;var f:text;aky_text:string); implementation procedure twindow(x1,y1,x2,y2:integer); begin window(x1,y1,x2,y2); end; procedure owindow(x1,y1,x2,y2:integer); begin twindow(x1,y1,x2,y2); xw1:=x1;yw1:=y1;xw2:=x2;yw2:=y2; end; procedure okno(x1, y1, x2, y2:integer; text,podpis:string; bar:integer); var x,y:integer; begin owindow(x1+1,y1+1,x2-1,y2-1); textbackground(bar); clrscr; owindow(1,1,80,25); for x:=x1+1 to x2-1 do begin gotoxy(x,y1);write('Ä'); gotoxy(x,y2);write('Ä'); end; for y:=y1+1 to y2-1 do begin gotoxy(x1,y);write('³'); gotoxy(x2,y);write('³'); end; gotoxy(x1,y1);write('Ú'); gotoxy(x2,y1);write('¿'); gotoxy(x1,y2);write('À'); gotoxy(x2,y2);write('Ù'); textbackground(bar); gotoxy(x1+round((x2-x1-length(text))/2),y1);write(text); gotoxy(x2-length(podpis)-2,y2);write(podpis); owindow(x1+1,y1+1,x2-1,y2-1); end; procedure vypln(s:string); var i:integer; begin owindow(xw1+3,yw1+1,xw2-3,yw2-1); textbackground(BLUE);textcolor(LIGHTGRAY); gotoxy(1,1); for i:=1 to round(((xw2-xw1)*(yw2-yw1+2)+18)/length(s)) do write(s); textcolor(YELLOW); end; procedure hlaska(s:string;del:integer); var i:integer; odloz:array[1..2,1..80] of byte; reg:registers; xo1,yo1,xo2,yo2:integer; begin xo1:=xw1;yo1:=yw1;xo2:=xw2;yo2:=yw2; owindow(1,1,80,25); textbackground(DARKGRAY); for i:=1 to length(s) do begin gotoxy(xw1+i,25); reg.ah:=8; reg.bh:=0; intr($10,reg); odloz[1,i]:=reg.ah; odloz[2,i]:=reg.al; end; gotoxy(xw1+1,25); if del=-2 then write(nothing(78)) else write(s); if z_sound then begin sound(500);delay(3);nosound;end; if del=-1 then begin owindow(xo1,yo1,xo2,yo2); exit; end; if del=0 then repeat until keypressed else delay(abs(del)*10); for i:=1 to length(s) do begin gotoxy(xw1+i,25); reg.ah:=$9; reg.bh:=0; reg.al:=odloz[2,i]; reg.bl:=odloz[1,i]; reg.cx:=1; intr($10,reg); end; owindow(xo1,yo1,xo2,yo2); end; function vali(s:string):longint; var vys:longint; err:integer; begin if length(s)<2 then s:='0'+s; { Len aby !!! } while (pos(' ',s)>0) do delete(s,pos(' ',s),1); val(s,vys,err); while ( (err<>0) and (s<>'') ) do begin delete(s,err,1); val(s,vys,err); end; vali:=vys; end; function valr(s:string):real; var err:integer; vys:real; begin while (pos(' ',s)>0) do delete(s,pos(' ',s),1); val(s,vys,err); while ( (err<>0) and (s<>'') )do begin delete(s,err,1); val(s,vys,err); end; valr:=vys; end; function stri(i:longint;k:integer):string; var s:string; begin str(i:k,s); stri:=s; end; function strr(i:real;k:integer):string; var s:string; begin str(i:k:2,s); strr:=s; end; function strri(i:real;k:integer;p:integer):string; var s:string; begin str(i:k:p,s); strri:=s; end; function strs(s:string;medzera:boolean):string; var i:integer; sp:string; begin sp:='';i:=1; if medzera then while ( (s[i] in [' '..'z']) and (i<=length(s)) ) do begin sp:=sp+s[i]; i:=i+1; end else while ( (s[i] in ['!'..'z']) and (i<=length(s)) ) do begin sp:=sp+s[i]; i:=i+1; end; strs:=sp; end; function strsi(s:string;p:integer):string; var i:integer; sp:string; begin sp:='';i:=1; while ( (s[i] in [' '..'þ']) and (i<=length(s)) ) do begin sp:=sp+s[i]; i:=i+1; end; while ( (pos(' ',sp)>0) and (length(sp)>0) ) do delete(sp,pos(' ',sp),1); strsi:=nothing(p-length(sp))+copy(sp,1,p); end; function nothing(i:integer):string; begin nothing:=copy(' ',1,i); end; procedure prikaz(s:string); begin SwapVectors; Exec(GetEnv('COMSPEC'), '/C '+s); SwapVectors; if doserror<>0 then hlaska(' Chyba '+stri(doserror,0)+' ',0); end; function ask_date(s:string):string; begin ask_date:=s[7]+s[8]+'.'+s[5]+s[6]+'.'+copy(s,1,4); end; function poc_dni(s:string):LongInt; var p:LongInt; r,m,d:integer; begin r:=vali(copy(s,1,4));m:=vali(s[5]+s[6]);d:=vali(s[7]+s[8]); poc_dni:=LongInt(r)*365+map_mes[m]+d; end; function get_date(pp:LongInt):string; var r,m,d:integer; i:integer; s:string; begin r:=trunc(pp/365); d:=pp-r*365; i:=1; while ( (map_mes[i]<=d) and (i<=12) ) do i:=i+1; m:=i-1; d:=d-map_mes[m]+1; s:=stri(r,4); if m<10 then s:=s+'0'+stri(m,1) else s:=s+stri(m,2); if d<10 then s:=s+'0'+stri(d,1) else s:=s+stri(d,2); get_date:=s; end; function get_realy_date(typ:integer):string; const days : array [0..6] of String[8] = ('Nede-a','Pondelok','Utorok', 'Streda','ætvrtok','Piatok','Sobota'); var y, m, d, dow : Word; s,c:string; begin GetDate(y,m,d,dow); if typ=1 then get_realy_date:= days[dow]+' '+stri(d,0)+ '/'+ stri(m,0)+ '/'+ stri(y,0) else begin c:= copy(stri(y,4),3,2); s:= stri(m,0); if length(s)<2 then s:='0'+s; c:=c+s; s:= stri(d,0); if length(s)<2 then s:='0'+s; c:=c+s; get_realy_date:=c; end; end; function s_exist(s:string;velk:integer):boolean; var s_find:SearchRec; begin FindFirst(s,Archive,s_find); if velk=1 then begin if (DosError=0) and (s_find.size<>0) then s_exist:=true else s_exist:=false; end else begin if (DosError=0) then s_exist:=true else s_exist:=false; end end; procedure z_hlava(var strana,poc_y:integer;var f:text;aky_text:string); var err:integer; begin append(f); err:=ioresult; {$I+} if err<>0 then begin hlaska('Chyba z pisu na disk. Pracovnì disk chr nenì proti z pisu.',0);exit;end; if strana<>0 then writeln(f,chr(12)); poc_y:=2;inc(strana); writeln(f,aky_text+' Zo dåa '+get_realy_date(1)+' strana:'+stri(strana,0)); writeln(f,''); end; end.