home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PROGRAMS / UTILS / LASER / DLST12.ZIP / DLSTW.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-11-28  |  7.4 KB  |  299 lines
  1. { DLSTW 1.2 - David L. Peterson, 220 9th St So. Waite Park, Mn 56387 }
  2.  
  3. {   Print multiple files using very small font to get up to 336 lines
  4.     printed per page
  5. }
  6.  
  7. Uses Dos;
  8. type str255 = string[255];
  9. const
  10.   sptab : array[0..9] of string[8] =
  11.    (' ',' ','  ','   ','    ','     ','      ','       ','        ',' ');
  12. var
  13.   inf,outf     :  text;
  14.   inbuf,outbuf : array[1..10240] of char;
  15.   fnm,infname  :  string[60];
  16.   wln  :  string[255];
  17.   lnr  :  integer;
  18.   pgnr :  integer;
  19.   blanknr:integer;
  20.   i,j,k:  integer;
  21.   colnr:  integer;
  22.  
  23.   wss  :  string[60];
  24.   title:  string[60];
  25.  
  26.   r    :  real;          { following 3 used in setting lines per page }
  27.   rss  :  string[5];
  28.   err  :  integer;
  29.   mxln :  integer;
  30.  
  31. {------------------------------------------}
  32. function reptch(ch:char; n:integer):str255;
  33. var ss : str255;
  34. begin
  35.   if n > 0 then fillchar(ss[1],n,ch);
  36.   ss[0] := chr(n);
  37.   reptch := ss;
  38. end;
  39.  
  40. {------------------------------------------}
  41. function intss(n,l:integer):str255;
  42. var ss : str255;
  43. begin
  44.   str(n:l, ss);
  45.   intss := ss;
  46. end;
  47.  
  48. {------------------------------------------}
  49. { readln version of getline
  50.    expands tabs, delete ff
  51.    note: readln interprets a single CR as an end of line
  52.          readln does not do anything special with a FF  }
  53. procedure getline;
  54. var i,j  : integer;
  55. begin
  56.   readln(inf,wln);
  57.  
  58.   i := pos(#12,wln);
  59.   while i <> 0 do begin
  60.      delete(wln, i, 1);
  61.      i := pos(#12,wln);
  62.   end;
  63.  
  64.   i := pos(#9,wln);
  65.   while i <> 0 do begin
  66.      j := 9 - (i mod 8);
  67.      delete(wln, i, 1);
  68.      insert(sptab[j], wln, i);
  69.      i := pos(#9,wln);
  70.   end;
  71. end;
  72.  
  73. {------------------------------------------}
  74. procedure prthdg;
  75. begin
  76.     writeln(outf,
  77.             #13#27'&dD',title,        { CR, Underline, Title }
  78.             #27'&a70C',               { Pos to col 70 }
  79.             'Page',intss(pgnr,4),     { Page number }
  80.             #27,'&d@');               { Underline off }
  81.     lnr := 2;
  82.     writeln('Printing Page ', pgnr);
  83. end;
  84.  
  85. {------------------------------------------}
  86. procedure endcol;
  87. begin
  88.   if colnr = 1 then begin
  89.              { Draw a rule between the two columns
  90.                 then position to line 0 }
  91.      write(outf,#27'*p1230x0Y'#27'*c3a3150b0P'#27'&a0R');
  92.              { Set font to internal 10 cpi font so we can set
  93.                  the left margin based on 1/10 in. }
  94.              { 0p    fixed spacing
  95.                10h   10 cpi
  96.                10u   symbol set
  97.                3t    Courier    }
  98.              { set left margin to 4.2 in., set to font id #1 }
  99.      write(outf,#27'(s0p10h10u3T'#27'&a42L');
  100.      write(outf,#27'(1X');
  101.      colnr := 2;
  102.      lnr := 1;
  103.   end
  104.   else begin
  105.           { output a FF
  106.              set to 10cpi font, set left margin to .4 in.
  107.              set font id # 1, pos to line 0 }
  108.      write(outf,#12);
  109.      write(outf,#27'(s0p10h10u3T'#27'&a4L');
  110.      write(outf,#27'(1X'#27'&a0R');
  111.      colnr := 1;
  112.      pgnr := pgnr + 1;
  113.      prthdg;
  114.   end;
  115. end;
  116.  
  117. {------------------------------------------}
  118. procedure putline;
  119. var wlen : integer;
  120. begin
  121.  
  122.   wlen := length(wln);
  123.   if wlen > 90 then lnr := lnr + 2
  124.   else              lnr := lnr + 1;
  125.  
  126.   if lnr >= mxln then
  127.     endcol;
  128.  
  129.   if wlen > 90 then begin
  130.     writeln(outf,#13#10,copy(wln,1,90));
  131.     write  (outf,'    ....',copy(wln,91,80));
  132.   end
  133.   else
  134.     write(outf,#13#10,wln);
  135. end;
  136.  
  137.  
  138. {------------------------------------------}
  139. procedure pfile(fspec, fnm, fdesc:str255);
  140. begin
  141.   assign(inf,fspec);
  142.   SetTextBuf(inf,inbuf);
  143.   {$I-} reset(inf); {$I+}
  144.   if ioresult <> 0 then begin
  145.     writeln(fnm, ' cannot open');
  146.     halt;
  147.   end;
  148.  
  149.   wln := '';
  150.   putline;
  151.   write(outf,#27'*c1000a3b0P');
  152.  
  153.   wln:=#27'&dD'+fnm+'       '+fdesc+#27'&d@';
  154.   putline;
  155.  
  156.   blanknr := 0;
  157.   while not eof(inf) do begin
  158.     getline;
  159.     if length(wln) = 0 then
  160.       blanknr := blanknr + 1
  161.     else
  162.       blanknr := 0;
  163.     if blanknr < 3 then
  164.       putline;
  165.   end;
  166.   close(inf);
  167. end;
  168.  
  169. {--------------------------------------------------}
  170. {  Getfnames - use wildcard name to process files  }
  171. {         fnm - wildcard filename                  }
  172. {         pass - =1 then list filenames            }
  173. {         pass - =2 then process each file         }
  174. {--------------------------------------------------}
  175. procedure getfnames (fnm:str255;pass:integer);
  176.  
  177. var
  178.     Dirinfo   :   Searchrec;
  179.     Dttm      :   DateTime;
  180.     sname     :   string[65];
  181.     prefix    :   string[65];
  182.     nm        :   string[12];
  183.     szss,mdyss:   string[12];
  184.     j         :   integer;
  185. begin
  186.  
  187.     sname := fnm;
  188.     if sname = '' then
  189.        sname := '*.*';
  190.  
  191.   { --- get prefix(drive & path) of file spec if any --- }
  192.     j := 0;
  193.     for i := 1 to length(sname) do
  194.        if sname[i] in [':','\'] then j := i;
  195.     prefix := '';
  196.     if j > 0 then
  197.        prefix := copy(sname,1,j);
  198.  
  199.     Findfirst(sname, 0, Dirinfo);
  200.  
  201.     j := 0;
  202.     while DosError = 0 do begin
  203.       with Dirinfo do begin
  204.         nm := Name;
  205.  
  206.         if   ( pos('.COM',nm) = 0 )
  207.          and ( pos('.EXE',nm) = 0 ) then begin
  208.              UnpackTime(time,Dttm);
  209.  
  210.              with Dttm do
  211.                mdyss := intss(month,2)+'/'+intss(day,2)+'/'+intss(year,2);
  212.  
  213.              str(Size:8, szss);
  214.  
  215.              if pass = 1 then begin
  216.                wln := nm + reptch(' ',20-length(nm)) + mdyss + '   ' + szss;
  217.                putline;
  218.              end else
  219.                pfile(prefix + nm, nm, mdyss + '   ' + szss);
  220.        end;
  221.  
  222.       end; {with}
  223.       FindNext (Dirinfo);
  224.  
  225.     end; {while}
  226. end;
  227. {------------------------------------------}
  228. begin
  229.   writeln('DLSTW 1.2');
  230.   pgnr := 1;
  231.   colnr := 1;
  232.  
  233.   if paramcount < 3 then begin
  234.      writeln('Usage:  dlstw title <fspec> <outfile> [# lines]');
  235.      halt;
  236.   end;
  237.  
  238.   { --- get lines per page & calc x/48 spacing --- }
  239.   { ---   default to 168 & 3.0/48 in. spacing  --- }
  240.   err := 1;
  241.   if paramcount > 3 then
  242.      val (paramstr(4), mxln, err);
  243.   if err <> 0 then mxln := 168;
  244.   r := trunc(5040/mxln)/10;        { 504 is 10.5 in times 48 }
  245.   str(r:3:1,rss);
  246.  
  247.   title := paramstr(1);
  248.   wss   := paramstr(2);
  249.  
  250.   fnm := paramstr(3);
  251.   assign(outf,fnm);
  252.   SetTextBuf(outf,outbuf);
  253.   {$I-} rewrite(outf); {$I+}
  254.   if ioresult <> 0 then begin
  255.     writeln(fnm, ' cannot open');
  256.     halt;
  257.   end;
  258.  
  259.  
  260.   { ---------- Send Esc Seqs to Printer ------------ }
  261.   write(outf,#27'E',                 { reset }
  262.              #27'&l8d2e84f6d',       { set top & bottom margin to give
  263.                                        10.5 in of printable area }
  264.              #27'(s0p10h10u3T'#27'&a4L',{ set to 10 cpi font,
  265.                                         ** add symbol set to font sel 10u
  266.                                         set left margin .4 in }
  267.              #27'(1X',               { set to font id # 1 }
  268.              #27'&l',rss,'C',        { set line spacing to rss/48 in. }
  269.              #27'&a0R');             { position to line 0 }
  270.  
  271.   prthdg;
  272.  
  273.  
  274.  
  275.   { ---- Read & Print File ---- }
  276.   lnr := 1;
  277.  
  278.   getfnames(wss,1);
  279.   getfnames(wss,2);
  280.  
  281. { blanknr := 0;
  282.   while not eof(inf) do begin
  283.     getline;
  284.     if length(wln) = 0 then
  285.       blanknr := blanknr + 1
  286.     else
  287.       blanknr := 0;
  288.     if blanknr < 3 then
  289.       putline;
  290.   end;
  291. }
  292.   if lnr > 1 then
  293.     write(outf,#12);    { output FF }
  294.  
  295.   write(outf,#27'E');    { output Reset }
  296.  
  297.   close(outf);
  298. end.
  299.