Power-Programmierung/CD1.mdf/pascal/library/dos/database/designer/ibmlib1.inc

Text File | 1991-05-13 | 17.5 KB | 724 lines

procedure cls;
begin
   gotoxy(1,1);
   clrscr
end;

procedure setcurs(n:Integer);
{ Set cursor size to n scan lines }
Type
   String80 = String[80];

var
   regs : registers;

begin
   if not (n in [1..7]) then
   n := 6;                { One scan line if out of bounds }
   regs.ah := 1;          { Set cursor size }
   regs.ch := 7-n;        { Top scan line   }
   regs.cl := 7;          { Bottom scan line }
   intr($10,regs);        { Call video I/O  }
end;

Procedure Beep;
   Begin
      Write(chr(7))
   end; { Beep }

Function Yes : Boolean;
   Const
      YesNo : Set of Char = ['Y','y','N','n'];

   Var
      C : Char;
      Ok, Ans : Boolean;

   Begin
      Repeat
         C := ReadKey;
         Ok := (C in YesNo);
         If Not OK then Beep;
      Until OK;
      Ans := (UpCase(C) = 'Y');
      if Ans then write('Y') else
      write('N');
      Yes := Ans;
   end; { Yes }

Function YYes : Boolean;
{ Gets Yes/No answer while keeping up clock }
   Const
      YesNo : Set of Char = ['Y','y','N','n'];

   Var
      C : Char;
      Ok, Ans : Boolean;

   Begin
      Repeat
         C := ReadKey;
         Ok := (C in YesNo);
         If Not OK then Beep;
      Until OK;
      Ans := (UpCase(C) = 'Y');
      YYes := Ans;
   end; { Yes }

{ -------------------------------------------------------- }
Function Spaces(n:Integer):String80;
var
   i : Integer;
   Sp : String80;
