{$I KEYS} unit Lib1; interface uses WinTypes; const _SUPERVALUE_ = 3.14159265358e27; _SUPMIN_ = 3.14e27; _SUPMAX_ = 3.15e27; function SelectUniKey_(var s :string; var ms :string) :string; function SelectTimeFromComment(var s :string) :string; function SelectUserFromComment(var s :string) :string; function StripFun(s :string) :string; function RptExt(var s :string) :string; function IsSuperValue(x :double) :boolean; function EqDouble(x,y :double) :boolean; function ISLETTER ( C :char ) :boolean; function AbsDay(d,m,y :integer) :double; procedure AntiAbsDay(da :longint; var d,m,y :integer); procedure ALLOC_CMD(var p :pointer; c :char); procedure FREE_CMD(var p :pointer); function SIZE_CMD(p :pointer) :word; function SIZE_OF_PROG(Prg :pointer) :longint; procedure DELETE_OUTRPT; procedure CREATE_OUTRPT; procedure CLOSE_OUTRPT; procedure SetWindowTextStr(w :HWND; s :string); implementation uses Interna, Opt1, CompUni1, AsgnUnit, Pro1, WinProcs, Strings; function SelectUniKey_(var s :string; var ms :string) :string; label 1; var t :string; i :integer; begin i:=1; t:=''; ms:=''; while (i <= length(s)) and (s[i] <> 'ъ') do inc(i); if i > length(s) then goto 1; inc(i); while (i <= length(s)) and (s[i] <> 'ъ') do inc(i); if i > length(s) then goto 1; inc(i); while (i <= length(s)) and (s[i] <> 'ъ') do inc(i); if i > length(s) then goto 1; inc(i); while i <= length(s) do begin t:=t + s[i]; inc(i) end; ms:=copy(t, 1, 1); t :=copy(t, 2, 255); if length(t) = 7 then if t[1] in ['A'..'Z'] then if t[2] in ['A'..'Z'] then if t[3] in ['A'..'Z'] then if t[4] = '-' then if t[5] in ['0'..'9'] then if t[6] in ['0'..'9'] then if t[7] in ['0'..'9'] then goto 1; t:=''; 1: SelectUniKey_:=t; end; function SelectTimeFromComment(var s :string) :string; label 1; var t :string; i :integer; begin i:=1; t:=''; while (i <= length(s)) and (s[i] <> 'ъ') do inc(i); if i > length(s) then goto 1; inc(i); while (i <= length(s)) and (s[i] <> 'ъ') do inc(i); if i > length(s) then goto 1; inc(i); while (i <= length(s)) and (s[i] <> 'ъ') do begin t:=t + s[i]; inc(i); end; 1: SelectTimeFromComment:=t; end; function SelectUserFromComment(var s :string) :string; label 1; var t :string; i :integer; begin i:=1; t:=''; while (i <= length(s)) and (s[i] <> 'ъ') do inc(i); if i > length(s) then goto 1; inc(i); while (i <= length(s)) and (s[i] <> 'ъ') do begin t:=t + s[i]; inc(i) end; 1: SelectUserFromComment:=t; end; function StripFun(s :string) :string; label 1,2; var i,n :integer; begin n:=1; for i:=length(s) downto 1 do if s[i] <> ' ' then begin n:=i; goto 1; end; 1: s:=copy(s, 1, n); if s = '' then s:=' '; n:=1; for i:=1 to length(s) do if s[i] <> ' ' then begin n:=i; goto 2; end; 2: s:=copy(s, n, 255); StripFun:=s; end; function RptExt(var s :string) :string; label 1,2,3; var t :string[25]; i :integer; begin t:=s; for i:=1 to length(t) do t[i]:=upcase(t[i]); RptExt:=t; for i:=length(t) downto 1 do if t[i] <> ' ' then goto 1; goto 3; 1: if i >= 5 then if t[i ]='T' then if t[i-1]='P' then if t[i-2]='R' then if t[i-3]='.' then goto 3; t:=t+'.RPT'; RptExt:=t; 3: end; function IsSuperValue(x :double) :boolean; begin IsSuperValue:= (x > _SUPMIN_) and (x < _SUPMAX_) end; function EqDouble(x,y :double) :boolean; var xr,yr :real; begin xr:=x; yr:=y; EqDouble:= xr = yr; end; function ISLETTER ( C :char ) :boolean; begin ISLETTER:= Upcase(C) in ['A'..'Z'] end; function AbsDay(d,m,y :integer) :double; const Y0 = 1900; ML :array [1..12] of integer = (31,28,31,30,31,30,31,31,30,31,30,31); var i :integer; S :longint; begin S:=0; for i:=Y0 to y-1 do if i mod 4 = 0 then S:=S+366 else S:=S+365; for i:=1 to m-1 do begin S:=S+ML[i]; if i=2 then if y mod 4 = 0 then S:=S+1 end; S:=S+d-1; AbsDay:=S-33176; end; procedure AntiAbsDay(da :longint; var d,m,y :integer); label 1, 2, EX; var i :integer; begin for i:=1901 to 2100 do if AbsDay(1,1,i) > da then begin y:=i-1; goto 1; end; d:=0; m:=0; y:=0; goto EX; 1: for i:=1 to 12 do if AbsDay(MonthLen(i,y),i,y) >= da then begin m:=i; goto 2; end; d:=0; m:=0; y:=0; goto EX; 2: for i:=1 to 31 do if AbsDay(i,m,y) = da then begin d:=i; goto EX; end; d:=0; m:=0; y:=0; EX: end; procedure ALLOC_CMD(var p :pointer; c :char); var L :word; begin case c of '+','-','*','/','<','>','=','!','i' : L:= 9; 'r' : L:= 9+8; 'v','s' : L:= 9+2; 'f' : L:= 9+3; else L:=sizeof(CMD_TYPE); end; GetMem(p,L); end; procedure FREE_CMD(var p :pointer); var c :char; L :word; begin c:=pCMD_TYPE(p)^.CMD; case c of '+','-','*','/','<','>','=','!','i' : L:= 9; 'r' : L:= 9+8; 'v','s' : L:= 9+2; 'f' : L:= 9+3; else L:=sizeof(CMD_TYPE); end; FreeMem(p,L); end; function SIZE_CMD(p :pointer) :word; var c :char; L :word; begin c:=pCMD_TYPE(p)^.CMD; case c of '+','-','*','/','<','>','=','!','i' : L:= 9; 'r' : L:= 9+8; 'v','s' : L:= 9+2; 'f' : L:= 9+3; else L:=sizeof(CMD_TYPE); end; SIZE_CMD:=L; end; function SIZE_OF_PROG(Prg :pointer) :longint; var OP :char; L :longint; cc :pCMD_TYPE; begin cc:=Prg; L:=0; while cc <> nil do begin OP:=cc^.CMD; L := L + SIZE_CMD(cc); if (OP='p') or (OP='?') then L:=L+cc^.NFUN+2; cc:=cc^.NEXT_CMD; end; SIZE_OF_PROG:=L; end; procedure DELETE_OUTRPT; var i :integer; begin assign(OutRpt,WorkDir(OutRptName)); erase(OutRpt); i:=ioresult; end; procedure CREATE_OUTRPT; begin assign(OutRpt,WorkDir(OutRptName)); rewrite(OutRpt); if ioresult <> 0 then ErrorText:= its_41001 { ' Не могу создать ' } +OutRptName; end; procedure CLOSE_OUTRPT; begin close(OutRpt); if ioresult <> 0 then ErrorText:= its_41002 { ' Не могу закрыть ' } +OutRptName; end; procedure SetWindowTextStr(w :HWND; s :string); var Buf :array [0..128] of char; begin StrPcopy(@Buf, s); SetWindowText(w, @Buf); end; begin end.