DataMuseum.dk

top - download

    Length: 10112 (0x2780)
    Types: TextFile
    Names: »REGN2.PAS«

└─⟦5c8344fa1⟧ Bits:30004223 REGN version 2.1 til ICL Comet
    └─ ⟦this⟧ »REGN2.PAS« 

TextFile

(* REGN2.PAS INCLUDE FILE *)

æ*******************************************************************å
æ*  purpose:            micellaneous utilities and commands.       *å
æ*******************************************************************å

PROCEDURE CURSOR(cursor_on:boolean);
begin
 if cursor_on then
  write(curon)
 else
  write(curoff); 
end;

FUNCTION KEY:char;  æ Allmost all keyboard inputs through this routine å 
var
 cch:char;
begin
 CURSOR(true);
 read(kbd,cch);
 KEY:=cch;
 CURSOR(false);
end;

PROCEDURE DELAY(antal:integer;var trykket:boolean);
var
 dcount:integer;
begin
 dcount:=0;
 while (dcount<antal) and not trykket do begin
  dcount:=dcount+1;
  trykket:=keypress;
 end; 
end;

æ Displayes a line in the bottom of the screen and higligts the listed å
æ characters                                                           å

PROCEDURE HIGHLIGHTMSG(indlin:str128);
var
 udlin1,udlin2:stringÆ128Å;
 tpos:byte;
begin
 udlin1:=indlin;
 udlin2:='';
 for tpos:=1 to len(udlin1) do begin
  if (udlin1ÆtposÅ in Æ'A'..'Å','0','?'Å) then
   udlin2:=udlin2+rvson+udlin1ÆtposÅ+rvsoff
  else
   udlin2:=udlin2+udlin1ÆtposÅ;
 end;
 write(udlin2);
end;

PROCEDURE MSG(s: anystring);
begin
 gotoxy(0,23);
 write(clreol);
 write(s,rvsoff,' ');
end;

PROCEDURE FLASH(x: integer; s: anystring;  blink: boolean);
var
 tasttrykket:boolean;
begin
 tasttrykket:=false;
 write(rvson);
 gotoxy(x,22);
 write(s);
 if blink then begin
  repeat
   gotoxy(x,22);
   blink:=not blink;
   if blink then write(rvson) else write(rvsoff);
   write(s);
   DELAY(pause,tasttrykket);
  until tasttrykket;
 end;
 write(rvsoff);
end;

PROCEDURE FJERNFLASH(xpos,tlen:byte);
begin
 FLASH(xpos,rvsoff+copy(tom,1,tlen),false);
end;

FUNCTION UPCASE(nch:char):char;
begin
 if (ord(nch)>96) and (ord(nch)<127) then
  UPCASE:=chr(ord(nch)-32)
 else
  UPCASE:=nch;
end;

PROCEDURE AUTO;
begin
 autocalc:=not autocalc;
 if autocalc then
  FLASH(63,' Autoregn: TIL ',false)
 else
  FLASH(63,' Autoregn: FRA ',false);
end;

PROCEDURE GRID;
var
 i:integer;
 count:char;
begin
 write(clrhom,indicator,rvson);
 for count:='A' to fxmax do begin
  gotoxy(xposÆcountÅ,0);
  write(vline,'    ',count,'     ');
 end;
 gotoxy(0,1);
 for i:=1 to fymax do writeln(i:2);
 write(rvsoff);
 if autocalc then
  FLASH(63,' Autoregn: TIL ' ,false)
 else
  FLASH(63,' Autoregn: FRA ',false);
 FLASH(37,'  Tast  /  for kommando  ',false);
end;
 
PROCEDURE BUFFERNULL;
begin
 kopierfra:='';
 with formelbuffer do begin
  cellstatus:=ÆtxtÅ;
  contents:='';
  value:=0;
  fw:=normwidth;dec:=2;
 end;
end;

PROCEDURE RYDCELLE(i:sheetindex;j:integer;all:boolean);
begin
 with sheetÆi,jÅ do begin
  cellstatus:=ÆtxtÅ;      æ all cells initiated with text attribut å
  contents:='';           æ all strings emty                       å  
  value:=0;               æ all values 0                           å
  if all then dec:=2;     æ default number of decimals             å
  if all then fw:=normwidth;  æ all cells width = normwidth        å
 end;
end;

PROCEDURE INIT;
var
 i: sheetindex;
 j: integer;