begin
   sp := '';
   for i := 1 to n do
      sp := concat(sp,#32);
   Spaces := sp
end;

function blank(str:String80):boolean;
var
   i : Integer;
   temp : boolean;

begin
   temp := true;
   for i := 1 to length(str) do
   if str[i] <> #32 then temp := false;
   blank := temp
end;

{ ----------------------------------------------------- }
procedure fwrite(col,row,attrib:byte;str:String80);
{ Write directily to video memory }
begin
inline
($1E/$1E/$8A/$86/row/$B3/$50/$F6/$E3/$2B/$DB/$8A/$9E/col/
 $03/$C3/$03/$C0/$8B/$F8/$be/$00/$00/$8A/$BE/attrib/
 $8a/$8e/str/$22/$c9/$74/$3e/$2b/$c0/$8E/$D8/$A0/$49/$04/
 $1F/$2C/$07/$74/$22/$BA/$00/$B8/$8E/$DA/$BA/$DA/$03/$46/
 $8a/$9A/str/$EC/$A8/$01/$75/$FB/$FA/$EC/$A8/$01/$74/$FB/
 $89/$1D/$47/$47/$E2/$Ea/$2A/$C0/$74/$10/$BA/$00/$B0/
 $8E/$DA/$46/$8a/$9A/str/$89/$1D/$47/$47/$E2/$F5/$1F);
end;

procedure time(var line:String15; var AmPm:String5);
var
   register : Registers;
   Hour,Min,Sec,Hun : Integer;
   hours, minutes, seconds : String[5];
begin
   register.AX := $2C00;
   MsDos(Register);
   With Register do
      begin
         Hour := Cx shr 8;
         Min  := Cx and $00FF;
         Sec  := Dx shr 8;
         Hun  := Dx and $00FF;
      end;
      if hour > 11 then
      ampm := ' PM' else
      ampm := ' AM';

      if hour > 12 then
         hour := hour - 12;
      str(hour:2,hours);
      if hours[1] = #32 then hours[1] := '0';
      if hours = '00' then hours := '12';
      str(min:2,minutes);
      if minutes[1] = #32 then minutes[1] := '0';
      str(sec:2,seconds);
      if seconds[1] = #32 then seconds[1] := '0';

   line := Hours+':'+Minutes+':'+Seconds;
end;
{ -------------------------------------------------------- }
Procedure Date(var line:String15);
Type
   Str9 = String[9];

Const
   Dates : Array[1..7] of str9 = ('Sunday','Monday','Tuesday','Wednesday',
                                    'Thursday','Friday','Saturday');
Var
   Regs : Registers;
   DayNum,Month,Day,Year : Integer;
   MStr,DStr,YStr : String[2];
Begin
   Regs.Ax := $2A00;
   MsDos(Regs);
   DayNum := (Regs.Ax and $00FF) + 1;
   Month  := Regs.Dx shr 8;
   Day    := Regs.Dx and $00FF;
   Year   := Regs.Cx - $76C; { Subtract 1900 so we get a two digit year }
   str(month:2,mstr);
   str(day:2,dstr);
   str(year:2,ystr);
   if mstr[1] = #32 then mstr[1] := '0';
   if dstr[1] = #32 then dstr[1] := '0';
   if ystr[1] = #32 then dstr[1] := '0';
   line := mstr+'/'+dstr+'/'+ystr+'.'
end;

procedure display_datetime;
begin
   date(The_Date);
   time(The_Time,AmPm);
   fwrite(50,2,lbg*16+lfg,The_Date+' - '+The_Time+AmPm)
end;

procedure clock;
begin
   if not clockon then exit;
   while not keypressed do
   begin
      temp := temptime;
      time(temptime,AmPm);
      if temp <> temptime then
      display_datetime
   end;
end;

{ -------------------------------------------------------- }
Function Color_Monitor: Boolean;
const
   ZeroSeg     = $0000;
   ConfigWorld = $0410;
var
   Flag : byte;
   Ch   : char;
begin
   Flag := (Mem [ZeroSeg:ConfigWorld])
            and $30;
   if Flag = $20 then
      Color_Monitor := true
   else if Flag = $30 then
      Color_Monitor := false
   else
   begin
      Make_Window(10,10,70,15,f,b,True);
      writeln('I can`t determine what kind of monitor you have.');
      writeln('The default will be Monochrome.');
      Color_Monitor := false;
      writeln;
      writeln('Press any key...');
      Ch := ReadKey;
      Remove_Window
   end;
end;

{ -------------------------------------------------------- }
function Strings(n:Integer;ch:char):String80;
{ Emulate the BASIC STRING$ function }
var
   i : Integer;
   temp : String80;
begin
   temp := '';
   for i := 1 to n do
   temp := concat(temp,ch);
   Strings := temp
end;


procedure GetIntVal(Var Value:Integer; xpos,ypos:Integer;
          var up,q:boolean);
{ Do error checking on Integer number input }
var
   tempString, tempval : String10;
   code : Integer;
begin
      str(value,tempval);
      gotoxy(xpos,ypos);
      repeat
      tempString := '';
      EditLine(TempString,8,WhereX,WhereY,LegalChars,Term,Tc);
      Up := Tc = UpKey;
      q  := Tc = Esc;
      if tempString = '' then exit;
      val(tempString,value,code);
      if code > 0 then
         begin
            write(#7);
            Make_Window(20,9,60,12,f,black,True);
            write('Integer number expected.');
            delay(1000);
            Remove_Window;
            gotoxy(xpos,ypos);
            write('     ');
            gotoxy(xpos,ypos);
         end;
      until code = 0
end;

{ -------------------------------------------------------- }
procedure GetRealVal(Var Value:real; xpos,ypos:Integer;
                     Var up,q:boolean);
{ Do error checking on real number input }
var
   tempString, tempval : String10;
   code : Integer;

begin
      up := false;
      q  := false;
      str(value,tempval);
      gotoxy(xpos,ypos);
      repeat
      EditLine(tempString,8,wherex,wherey,LegalChars,Term,Tc);
      Up := Tc = UpKey;
      q  := Tc = Esc;
      val(tempString,value,code);
      if code > 0 then
         begin
            write(#7);
            Make_Window(20,9,60,12,f,b,True);
            write('Real number expected.');
            delay(1000);
            Remove_Window;
            gotoxy(xpos,ypos);
            write('     ');
            gotoxy(xpos,ypos);
         end;
      until code = 0
end;

function Exist(Filename:String80):boolean;
VAR infile:text;

Begin                        { Find out if the file exists }
   Assign(Infile,Filename);
   {$I-}
   Reset(infile);
   close(infile);
   {$I+}
   Exist := (IOresult = 0);
end;


function uppercase(progname:String80): String80;
{ Convert a String to upper case }
var
   i : Integer;
begin
   for i := 1 to length(progname) do
      progname[i] := upcase(progname[i]);
   uppercase := progname
end;

Procedure Exec(s : String80);
{ Execute DOS command or Program }
Var
   save_ax : Integer;
Const
   save_ss : Integer = 0;
   save_sp : Integer = 0;
BEGIN
    s[Length(s)+1] := ^M;
    INLINE(
      $1E/                    {   push    ds                   }
      $55/                    {   push    bp                   }
      $2E/$8C/$16/save_ss/    {   mov     cs:[save_ss],ss      }
      $2E/$89/$26/save_sp/    {   mov     cs:[save_sp],sp      }
      $8C/$D0/                {   mov     ax,ss                }
      $8E/$D8/                {   mov     ds,ax                }
      $8D/$76/<s/             {   lea     si,s[bp]             }
      $CD/$2E/                {   int     2eh                  }
      $2E/$8E/$16/save_ss/    {   mov     ss,cs:[save_ss]      }
      $2E/$8B/$26/save_sp/    {   mov     sp,cs:[save_sp]      }
      $5D/                    {   pop     bp                   }
      $1F/                    {   pop     ds                   }
      $89/$46/<save_ax        {   mov     save_ax[bp],ax       }
      );
    IF save_ax <> 0 THEN WriteLn('Exit code = ', save_ax);
End;

procedure Zero;
    begin
       FillChar(zero1,ofs(zero2) - ofs(zero1) + sizeof(zero2), 0);
    end;

procedure help(pos:Integer);
{ Read and display help.txt }
const
   filename = 'help.txt';

var
   ch : char;
   i  : Integer;

begin
   if not exist(filename) then
   begin
      Make_Window(20,10,60,14,hf,hb,True);
      writeln(' Help file ''help.txt'' not found.');
      write(' Press any key...');
      clock;
      Ch := ReadKey;
      Remove_Window
   end else
   begin
      Make_Window(5,4,75,23,hf,hb,True);
      i := 1;
      assign(helpfile,filename);
      reset(helpfile);
      while not eof(helpfile) do
      begin
         seek(helpfile,pos-1);
         read(helpfile,trec);
            fwrite(7,i+3,hb*16+hf,trec.fString);
         i := succ(i);
         pos := succ(pos);
         if i > 15 then
         begin
            i := 1;
            writeln;
               fwrite(10,21,hb*16+4,'Press "-" or "+" or ESC to exit...');
            gotoxy(47,18);
            clock;
            repeat
               Ch := ReadKey;
            until ch in ['-','+',ESC];
            clrscr;
            if ch = '-' then pos := pos - 30;
            if pos < 1 then pos := 1;
            if ch = ESC then
            begin
               close(helpfile);
               textbackground(b);
               Remove_Window;
               exit
            end;
            clrscr;
         end;
      end;
         fwrite(10,21,hb*16+4,'Press any key to exit help...');
      gotoxy(35,18);
      clock;
      Ch := ReadKey;
      close(helpfile);
      textbackground(b);
      Remove_Window;
   end;
end;

procedure setprn(var c:char; var can:char);
{ Set up printer }
var
   d : text;
   ch : char;

begin
   assign(d,prnfile);
   rewrite(d);
   make_window(30,10,50,18,f,b,True);
   writeln;
   writeln(' 1 - Epson');
   writeln(' 2 - Okidata');
   repeat
      Ch := ReadKey;
   until ch in ['1'..'3'];
   case ch of
      '1': begin
              preset     := #27+#69;
              normal     := #27+#69;
              expanded   := #14;
           end;
      '2': begin
              preset     := #24;
              normal     := #30;
              expanded   := #31;
           end;
  end; { Case }
  writeln(d,preset);
  writeln(d,normal);
  writeln(d,expanded);
  writeln(d,can);
  close(d);
  remove_window
end;

procedure loadprn(var c:char; var can:char);
var
   d : text;

begin
   if exist(prnfile) then
   begin
      assign(d,prnfile);
      reset(d);
      readln(d,preset);
      readln(d,normal);
      readln(d,expanded);
      close(d);
   end else
   begin
      c := #29;    { Okidata Compress Code By Default }
      can := #30   { Okidata Cancel Code }
   end;
end;

{ -------------------------------------------------------- }
procedure display_colors(n:Integer);
var
   i : Integer;
begin
   writeln;
   textbackground(black);
   for i := 1 to n do
   begin
      textcolor(i);
      write(i:3)
   end;
   textcolor(15);
   writeln
end;

procedure save_setupfile;
var
   textfile : text;

begin
   assign(textfile,setupfile);
   rewrite(textfile);
   writeln(textfile,title);
   writeln(textfile,f);
   writeln(textfile,b);
   writeln(textfile,wf1);
   writeln(textfile,fc);
   writeln(textfile,wb1);
   writeln(textfile,wf2);
   writeln(textfile,wb2);
   writeln(textfile,lfg);
   writeln(textfile,lbg);
   writeln(textfile,bar_color);
   writeln(textfile,pattern);
   writeln(textfile,hf);
   writeln(textfile,hb);
   writeln(textfile,pr);
   close(textfile);
end;

procedure clear_windows;
var
   i : Integer;

begin
   for i := 1 to 5 do
   remove_window
end;

function free(dr:char):real;
{ Compute free disk space }
var
   reg:registers;

begin
   with reg do
   begin
      ah := $36;              { DOS function number }
      case upcase(dr) of
         'A': dl := $01;
         'B': dl := $02;
         'C': dl := $03;
         else dl := $00;      { drive number : 00=default, 01=A, 02=B, etc.}
      end;
      MSDOS(reg);             { call DOS }
      free := 1.0*ax*bx*cx    { multiply by 1.0 to create a real value}
   end;
end;

procedure logo;

var
   i : Integer;
   line : String60;

begin
   textbackground(lbg);
   textcolor(lfg);
   window(5,2,75,9);
   clrscr;
   gotoxy(1,4);
   writeln('  ',title);
   window(1,1,79,25);
   line := Strings(60,#176);
   for i := 10 to 23 do
      fwrite(10,i,pattern,line);
   textcolor(white);
   textbackground(black);
end;

procedure display_size;
var
   n : real;
   s : Integer;
   num : String10;

begin
   n := filesize(d);
   str(n:4:0,num);
   fwrite(6,6,lbg*16+lfg,'Number of records = '+num);
   s := sizeof(rec) * round(n);
   str(s:7,num);
   fwrite(6,7,lbg*16+lfg,'Database size =  '+num+' bytes');
   n := free(' ');
   str(n:8:0,num);
   fwrite(38,6,lbg*16+lfg,'Free disk space = '+num+' bytes   ');
end;

procedure main_menu;
begin
   clear_windows;
   TextBackground(Black);
   ClrScr;
   logo;
   Make_Window(16,13,38,22,wf1,wb1,True);
   textcolor(fc);    write('  F1: ');
   textcolor(wf1);   writeln('Help');
   textcolor(fc);    write('  F2: ');
   textcolor(wf1);   writeln('Printer setup');
   textcolor(fc);    write('  F3: ');
   textcolor(wf1);   writeln('Colors');
   textcolor(fc);    write('  F4: ');
   textcolor(wf1);   writeln('Clock On/Off');
   textcolor(fc);    write('  F5: ');
   textcolor(wf1);   writeln('Sort');
   textcolor(fc);    write('  F6: ');
   textcolor(wf1);   writeln('Shrink');
   textcolor(fc);    write('  F7: ');
   textcolor(wf1);   writeln('Backup Data');
   textcolor(fc);    write('  ESC');
   textcolor(wf1);   write('-Exit ');
   Make_Window(41,13,63,22,wf2,wb2,True);
end;

{ -------------------------------------------------------- }
Procedure Display_Choices(n:Integer);
var
   i, x, y : Integer;
begin
   x := 1;
   y := 1;
   if Color_Monitor then textbackground(b);
   clrscr;
   for i := 1 to n do
   begin
      y := y + 1;
      if y > 16 then
      begin
         x := x + 19;
         y := 2
      end;
   gotoxy(x,y);
      writeln(' '+Menu[i],spaces(18-length(menu[i])));
   end;
end;

procedure get_colors;
var
   temp : String60;
   i : Integer;
   q, up : boolean;

begin
   Make_Window(1,5,79,20,white,black,True);
   temp := '';
   textcolor(white);
   textbackground(black);
   Writeln('Title - ',title,' --> ');
   EditLine(temp,60,wherex,wherey,LegalChars,Term,Tc);
   if (temp <> title) and (temp <> '') then title := temp;
   temp := '';
   display_colors(15);
   if lfg = black then textcolor(white) else
   textcolor(lfg);
   write('Title text color ',lfg:2,' --> ');
   getintval(lfg,wherex,wherey,up,q);
   display_colors(7);
   textcolor(lbg);
   write('Title background color ',lbg:2,' --> ');
   getintval(lbg,wherex,wherey,up,q);
   display_colors(15);
   textcolor(wf1);
   write('Left window text color ',wf1:2,' --> ');
   getintval(wf1,wherex,wherey,up,q);
   display_colors(15);
   textcolor(fc);
   write('Left window function key color ',fc:2,' --> ');
   getintval(fc,wherex,wherey,up,q);
   display_colors(7);
   textcolor(wb1);
   repeat
      write('left window background color ',wb1:2,' --> ');
      getintval(wb1,wherex,wherey,up,q);
      writeln;
   until wb1 in [0..7];
   display_colors(15);
   textcolor(wf2);
   write('Right window text color ',wf2:2,' --> ');
   getintval(wf2,wherex,wherey,up,q);
   repeat;
      writeln;
      display_colors(7);
      textcolor(wb2);
      write('Right window background color ',wb2,' --> ');
      getintval(wb2,wherex,wherey,up,q);
   until wb2 in [0..7];
   display_colors(15);
   textcolor(bar_color);
   write('Slide Bar color ',bar_color:2,' --> ');
   getintval(Bar_color,wherex,wherey,up,q);
   textcolor(pattern);
   display_colors(15);
   write('Pattern Color ',pattern:2,' --> ');
   getintval(pattern,wherex,wherey,up,q);
   display_colors(15);
   write('Help window foreground color ',hf:2,' --> ');
   getintval(hf,wherex,wherey,up,q);
   display_colors(7);
   write('Help window background color ',hb:2,' --> ');
   getintval(hb,wherex,wherey,up,q);
   Save_SetupFile;
   for i := 1 to 3 do Remove_Window;
   main_menu;
   Display_Choices(3);
end;


procedure configure;
var
   textfile : text;
   i : Integer;

begin
   if exist(setupfile) then
   begin
      assign(textfile,setupfile);
      reset(textfile);
      readln(textfile,title);
      readln(textfile,f);
      readln(textfile,b);
      readln(textfile,wf1);
      readln(textfile,fc);
      readln(textfile,wb1);
      readln(textfile,wf2);
      readln(textfile,wb2);
      readln(textfile,lfg);
      readln(textfile,lbg);
      readln(textfile,bar_color);
      readln(textfile,pattern);
      readln(textfile,hf);
      readln(textfile,hb);
      readln(textfile,pr);
      close(textfile);
   end else
   begin
      clear_windows;
      clrscr;
      get_colors
   end;
end;