home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / APPS / BUSINESS / TTYPRT36.ZIP / UTIL.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1991-01-16  |  11.0 KB  |  314 lines
  1. FUNCTION get_fn; {: BOOLEAN (c)}
  2. (*****************************************************************************
  3. gets a filename from user
  4. ******************************************************************************)
  5. VAR
  6.     i:INTEGER;
  7.     temp:S35;
  8. BEGIN
  9.     TextBackGround(Blue); TextColor(LightGray);
  10.     temp:=c;
  11.     c:=READKEY;
  12.     WHILE c<>^M DO BEGIN
  13.         IF c=^H THEN BEGIN
  14.             IF Length(temp) > 0 THEN BEGIN
  15.                 temp:=COPY(temp,1,LENGTH(temp)-1);
  16.                 WRITE(^H,' ',^H)
  17.             END
  18.         END ELSE BEGIN
  19.             WRITE(c);
  20.             temp:=temp+c
  21.         END;
  22.         c:=READKEY
  23.     END;
  24.     TextBackGround(Black); TextColor(Cyan); WRITELN;
  25.     FOR i:=1 TO LENGTH(temp) DO temp[i]:=UpCase(temp[i]); {all uppercase}
  26.     get_fn:=temp
  27. END; {FUNCTION get_fn}
  28.  
  29. FUNCTION open_fn; {(fn:FILE_STR):BOOLEAN}
  30. (*****************************************************************************
  31. opens file given by argument, searches along path to do so; returns result
  32. ******************************************************************************)
  33. VAR
  34.     err:INTEGER;
  35.     found:BOOLEAN;
  36.     dospath,subdir:STRING[80];
  37.     sigfn:S35;
  38.     brk:INTEGER;
  39. BEGIN
  40.     found:=FALSE;
  41.     ASSIGN(io_file,fn);                      {open file}
  42.     {$I-} RESET(io_file); {$I+}
  43.     err:=IORESULT;
  44.     IF err = 0 THEN                          {was if successful?}
  45.         found:=TRUE
  46.     ELSE BEGIN                               {no, so look along path}
  47.         dospath:=GetEnv('PATH');
  48.         WHILE (err<>0) AND (LENGTH(dospath)>0) DO BEGIN
  49.             brk:=POS(';',dospath);
  50.             IF brk<>0 THEN BEGIN
  51.                subdir:=COPY(dospath,1,brk-1);
  52.                dospath:=COPY(dospath,brk+1,LENGTH(dospath))
  53.             END ELSE BEGIN
  54.                subdir:=dospath;
  55.                dospath:=''
  56.             END;
  57.             IF (subdir[LENGTH(subdir)]=':') OR (subdir[LENGTH(subdir)]='\') THEN
  58.                sigfn:=subdir+fn
  59.             ELSE
  60.                sigfn:=subdir+'\'+fn;
  61.             ASSIGN(io_file,sigfn);                  {open sign block file}
  62.             {$I-} RESET(io_file); {$I+}
  63.             err:=IORESULT;
  64.             IF err=0 THEN found:=TRUE
  65.         END
  66.     END;
  67.     IF found THEN
  68.         open_fn:=TRUE
  69.     ELSE
  70.         open_fn:=FALSE
  71.     {end}
  72. END; {FUNCTION open_ifn}
  73.  
  74. FUNCTION get_line;
  75. (*****************************************************************************
  76. reads a line of input from io_file, filters out garbage.
  77. ******************************************************************************)
  78. VAR
  79.     tmpstr:STRING;
  80.     eol:BOOLEAN;
  81.     cc:BYTE;
  82.     c:CHAR;
  83. BEGIN
  84.     tmpstr:=''; eol:=FALSE;
  85.     WHILE (NOT EOF(io_file)) AND (NOT eol) DO BEGIN
  86.         READ(io_file,c);                     {get one character}
  87.         WHILE ORD(c)=$1D DO BEGIN            {if $1D, it's the W* print header}
  88.             READ(io_file,c);                 {discard chars till ending $1D}
  89.             WHILE ORD(c) <> $1D DO READ(io_file,c);
  90.             READ(io_file,c)                  {read next 'real' char}
  91.         END;
  92.         c:=CHR(ORD(c) AND 127);              {zero hi bit}
  93.         c:=UpCase(c);                        {force uppercase}
  94.         IF c < ' ' THEN BEGIN                {control char?}
  95.             IF c=^M THEN eol:=TRUE           {return? discard all others!}
  96.         END ELSE
  97.             tmpstr:=tmpstr+c                 {add it on to string}
  98.         {end}
  99.     END;
  100.     cc:=LENGTH(tmpstr);
  101.     WHILE (tmpstr[cc]=' ') AND (cc>=1) DO cc:=cc-1;  {delete trailing <sp>'s}
  102.     tmpstr[0]:=CHAR(cc);                     {adjust new length}
  103.     get_line:=tmpstr                         {return w/line}
  104. END;
  105.  
  106. PROCEDURE disp_dir;
  107. (*****************************************************************************
  108. shows a list of files in the current directory - 4 wide
  109. ******************************************************************************)
  110. VAR DirInfo:SearchRec;
  111.     i:INTEGER;
  112.     dir:FILE_STR;
  113. BEGIN
  114.     GetDir(0,dir);
  115.     TextBackground(Black); TextColor(LightCyan);
  116.     WRITELN;
  117.     WRITELN;
  118.     WRITE('Directory of files in ');
  119.     TextColor(lightGray); TextBackground(Blue); WRITE(dir);
  120.     TextColor(lightCyan); TextBackground(Black); WRITELN(':');
  121.     TextColor(Cyan);
  122.     FindFirst('*.*',Archive,DirInfo);
  123.     i:=1;
  124.     WHILE DosError=0 DO BEGIN
  125.         IF i<5 THEN BEGIN
  126.             WRITE(COPY(DirInfo.name+'                 ',1,15));
  127.             i:=i+1
  128.         END ELSE BEGIN
  129.             WRITELN(DirInfo.name);
  130.             i:=1
  131.         END;
  132.         FINDNEXT(DirInfo)
  133.     END;
  134.     WRITELN
  135. END; {PROCEDURE disp_dir}
  136.  
  137. PROCEDURE chg_dir;
  138. (*****************************************************************************
  139. changes current directory
  140. ******************************************************************************)
  141. VAR
  142.     dir,new_dir:FILE_STR;
  143.     err:INTEGER;
  144.     c:CHAR;
  145. BEGIN
  146.     GetDir(0,dir);
  147.     TextBackground(Black); TextColor(LightCyan);
  148.     WRITELN;
  149.     WRITELN;
  150.     WRITE('        Current directory is ',#26,' ');
  151.     TextBackground(Blue); TextColor(LightGray); WRITE(dir);
  152.     TextBackground(Black); TextColor(Yellow); WRITELN;
  153.     WRITE(  'Enter directory to change to ',#26,' ');
  154.     TextBackground(Blue); TextColor(LightGray);
  155.     READLN(new_dir);
  156.     TextBackground(Black); TextColor(Cyan); clreol;
  157.     {$I-} ChDir(new_dir); {$I+}
  158.     err:=IORESULT;
  159.     IF err <> 0 THEN BEGIN
  160.         TextColor(LightMagenta+Blink); WRITELN('That directory was not found!');
  161.         beep; TextColor(Cyan);
  162.     END;
  163.     WRITELN
  164. END; {PROCEDURE chg_dir}
  165.  
  166. PROCEDURE disp_msg;
  167. (*****************************************************************************
  168. displays text of message on screen, a page at a time
  169. ******************************************************************************)
  170. VAR line_cnt,i:INTEGER;
  171.     c:CHAR;
  172. BEGIN
  173.     TextBackGround(Black);
  174.     cur_page:=1;
  175.     WHILE cur_page<=tot_pages DO BEGIN
  176.         Clrscr;
  177.         TextColor(LightGreen);
  178.         WRITELN('Page ',cur_page:2,' of ',tot_pages);
  179.         WRITELN; TextColor(Cyan);
  180.         line_cnt:=1;
  181.         WHILE (line_cnt <= Max_Lines_Page) AND
  182.              ((Max_Lines_Page * (cur_page-1)+line_cnt) <= Tot_tty_lines) DO BEGIN
  183.              WRITELN(tty[Max_Lines_Page*(cur_page-1)+line_cnt]);
  184.              line_cnt:=line_cnt+1
  185.         END; {while}
  186.         WRITELN;
  187.         TextColor(Yellow);
  188.         WRITE('Strike <esc> to return, any other key to continue ...');
  189.         c:=READKEY;
  190.         IF c=#27 THEN exit;
  191.         cur_page:=cur_page+1;
  192.     END; {while}
  193.     IF tot_mfr_lines>0 THEN BEGIN
  194.         Clrscr;
  195.         TextColor(LightGreen);
  196.         WRITELN('MFR:');
  197.         WRITELN; TextColor(Cyan);
  198.         FOR i:=1 TO tot_mfr_lines DO
  199.             WRITELN(mfr[i]);
  200.         WRITELN;
  201.         TextColor(Yellow);
  202.         WRITE('Strike any key to continue ...');
  203.         c:=READKEY
  204.     END
  205. END; {PROCEDURE disp_msg}
  206.  
  207. PROCEDURE beep;
  208. (*****************************************************************************
  209. does just what it says!
  210. ******************************************************************************)
  211. Begin
  212.   sound(1000);
  213.   delay(200);
  214.   nosound
  215. END; {PROCEDURE beep}
  216.  
  217. PROCEDURE help_msg; {(subj:S10)}
  218. (*****************************************************************************
  219. displays the help file on the argument subject
  220. ******************************************************************************)
  221. VAR c:char;
  222.    i:INTEGER;
  223.    buff,tmp:STRING[80];
  224. BEGIN
  225.     TextBackGround(Black); clrscr;
  226.     IF open_fn(hfn) THEN BEGIN
  227.         tmp:=':'+subj;
  228.         readln(io_file,buff);
  229.         WHILE buff <> tmp DO readln(io_file,buff);     {find subject line}
  230.         READLN(io_file,buff);                          {read header line}
  231.         WHILE NOT EOF(io_file) AND (buff[1]<>':') DO BEGIN
  232.             clrscr;
  233.             TextColor(LightGreen); WRITELN(buff);  {help page title is highlighted}
  234.             TextColor(Cyan);
  235.             READLN(io_file,buff);
  236.             i:=1;
  237.             WHILE (i<23) AND (buff[1]<>':') DO BEGIN
  238.                 WRITELN(buff);
  239.                 READLN(io_file,buff);
  240.                 i:=i+1;
  241.             END;
  242.             GOTOXY(1,25); TextColor(Yellow);     {last line is highlighted}
  243.             WRITE('Strike any key to continue ...');
  244.             c:=READKEY; TextColor(Cyan); WRITELN;
  245.             IF (c=#27) OR (buff[1]=':') THEN BEGIN
  246.                 clrscr;
  247.                 exit
  248.             END;
  249.             READLN(io_file,buff);                {read next header line}
  250.         END
  251.     END ELSE BEGIN
  252.         TextColor(lightMagenta);
  253.         WRITELN('Help file (',hfn,') not found.');
  254.         WRITELN;
  255.         TextColor(Cyan);
  256.         WRITELN('Please refer to your documentation or the file TTYPRT3.DOC');
  257.         WRITELN('for additional help.');
  258.         WRITELN;
  259.         TextColor(Yellow);                 {last line is highlighted}
  260.         WRITE('Strike any key to continue ...');
  261.         c:=READKEY; TextColor(Cyan)
  262.     END;
  263.     clrscr;
  264. END; {PROCEDURE help_msg}
  265.  
  266. PROCEDURE load_font;
  267. (*****************************************************************************
  268. Copies external soft font file to LPT1 with appropriate control strings
  269. Used in the HPLJ version only!
  270. ******************************************************************************)
  271. VAR
  272.     ans:STRING[30];  {answers to prompts}
  273.     err:INTEGER;
  274.     c:CHAR;
  275. Begin
  276. {$ifdef HPLJ}
  277.     TextBackGround(Black); TextColor(LightGreen);
  278.     clrscr;
  279.     WRITELN('Softfont download to HP LaserJet or compatible printer');
  280.     WRITELN; WRITELN; WRITELN; TextColor(cyan);
  281.     WRITELN('(If unsure of the following questions - hit <enter> for defaults.)');
  282.     WRITELN;
  283.     TextColor(Yellow); WRITE('Enter OCR-A softfont filename or <enter> for ',ffn,' ',#26,' ');
  284.     TextBackGround(Blue); TextColor(LightGray);
  285.     READLN(ans); TextBackGround(Black);
  286.     IF LENGTH(ans)>0 THEN ffn:=ans;
  287.     WRITELN;
  288.     TextColor(Yellow); WRITE('Enter softfont id number or <enter> for ',sfid:0,' ',#26,' ');
  289.     TextBackGround(Blue); TextColor(LightGray);
  290.     READLN(ans); TextBackGround(Black); TextColor(Cyan);
  291.     IF LENGTH(ans)>0 THEN VAL(ans,sfid,err);
  292.     IF sfid=0 THEN sfid:=1776;                {0 is not allowed, so reset}
  293.     WRITELN;
  294.     IF NOT open_fn(ffn) THEN BEGIN
  295.         beep; TextColor(LightMagenta+Blink);
  296.         WRITE('Font File not found, ');
  297.     END ELSE BEGIN
  298.         WRITE('Starting download, please wait ... ');
  299.         WRITE(lst,#27,'E');                 {reset LaserJet}
  300.         WRITE(lst,#27,'*c',sfid:0,'D');     {start softfont}
  301.         WHILE NOT eof(io_file) DO BEGIN
  302.             READ(io_file,c);
  303.             WRITE(lst,c)
  304.         END;
  305.         WRITE(lst,#27,'*c5F');               {make it permament}
  306.         CLOSE(io_file);
  307.         WRITELN; WRITE('Soft font successfully downloaded, ');
  308.     END;
  309.     TextColor(Cyan);
  310.     WRITELN('strike any key to continue ...');
  311.     c:=READKEY
  312. {$endif}
  313. END; {PROCEDURE beep}
  314.