Power-Programmierung/CD1.mdf/pascal/library/dos/drucker/printr2/printr2.pas

Pascal/Delphi Source File | 1989-12-18 | 21.3 KB | 652 lines

{$S-,V-}
(****************************************************************************)
(*                                                                          *)
(*                             Mesa Software                                *)
(*                       3302 Fourth Ave, Suite 101                         *)
(*                          San Diego, Ca. 92103                            *)
(*                                                                          *)
(*                                                                          *)
(*       Program :    Unit Printr2         File Name :  printr2.pas         *)
(*                                                                          *)
(*       Release :    Version 1.0               Date :  Dec. 15, 1989       *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)

    Unit printr2;
    Interface

     {Requires TJocks5.
      Use at your own risk. Mesa Software assumes no
      liability for the use of this software}

    uses CRT,dos,fastttt5,miscttt5,winttt5,strnttt5,keyttt5;

      Const
        esc            = #27;
        off            = #0;
        NLQ            = (esc + '!' + #1);
        NLQ_OFF        = (esc + '!' + #0);
        Supercrpt      = (esc + 'S' + #0);
        Subscrpt       = (esc + 'S' + #1);
        scrp_off       = (esc + 'T');
        Comprsd        = (esc + #15);
        uncomprsd      = (esc + #18);
        Emphaszd       = (esc + 'E');
        unemphszd      = (esc + 'F');
        Dbl_prtng      = (esc + 'G');
        un_dbl         = (esc + 'H');

        dbl_wid        = (esc + 'W' + #1);
        un_wid         = (esc + 'W' + off);

        {The two print commands below are the same as the two
         above.}
        expanded       = esc + '!' + #48;
        unexpand       = esc +  'W' + off;


        undr_lin       = (esc + '-' + #1);
        undr_lin_off   = (esc + '-' + off);
        backspc        = (#8);
        char_byte      = '$';
          {This is the char you see in the banner and
           report headers.  Try !,*,#, or %.  Taylor
           your chars for different reports}

        thirteen       = 13;
        backspace      = #8;
        centered       = #27 + 'a' + #1;
        left_margin    = #27 + 'a' + off;
        line_feed      = #10;
        form_feed      = #12;
        carig_rtn      = #13;
        author         = 'Tom Devanney';

     Type
       Datestr = string[8];

     var
      lst                  : Text;
      page                 : string;
      num                  : integer;

      Function  Printer_on : Boolean;
      Procedure Beepr;
      Procedure banner(co_nam,addrs,city,st,zip,phone,rpt_title : string);
      Procedure Report_hdr(Rpt_Title,co_nam,addrs,city,st,zip,page : String);
      Function  IO_Not_OK(num : word) : Boolean;
      Function  GetSystemDate : Datestr;
      Function  NumToStr(number : LongInt) : string;
      Procedure Check_color(var Textf,Back : byte);

    {======================================================================}

    Implementation

    {======================================================================}


    Procedure Check_color(var Textf,Back : byte);

       {This is to change any color combo into white on black for monochrome
          screens}

       begin
         if (baseOfScreen <> $B800) then
         begin
           Textf := 15;
           Back  := 0;
         end;
       end;

     Function GetSystemDate : Datestr;   {string[10]}

     {This is to get a system date from the system and return as a string}

       Var
         regs         :  Registers;
         st2,st3,st4  : String[10];

         begin
           Fillchar(regs,Sizeof(regs),0);
           Regs.AH := $2A;     {Interrupt for system date}
           MsDos(regs);
           With regs do
           Begin
             Str(CX, st2); {year}
             Str(DH, st3); {Month}
             Str(DL, st4); {Day}
           end;
           If length(st3) = 1 then  st3 := '0' + st3;
           If length(st4) = 1 then  st4 := '0' + st4;
           getsystemdate := st3 + '/' +  st4 + '/' + copy(st2,3,2);
         end;


    Function NumToStr(number : LongInt) : string;

    {-Convert a longinteger,word,integer,byte to a string}

      var
        numstr : string;
      begin
        Str(number,numstr);
        NumToStr := numstr;
      end;


    Procedure Beepr;

      {This is a fancy lawyer telephone beeper sound
       The sound you hear is money}

      Const
        itration = 3;
      var
        countr   : integer;

      begin
        for countr := 1 to itration do
        begin
          Sound(949); {925..999}
          Delay(50);
          sound(499); {450..600}
          delay(50);
        end;
        Nosound;
      end; { Beep }

    Function Printer_on : Boolean;

      {This is a printer screen that is easy to use}

      var
        line,col,end_lin,
        end_col,box_knd    : integer;
        Regs               : registers;
        answr              : char;
        message            : string;
        textf,boxf,back    : byte;

      begin
        answr := ' ';
        clrscr;
        col     := 10;
        line    := 10;
        end_col := 70;
        end_lin := 20;
        box_knd := 0;  {0..4,5..9 choose another box type to suit your style}
       Printer_on := False;
       savescreen(1);
       boxf  := white;
       back  := lightgray;
       check_color(boxf,back);
       Fbox(col,line,end_col,end_lin,boxf,back,box_knd);
       boxf  := yellow;
       back  := red;
       check_color(boxf,back);
       Fbox(col + 1 ,line + 1,end_col - 1,end_lin - 1,boxf,back,box_knd);
       back := black;
       check_color(boxf,back);
       Fbox(col + 2,line + 2,end_col - 2,end_lin - 2,boxf,back,box_knd);
       textf := yellow;
       check_color(textf,back);
       Writebetween(col,end_col,line + (end_lin - line) div 2 - 1,textf,back,'CHECK THE PRINTER FOR PAPER');
       message := 'THE PRINTER IS READY, HIT RETURN TO START';

       Offcursor;
       with regs do
       begin
         ah := 2;
         dx := 0;
         intr($17,regs);
         printer_on := (ah = 144);
       end;
       Repeat
         if (regs.ah <> 144)  then
           message := 'PRINTER OFF LINE, ESC TO ABORT OR RETURN TO CONTINUE';
           beepr;
           Writebetween(col,end_col,line + (end_lin - line) div 2 + 1,textf,back, message);
           answr := getkey;
         with regs do
         begin
           ah := 2;
           dx := 0;
           intr($17,regs);
           printer_on := (ah = 144);
         end;
       until ((regs.ah = 144) or (answr = #27));
       if (answr = #27) then
         Printer_on := False;
       restorescreen(1);
       disposescreen(1);
    end; {Function  Printer_on_line}







   Function IO_NOT_OK(num : word) : Boolean;

     {This is an error manager that will enable you to escape most runtime
       errors.  In some cases you will add recovery code after this routine
       to your program}

     var
       msg,Drive_a,
       Drive_b : string;

     begin
       Drive_a := 'A:';
       Drive_b := 'B:';
       Flushkeybuffer;
       msg := '';
       IO_Not_ok := (num <> 0);
       if (num <> 0) then
       begin
         case num of
           002 : msg := 'File not found';
           003 : msg := 'Path not found';
           004 : msg := 'Too many open files, Check Files = in config.sys';
           005 : msg := 'File access denied or Drive/Directory exists';
           006 : msg := 'Invalid file handle';
           012 : msg := 'Invalid file access code';
           015 : msg := 'Invalid drive number';
           016 : msg := 'Cannot remove current directory';
           017 : msg := 'Cannot rename across drives';
           100 : msg := 'Disk read error, is file open ?';
           101 : msg := 'Disk write error, is disk full ?';
           102 : msg := 'File not assigned, File name not assigned?';
           103 : msg := 'File not open';
           104 : msg := 'File not open for input';
           105 : msg := 'File not open for output';
           106 : msg := 'Invalid numeric format';
           150 : msg := 'Disk is write-protected, Remove tab?';
           151 : msg := 'Unknown unit';
           152 : msg := 'Drive not ready, close drive door, Thank you';
           153 : msg := 'Unknown command';
           154 : msg := 'CRC error in data';
           155 : msg := 'Bad drive request structure length';
           156 : msg := 'Disk seek error';
           {I use error 157 to sense an unformatted floppy.}
           157 : msg := 'Unknown media type. We will format Floppy.';
           158 : msg := 'Sector not found';
           159 : msg := 'Printer out of paper, so put some in';
           160 : msg := 'Device write fault. Usually printer is off';
           161 : msg := 'Device read fault';
           162 : msg := 'Hardware failure';
           200 : msg := 'Division by zero';
           201 : msg := 'Range check error';
           202 : msg := 'Stack overflow';
           203 : msg := 'Insufficient memory';
           204 : msg := 'Invalid pointer operation';
           205 : msg := 'Floating point overflow, number too big';
           206 : msg := 'Floating point underflow';
           207 : msg := 'Invalid floating point operation';
           208 : msg := 'Overlay manager not installed';
           209 : msg := 'Overlay file read error';
         else
           msg := 'Turbo runtime error '+ NumToStr(num);
      end;
       savescreen(5);
       {These colors are for ega/vga, monochrome is not supported
         Here is a hint for good window/message formatting.
          Choose an odd number of lines for the window and
                 an odd number of messages to display
          or     an even number of lines for the window and
                 an even number of messages to display.
         Display your message centered in the window or box and the
         screen will look superb.  Makes happy satisfied users}

       Mkwin(10,8,70,17,yellow, lightgray,4);
       Writebetween(11,69,13,black,lightgray,upper(msg));
       Writebetween(11,69,14,black,lightgray,'HIT RETURN TO CONTINUE');
       readln;
       restorescreen(5);
       disposescreen(5);
       if ((num = 157) or (num = 3)) then
         begin
           clrscr;
           SwapVectors;
           Exec(GetEnv('COMSPEC'), '/C Format ' + Drive_a);
           SwapVectors;
           if DosError <> 0 then
             begin
               Writebetween(11,69,13,black,lightgray,upper('Could not execute COMMAND.COM'));
               Readln;
             end
           else
             begin
               Writebetween(11,69,13,black,lightgray,upper('Disk ' + Drive_a + ' is Formatted'));
               Readln;
             end;
         end;
     end;
   end;


(**************************************************************************)
(*                                                                        *)
(*                                                                        *)
(*                            Mesa Software                               *)
(*                       3302 Fourth Ave, Suite 101                       *)
(*                          San Diego, Ca. 92103                          *)
(*                                                                        *)
(*                                                                        *)
(*       Procedure :   Banner            File Name : Printr2.pas          *)
(*                                                                        *)
(*       Release   :   Version 1.0            Date : Dec 15, 1989         *)
(*                                                                        *)
(*                                                                        *)
(*                                                                        *)
(**************************************************************************)


   Procedure banner(co_nam,addrs,city,st,zip,phone,rpt_title : string);

   (*  this is a procedure with the following call:
       banner(co_nam,addrs,City,st,zip,rpt_title);

          co_nam    := 'MESA SOFTWARE';
          addrs     := '3302 FOURTH AVENUE, SUITE 101';
          city      := 'SAN DIEGO'; {If necessary,A routine will add the comma}
          st        := 'CALIFORNIA';
          zip       := '92103';
          phone     := '1(555)555-5555';
          rpt_title := 'ACCOUNTS RECEIVABLE AGING REPORT';
          dte       := Date; this date routine is in Technojocks.miscttt unit.

       We have Tested it using a Panasonic 1592. The routine is flexible enough to
       take most any size strings within reason. Watch the report titles as they
       are expanded, centered and added to. Check the code for comma addition.

    *)

   var
     i,j,k,pag_lnth,
     lin_lnth,lin_counter,char_count,
     Top_headr,bottom_headr,title_lines      : integer;
     page                                    : string;



   Procedure Banner_Top;

      var
        countr,i : integer;

      begin
        for countr := 1 to top_headr do
        begin
          for i := 1 to lin_lnth do
            write(lst,char_byte);
          Writeln(lst);
          char_count := 0;
          inc(lin_counter);
        end;
      end;

    Procedure Banner_Bottom;

      var
        countr,i : integer;

      begin
        for countr := 1 to bottom_headr do
        begin
          for i := 1 to lin_lnth - 1  do
            write(lst,char_byte);
          Writeln(lst,char_byte);
        end;
          for countr := 1 to 5 do
          writeln(lst);
          {After this routine, the form length, etc, should be set
              for your report paging to follow}
      end;


     Procedure Banner_left;

       begin

         {You can use most any replicating code to write the
          following. The sample below will give you an option for most
          of banner routines. You probably know the argument. My code is
          perfect, yours is not so perfect. So Help Yourself.
          You must be careful with the TJocks.Fastttt5.Replicate Function.
          There is a LIMIT of 80 characters. The function is primarily for
          screen writes, so be careful in using it for printer lengths over
          80 characters, it returns a value of 1.}

         write(lst,#27 + 'a' + #0);
         write(lst,replicate(10,char_byte));
         write(lst,#27 + 'j' + #0);
       end;

     Procedure Banner_right;

        begin
          write(lst,#27 + 'a' + #2);
          write(lst,#27 + 'Q' + #132);
          writeln(lst,replicate(10,char_byte));
        end;

      Procedure Filler_Line;

        begin
          Banner_Left;
          Banner_Right;
        end;


      Procedure Filler(num : integer);

        var
          countr      : integer;

        begin
          for countr := 1 to num do
            begin
              Filler_Line;
            end;
          end;

     Procedure Names;

        begin
          if copy(city,length(city),1) <> ',' then    {We add a comma if necessary}
            city := city + ', ' +  st + '  ' + zip
          else
            city := city + ' ' + st + '  ' + zip;
         end;

     Procedure Report_Title(str1 : string);

       begin
         banner_left;
         write(lst,#27 + 'a' + #1); {Auto Centering}
         write(lst,#27 + '!' + #48); {Double width/double strike printing}
         write(lst,str1);
         write(lst,#27 + 'W' + #0);
         write(lst,#27 + 'H');
         write(lst,#27 + '!' + #0);
         write(lst,#27 + 'j' + #0);
         banner_right;
       end;


     Procedure Title(sub_title : string);

       begin
         Banner_left;
         write(lst,#27 + 'a' + #1);
         write(lst,upper(sub_title));
         write(lst,#27 + 'j' + #0);
         Banner_Right;
       end;

      begin
        write(lst,#27,'@');     {Initializes the printer}
        write(lst,#27+'C'+#62); {Sets the page length to 62 lines}
        top_headr    := 6;      {This is the top lines to fill}
        pag_lnth     := 60;     {This is the page length  50..66}
        Bottom_headr := 6;      {Same as top_headr}
        lin_lnth     := 132;    {This was written using wide carriage. Try 80}
        lin_counter  := 1;
        title_lines  := 5;      {We need this to calculate top and bottom filler space}
        char_count   := 0;
        Names;
        banner_top;
        num := ((pag_lnth  - 20) div 2 - 1);
        Filler(num);
        rpt_title := upper(rpt_title);
        report_title(rpt_title);
        num := 2;
        Filler(num);
        title(date);
        num := 11;
        Filler(num);
        title(co_nam);
        title(addrs);
        title(city);
        title(phone);
        num := 12;
        Filler(num);
        Banner_bottom;
     end;


(***************************************************************************)
(*                                                                         *)
(*                            Mesa Software                                *)
(*                       3302 Fourth Ave, Suite 101                        *)
(*                          San Diego, Ca. 92103                           *)
(*                                                                         *)
(*                                                                         *)
(*     Procedure :    Report-hdr;          File Name :  PRINTR2.PAS        *)
(*                                                                         *)
(*       Release :    Version 1.0               Date :  Dec 15,1989        *)
(*                                                                         *)
(*                                                                         *)
(*                                                                         *)
(***************************************************************************)

    Procedure Report_hdr(Rpt_Title,co_nam,addrs,city,st,zip,page : String);



     (*  This is a procedure with the following call:
       Report_Hdr(Rpt_Title,co_nam,addrs,City,st,zip,rpt_title,page);

          co_nam    := 'MESA SOFTWARE';
          addrs     := '3302 FOURTH AVENUE, SUITE 101';
          city      := 'SAN DIEGO';
          st        := 'CALIFORNIA';
          zip       := '92103';
          phone     := '1(555)555-5555';
          dte       := Date; this date routine is in Technojocks, sub your own
          Rpt_Title := 'ACCOUNTS RECEIVABLE AGING REPORT';

        The code here is different from Banner. Choose your own style.
                                                            *)
      var
       i,j,k,lnth,pag_num : integer;
       pag                : string;


     Procedure Title(rpt_title : string);

       var i : integer;
       begin
         for i := 1 to (lnth div 2)  do write(lst,' ');
         j := i;
         write(lst,expanded);
         write(lst,Emphaszd);
         i := length(rpt_title);
         if odd(i) then rpt_title := rpt_title + ' ';
         for i:= 1 to length(rpt_title) div 2 do
         Write(lst,#8);
         write(lst,rpt_title);
         write(lst,unexpand);
         j := i + length(rpt_title) div 2;
         j := j  + (lnth div 2);
       end;


   Procedure Wrt_Address;

     var
       k : integer;

     begin
       addrs := '';
       addrs := co_nam + ' ' + addrs + ' ' + city + ' ' + st + '  ' + zip;
       if odd(length(addrs)) then addrs := addrs + ' ';
       for k := 1 to lnth div 2 - (length(addrs) div 2) do
         write(lst,#32);
       write(lst,Emphaszd,addrs);
       j := lnth div 2 + length(addrs) div 2;
     end;

   Procedure Wrt_Date;
     var
       i : integer;
     begin
       for i :=  1 to lnth - (j + length(date) - 1) do
         write(lst,#32);
       Writeln(lst,date);
     end;

   Procedure Wrt_city;
     var
       i : integer;
     begin
       city := city + ' ' + st + '  ' + zip;
       k := length(city);
       for i := 1 to lnth div 2  - (k div 2) do
         write(lst,#32);
       write(lst,city);
       j := lnth div 2 + (length(city)  div 2);
     end;

   Procedure Wrt_page;
     var
       i : integer;
     begin
       inc(pag_num);
       str(pag_num,pag);
       page := page + pag;
       for i := 1 to lnth - (j + length(page)) do
         write(lst,#32);
       writeln(lst,page);
       j := 0;
     end;

     begin
      page := 'Page No. ';
      pag_num := 0;
      lnth := 132;
      write(lst,#27 + '@');
      write(lst,#27 + 'P');
      Title(rpt_title);
      wrt_page;
      Wrt_address;
      Wrt_Date;
      for i := 1 to lnth do
        begin
           write(lst,char_byte);
           if (i = lnth div 2) then write(lst,'!');
        end;
        for i := 1 to 2 do writeln(lst);
          write(lst,#27 + '<');  {Home the print head}
     end;

    begin
       assign(lst,'LPT1');
       rewrite(lst);
    end.