begin
 forladt:='A';repeteret:=false;
 errmessageÆ1Å:='Uoverenstemmelse i filtype';
 errmessageÆ2Å:='Filen findes ikke';
 errmessageÆ3Å:='Disketten er fuld';
 errmessageÆ4Å:='Fil forsvundet';
 errmessageÆ5Å:='Programfejl - kan ikke læses';
 errmessageÆ6Å:='Programfejl - kan ikke skrives';
 errmessageÆ7Å:='For mange åbne filer';
 errmessageÆ8Å:='Ukendt fejl';
 errmessageÆ9Å:='Fejl ved indlæsning af tal';
 errmessageÆ10Å:='Ukendt fejl';
 errmessageÆ11Å:='For stor fil';
 errmessageÆ12Å:='Fil uafsluttet';
 errmessageÆ13Å:='Disketten er fuld';
 errmessageÆ14Å:='Søgning udover kant af fil';
 errmessageÆ15Å:='Fil ikke åben';
 retning:=1;indicator:=pilh;
 slut:=false;
 for i:='A' to fxmax do
  for j:=1 to fymax do RYDCELLE(i,j,true);
 autocalc:=true;            æ autocalc is on                         å
 fx:='A'; fy:=1;            æ first field in upper left corner       å
end;

PROCEDURE CLEAR;
begin
 write(rvsoff);
 gotoxy(0,23); write(clreol);
 write(bell+' Slet dette regneark?  (J/N) ');
 repeat
  ch:=UPCASE(KEY);
 until ch in Æ'J','N'Å;
 write(ch);
 if ch='J' then begin
  INIT;
  if kopierfra<>'' then kopierfra:='OLD';
  GRID;
 end;
end;

PROCEDURE SKIFTTYPE(typenr:byte);
begin
 gotoxy(4,22);write(rvson);
 if typenr=0 then
  write('TEKST: ')
 else
  if typenr=1 then
   write('TAL:   ')
  else
   write('FORMEL:');
 write(rvsoff);    
end;

PROCEDURE FLASHTYPE;
begin
 with sheetÆfx,fyÅ do begin
  gotoxy(0,22);
  if fy<10 then
   write(fx,fy,'  ')
  else
   write(fx,fy:2,' ');
  if formula in cellstatus  then
   write('FORMEL  ')
  else
   if constant in cellstatus then
    write('TAL     ')
   else
    if txt in cellstatus then write('TEKST   ');
  gotoxy(0,23);write(rvsoff,clreol);
  if Æformula,constantÅ*cellstatus<>ÆÅ then write(contents);
 end;
end;

PROCEDURE TALUD(i:sheetindex;j:integer);
var
 teststr:anystring;
begin
 with sheetÆi,jÅ do
  if (dec>=0) then begin
   str(value:fw+1:dec,teststr);
   if teststrÆ1Å<>' ' then
    write(copy(stars,1,fw))
   else
    write(value:fw:dec);
  end else begin
   str(value:fw+1,teststr);
   if teststrÆ1Å<>' ' then
    write(copy(stars,1,fw))
   else
    write(value:fw);
  end;
end;
 
PROCEDURE GOTOCELL(gx: sheetindex; gy: integer);
begin
 with sheetÆgx,gyÅ do begin
  write(rvson);
  gotoxy(xposÆgxÅ,gy);
  write(copy(tom,1,fw));
  gotoxy(xposÆgxÅ,gy);
  if txt in cellstatus then
   write(contents)
  else begin
   if not (formula in cellstatus) then
    TALUD(gx,gy)
   else
    if onscreen in cellstatus then
     TALUD(gx,gy)
    else
     write(copy(points,1,fw));
  end;
  FLASHTYPE;
  gotoxy(xposÆgxÅ,gy);
 end;
 write(rvsoff);
end;

PROCEDURE LEAVECELL(fx:sheetindex;fy: integer);
begin
 with sheetÆfx,fyÅ do begin
  gotoxy(xposÆfxÅ,fy);
  write(rvsoff);
  if (txt in cellstatus) then begin
   if not (cellstatus*Æoverwritten,lockedÅ<>ÆÅ) then
    write(contents+copy(tom,1,fw-len(contents)));
  end else begin
   write(copy(tom,1,fw));
   gotoxy(xposÆfxÅ,fy);
   if onscreen in cellstatus then
    TALUD(fx,fy)
   else
    write(copy(points,1,fw));
  end;
 end;
end;

PROCEDURE UPDATE;
var
 ufx: sheetindex;
 ufy: integer;
begin
 GRID;
 for ufx:='A' to fxmax do
  for ufy:=1 to fymax do
   if sheetÆufx,ufyÅ.contents<>'' then LEAVECELL(ufx,ufy);
end;

PROCEDURE MOVEDOWN;
var
 startx: sheetindex;
 starty: integer;
begin
 retning:=2;indicator:=pilned;
 gotoxy(0,0);write(indicator);
 LEAVECELL(fx,fy);
 if forladt>fx then fx:=forladt;
 startx:=fx;starty:=fy;
 repeat
  fy:=fy+1;
  if fy>fymax then fy:=1;
  while (sheetÆfx,fyÅ.cellstatus*Æoverwritten,lockedÅ<>ÆÅ)
   and (fx>'A') do fx:=pred(fx);
 until (sheetÆfx,fyÅ.cellstatus*Æoverwritten,lockedÅ=ÆÅ)
  or ((fy=starty) and (fx=startx));
 GOTOCELL(fx,fy);
end;

PROCEDURE MOVEUP;
var
 startx: sheetindex;
 starty: integer;
begin
 LEAVECELL(fx,fy);
 if forladt>fx then fx:=forladt;
 startx:=fx;starty:=fy;
 repeat
  fy:=fy-1;
  if fy<1 then fy:=fymax;
  while (sheetÆfx,fyÅ.cellstatus*Æoverwritten,lockedÅ<>ÆÅ)
   and (fx>'A') do fx:=pred(fx);
 until (sheetÆfx,fyÅ.cellstatus*Æoverwritten,lockedÅ=ÆÅ)
  or ((fy=starty) and (fx=startx));
 GOTOCELL(fx,fy);
end;

PROCEDURE MOVERIGHT;
var
 startx: sheetindex;
 starty: integer;
begin
 retning:=1;indicator:=pilh;
 gotoxy(0,0);write(indicator);
 LEAVECELL(fx,fy);
 startx:=fx;starty:=fy;
 repeat
  if fx<fxmax then
   fx:=succ(fx)
  else begin
   fx:='A';
   fy:=fy+1;
   if fy>fymax then fy:=1;
  end;
 until (sheetÆfx,fyÅ.cellstatus*Æoverwritten,lockedÅ=ÆÅ)
  or ((fx=startx) and (fy=starty));
 forladt:=fx;
 GOTOCELL(fx,fy);
end;

PROCEDURE MOVELEFT;
var
 startx: sheetindex;
 starty: integer;
begin
 LEAVECELL(fx,fy);
 startx:=fx;starty:=fy;
 repeat
  if fx>'A' then
   fx:=pred(fx)
  else begin 
   fx:=fxmax;
   fy:=fy-1;
   if fy<1 then fy:=fymax;
  end;
 until (sheetÆfx,fyÅ.cellstatus*Æoverwritten,lockedÅ=ÆÅ)
  or ((fx=startx) and (fy=starty));
 forladt:=fx;
 GOTOCELL(fx,fy);
end;

FUNCTION DREVTEST(drev:char):boolean;
var
 ch:char;
begin
 if drev>'B' then begin
  FJERNFLASH(37,25);
  MSG('DREV '+drev+': - OK?  J/N ');
  repeat
   ch:=UPCASE(KEY);
  until pos(ch,'JN')>0;
  if ch='J' then
   DREVTEST:=true
  else
   DREVTEST:=false; 
 end else
  DREVTEST:=true;
end;

FUNCTION EXIST(filen:anystring):boolean;
var
 f:file;
 test:boolean;
begin
 (*$i-*)
 assign(f,filen);
 reset(f);
 (*$i+*)
 test:=(iores=0);
 (*$i+*)
 if test then begin
  ro:=(memÆaddr(f)+21Å>127);
  close(f);
 end;
 EXIST:=test;
end;

PROCEDURE FORTRYDTEKST;
begin
 FLASH(37,'  Fortryd  -  Tast  ESC  ',false);
end;

FUNCTION DISKVALG:char;
var
 sv,udisk:char;
 drevok:boolean;
begin
 repeat
  FORTRYDTEKST;
  MSG(' Hvilket drev?  ');
  repeat
   udisk:=UPCASE(KEY);
  until udisk in Æ'A'..'P',escÅ;
  FJERNFLASH(37,25);
  drevok:=true;
  if udisk<>esc then drevok:=DREVTEST(udisk);
  if udisk<>esc then MSG('DREV '+(udisk)+': er valgt ');
 until drevok;
 DISKVALG:=udisk;
end;

PROCEDURE GETFILENAME(xp:byte; var line: str14; filetype:str3);
var
 kniv:stringÆ8Å;
begin
 line:='';
 FORTRYDTEKST;
 gotoxy(xp,23);write(clreol);
 repeat
  ch:=UPCASE(KEY);
  if ch in Æ'A'..'Z','_','0'..'9',return,venstre,delleft,escÅ then begin
   if ch in Ævenstre,delleftÅ then begin
    if len(line)>0 then delete(line,len(line),1);
    gotoxy(xp,23);write(clreol,line);
   end else begin
    if ch=esc then
     line:=''
    else
     if (len(line)<8) or (ch=return) then begin
      write(ch);
      line:=line+ch;
     end;
   end; 
  end;
 until (ch=return) or (ch=esc);
 if ch=return then delete(line,len(line),1);
 kniv:=line;line:=kniv;
 if line<>'' then line:=line+'.'+filetype;
 FJERNFLASH(37,25);
end;
«eof»