home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / HCDEMO.ZIP / PRNTSCR.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1993-01-04  |  14.3 KB  |  447 lines
  1. unit prntscr;
  2. interface
  3. uses dos,crt,printer,graph;
  4. {$V-}
  5. {$R-}    {Range checking off}
  6. {$B+}    {Boolean complete evaluation on}
  7. {$S+}    {Stack checking on}
  8. {$I+}    {I/O checking on}
  9.  
  10. const XMaxGlb  =79;                { Number of BYTES -1 in one screen line }
  11.       IVStepGlb= 2;                            { Initial value of VStepGlb }
  12.  
  13. var
  14.      XScreenMaxGlb, XPrnMax, YMaxGlb : Integer;
  15.  
  16. procedure SetBinBit;
  17. procedure UnSetBinBit;
  18. procedure dump_buffer;
  19. procedure Okidata_hardcopy(inverse:boolean;mode,start:byte); { Okidata }
  20. procedure OkiHrdCpySide(inverse:boolean;mode,start:byte);
  21. procedure Epson_hardcopy(inverse:boolean;mode,start:byte);   { EPSON   }
  22. procedure EpsHrdCpySide(inverse:boolean;mode,start:byte);
  23. Procedure ProHrdCpySide(Inverse:Boolean;Mode,start: Byte );
  24. procedure proprnt_hardcopy(inverse:boolean;mode,start:byte); { IBM     }
  25. procedure hardcopy(inverse:boolean;mode:byte;PrnType,
  26. Start:integer;Upright:Boolean);
  27.  
  28. implementation
  29.  
  30. procedure SetBinBit;
  31. { Sets the binary bit on the Lst device so data is passed }
  32. { in "raw" binary mode instead of ASCII mode through Lst. }
  33. var
  34.   LstHandle : word absolute Lst;
  35.   Regs      : Registers;
  36. begin
  37.   with Regs do
  38.   begin
  39.     AX := $4400;      { IOCTL sub function 0 - Get device information }
  40.     BX := LstHandle;  { device information is returned in DX          }
  41.     MsDos(Regs);
  42.     AX := $4401;      { IOCTL sub function 1 - Set device information }
  43.                       { New device setting is passed in DX            }
  44.  
  45.     DX := (DX and $00FF) or $0020; { Set bit 5 of DX so data is passed    }
  46.                                    { in "raw" mode through the Lst device }
  47.     MsDos(Regs);
  48.   end;
  49. end; { SetBinBit }
  50.  
  51. procedure UnSetBinBit;
  52. { UnSets the binary bit on the Lst device so data is passed }
  53. { in "cooked" ASCII mode instead of binary mode through Lst. }
  54. Var
  55.   LstHandle : word absolute Lst;
  56.   Regs      : Registers;
  57.   begin
  58.   with Regs do
  59.   begin
  60.     AX := $4400;      { IOCTL sub function 0 - Get device information }
  61.     BX := LstHandle;  { device information is returned in DX          }
  62.     MsDos(Regs);
  63.     AX := $4401;      { IOCTL sub function 1 - Set device information }
  64.                       { New device setting is passed in DX            }
  65.     DX := (DX and $00FF) xor $0020; { Turn bit 5 of DX off so data is passed }
  66.                                     { in "cooked" mode through the Lst device}
  67.     MsDos(Regs);
  68.    end;
  69. end; { UnSetBinBit }
  70.  
  71. procedure dump_buffer;
  72. { For use on IBM PC-LAN System. }
  73. var
  74.    regs : registers;
  75.  
  76. begin
  77.    with regs do
  78.    begin
  79.       ah := 6;
  80.       al := 3;
  81.       intr($2a,regs);
  82.    end;
  83. end;
  84.  
  85. procedure Okidata_hardcopy;
  86.   var i,j,top,row:integer;
  87.       ColorLoc,PrintByte:byte;
  88.  
  89.   procedure doline(top:integer);
  90.   var j : integer;
  91.     function ConstructByte(j,i:integer):byte;
  92.       { The image is reversed for Okidata, and only 7 bits are used. }
  93.       const Bits:array [0..6] of byte=(1,2,4,8,16,32,64);
  94.       var CByte,k:byte;
  95.       begin
  96.         i:=i * 7;
  97.         CByte:=0;
  98.         for k:=0 to 6 do
  99.           if GetPixel(j,i+k) > 0 then CByte:=CByte or Bits[k];
  100.           Cbyte := Cbyte or 128;
  101.         ConstructByte:=CByte;
  102.       end;
  103.     begin
  104.       SetBinBit;
  105.       for j:=0 to XScreenMaxGlb do
  106.        begin
  107.         if keypressed then exit else
  108.         PrintByte:=ConstructByte(j,i);
  109.         Write(lst,chr(PrintByte));
  110.         if (j-1) mod 5 = 0 then
  111.         Write(lst,chr(PrintByte));
  112.        end;
  113.        Write(lst,#3,#14); { Graphics Cr + Lf }
  114.     end;
  115.  
  116.   begin
  117.     top:=7;
  118.     row := GetMaxY div 7;
  119.     mode:=mode and 7;
  120.     if (mode=5) or (mode=0) then mode:=4;
  121.     if start = 0 then
  122.     begin
  123.        Write(lst,#29);        { 17 CPI }
  124.        Write(lst,#27,'1');    { Correspondence Quality }
  125.        Write(lst,#27,'0');    { Reset to default lines per inch }
  126.        Write(lst,#27,'8');    { 8 lines per inch }
  127.        Write(lst,#27,'N',#3); { Spacing }
  128.     end;
  129.        Write(lst,#3);         { Okidata Graphics Mode. }
  130.  
  131.     for i:= 0 to row do       { Print line of graphics. }
  132.        doline(6);
  133.  
  134.     Write(lst,#3,#2);         { Exit Graphics Mode. }
  135.     Write(lst,#29,'%9',#0);   { Normal height print. }
  136.     Write(lst,#30);           { Normal print width. }
  137.   end;
  138.  
  139. Procedure OkiHrdCpySide; { Sideways print }
  140.  
  141.   Var     Row, Col, G_row     : Integer ;
  142.           ColorLoc, PrintByte : Byte ;
  143.           LCnt, HCnt          : Char ;    { number of data points }
  144.  
  145.           NumOfDots,
  146.           Rpt, Mult           : Integer ; { scan multiplier       }
  147.  
  148.  
  149.   Function ConstructByte( X, Y : Integer ) : Byte ;
  150.  
  151.     const Bits:array [0..6] of byte=(1,2,4,8,16,32,64);
  152.     Var    CByte, B : Byte ;
  153.  
  154.     Begin
  155.       G_row := GetMaxX div 7;
  156.       CByte := 0 ; X := X * 7;
  157.       For B := 0 To 6 Do If GetPixel( X + B, Y ) > 0 Then
  158.       CByte := CByte OR Bits[B] ;
  159.       CByte := CByte OR 128;
  160.       ConstructByte := CByte ;
  161.     End ;
  162.  
  163.   Begin
  164.     Mult := 2;
  165.     Write(lst,#27,'0');    { Reset to default lines per inch }
  166.     Write(lst,#27,'1');    { Correspondence Quality }
  167.     Write(lst,#27,'8');    { 8 lines per inch }
  168.     Write(lst,#29);        { 17 CPI }
  169.     Write(lst,#3);         { Okidata Graphics Mode. }
  170.     For Col := 0 To XMaxGlb Do
  171.     Begin
  172.       SetBinBit;
  173.       For Row := GetMaxY - 1 DownTo 0 Do
  174.           Begin
  175.             PrintByte := ConstructByte( Col, Row ) ;     { The byte to send  }
  176.             For Rpt := 1 To Mult Do Write( LST, Chr( PrintByte )) ;
  177.           End ;
  178.         Write(lst,#3,#14);
  179.       End ;
  180.       WRite(lst,#3,#14);
  181.       Write(lst,#3,#2);
  182.       Write(lst,#29,'%9',#0); { Normal height print. }
  183.       Write(lst,#30);         { Normal print width. }
  184.   End ;
  185.  
  186. procedure Epson_hardcopy;
  187.   var i,j,top:integer;
  188.       ColorLoc,PrintByte:byte;
  189.  
  190.   procedure doline(top:integer);
  191.   var j : integer;
  192.     function ConstructByte(j,i:integer):byte;
  193.       const Bits:array [0..7] of byte=(128,64,32,16,8,4,2,1);
  194.       var CByte,k:byte;
  195.       begin
  196.         i:=i shl 3;
  197.         CByte:=0;
  198.         for k:=0 to top do
  199.           if GetPixel(j,i+k) > 0 then CByte:=CByte or Bits[k];
  200.         ConstructByte:=CByte;
  201.       end;
  202.     begin
  203.       if mode=1 then Write(lst,^['L')
  204.       else Write(lst,^['*',chr(mode));
  205.       Write(lst,chr(lo(XScreenMaxGlb+1)),chr(Hi(XScreenMaxGlb+215)));
  206.       for j:=0 to XScreenMaxGlb do
  207.        begin
  208.         if keypressed then exit else
  209.         PrintByte:=ConstructByte(j,i);
  210.         Write(lst,chr(PrintByte));
  211.         if (mode=1) and ((j-1) mod 3 = 0) then
  212.         Write(lst,chr(PrintByte));
  213.        end;
  214.        if mode<>4 then Writeln(lst);
  215.     end;
  216.  
  217.   begin
  218.     top:=7;
  219.     mode:=mode and 7;
  220.     if (mode=5) or (mode=0) then mode:=4;
  221.     Write(lst,^['3'#24);
  222.     for i:= 0 to ((YMaxGlb) shr 3)-1 do doline(7);
  223.     i:=((YMaxGlb) shr 3);
  224.     if (YMaxGlb) and 7<>0 then
  225.       doline((YMaxGlb) and 7);
  226.   end;
  227.  
  228. Procedure EPSHrdCpySide;
  229.  
  230.   Var     Row, Col            : Integer ;
  231.           ColorLoc, PrintByte : Byte ;
  232.           LCnt, HCnt          : Char ;    { number of data points }
  233.  
  234.           NumOfDots,
  235.           LeftMargin,
  236.           Rpt, Mult           : Integer ; { scan multiplier       }
  237.  
  238.  
  239.   Function ConstructByte( X, Y : Integer ) : Byte ;
  240.  
  241.     Const  Bits     : Array [0..7] Of Byte = ( 128, 64, 32, 16, 8, 4, 2, 1 ) ;
  242.     Var    CByte, B : Byte ;
  243.  
  244.     Begin
  245.       CByte := 0 ; X := X SHL 3 ;
  246.       For B := 0 To 7 Do If GetPixel( X + B, Y ) > 0 Then
  247.       CByte := CByte OR Bits[B] ;
  248.       ConstructByte := CByte ;
  249.     End ;
  250.  
  251.   Begin
  252.     Mult := 2;
  253.     LeftMargin := 5;          { One inch for left margin }
  254.     Write(lst,^['3'#24);
  255.     Write( LST, ^J^J^J^J ) ;  { To center image for CGA  }
  256.  
  257.     NumOfDots := GetMaxY * Mult ; { Compute how many  }
  258.     LCnt := Chr( Lo( NumOfDots )) ;                    { dots/line we are  }
  259.     HCnt := Chr( Hi( NumOfDots )) ;                    { going to send.    }
  260.     For Col := 0 To XMaxGlb Do
  261.       Begin
  262.          if mode=1 then Write(lst,^['L')
  263.          else Write(lst,^['*',chr(mode));
  264.         Write( LST, LCnt, HCnt ) ;          { Dot count to send        }
  265.  
  266.         For Row := GetMaxY - 1 DownTo 0 Do
  267.           Begin
  268.             PrintByte := ConstructByte( Col, Row ) ;     { The byte to send  }
  269.             If Inverse Then PrintByte := NOT PrintByte ; { Set reverse video }
  270.             For Rpt := 1 To Mult Do Write( LST, Chr( PrintByte )) ;
  271.           End ;
  272.         WriteLn( LST ) ;
  273.       End ;
  274.   End ;
  275.  
  276. Procedure ProHrdCpySide;
  277.   Const   G480  = 0 ; {  60 dpi,  480 dpl } { <-- disabled for HGC         }
  278.           G960a = 1 ; { 120 dpi,  960 dpl }
  279.           G960b = 2 ; { 120 dpi,  960 dpl } { <-- disabled for CGA and HGC }
  280.           G1920 = 3 ; { 240 dpi, 1920 dpl } { <-- disabled for CGA and HGC }
  281.  
  282.           LineSpc08  = ^['A'#8  ; { set line feed to 8/72"   }
  283.           LineSpc12  = ^['A'#12 ; { set line feed to 1/6"    }
  284.           StartVLF   = ^['2'    ; { start variable line feed }
  285.  
  286.           FormFeed   = #12      ; { form feed                }
  287.  
  288.           Start480   = ^['K'    ; { start 480  dots / line   }
  289.           Start960a  = ^['L'    ; { start 960a dots / line   }
  290.           Start960b  = ^['Y'    ; { start 960b dots / line   }
  291.           Start1920  = ^['Z'    ; { start 1920 dots / line   }
  292.  
  293.   Var     Row, Col            : Integer ;
  294.           ColorLoc, PrintByte : Byte ;
  295.           LCnt, HCnt          : Char ;    { number of data points }
  296.  
  297.           NumOfDots,
  298.           LeftMargin,
  299.           Rpt, Mult           : Integer ; { scan multiplier       }
  300.  
  301.  
  302.   Function ConstructByte( X, Y : Integer ) : Byte ;
  303.  
  304.     Const  Bits     : Array [0..7] Of Byte = ( 128, 64, 32, 16, 8, 4, 2, 1 ) ;
  305.     Var    CByte, B : Byte ;
  306.  
  307.     Begin
  308.       CByte := 0 ; X := X SHL 3 ;  { See KERNEL.DOC for desc of PD }
  309.       For B := 0 To 7 Do If GetPixel( X + B, Y ) > 0 Then
  310.       CByte := CByte OR Bits[B] ;
  311.       ConstructByte := CByte ;
  312.     End ;
  313.  
  314.   Begin
  315.     If Mode < G480                   { Make sure Mode is bounded  }
  316.       Then Mode := G480              { between 0 and 3            }
  317.       Else If Mode > G1920
  318.              Then Mode := G1920 ;
  319.  
  320.           Mult := 2  ;               { Lets send each pixel twice }
  321.           LeftMargin := 10;          { Two inches for left margin }
  322.           Write( LST, ^J^J^J^J ) ;   { To center image for CGA    }
  323.  
  324.     Write( LST, LineSpc08 ) ;        { set line spacing 8/72"     }
  325.     Write( LST, StartVLF ) ;         { start variable line feed   }
  326.  
  327.     NumOfDots := ( YMaxGlb + 1 + LeftMargin ) * Mult ; { Compute how many  }
  328.     LCnt := Chr( Lo( NumOfDots )) ;                    { dots/line we are  }
  329.     HCnt := Chr( Hi( NumOfDots )) ;                    { going to send.    }
  330.  
  331.     For Col := 0 To XMaxGlb Do       { XMaxGlb def in TYPEDEF.SYS }
  332.       Begin
  333.         Case Mode Of
  334.           G960a,                            { start 960a dots / line   }
  335.           G960b,                            { start 960b dots / line   }
  336.           G1920 : Write( LST, Start960a ) ; { start 1920 dots / line   }
  337.  
  338.         End ;
  339.  
  340.         Write( LST, LCnt, HCnt ) ;          { Dot count to send        }
  341.  
  342.         For Row := 1 To LeftMargin * Mult Do
  343.           Write( LST, ^@ ) ;                { Put the Left margin      }
  344.  
  345.         For Row := YMaxGlb DownTo 0 Do { YMaxGlb def in TYPEDEF.SYS }
  346.           Begin
  347.             PrintByte := ConstructByte( Col, Row ) ;     { The byte to send  }
  348.             If Inverse Then PrintByte := NOT PrintByte ; { Set reverse video }
  349.             For Rpt := 1 To Mult Do Write( LST, Chr( PrintByte )) ;
  350.           End ;
  351.         WriteLn( LST ) ;
  352.       End ;
  353.  
  354.     Write( LST, LineSpc12 ) ; { reset line spacing 12/72"  }
  355.     Write( LST, StartVLF ) ;  { start variable line feed   }
  356.   End ;
  357.  
  358. procedure proprnt_hardcopy;
  359. const
  360.    Start480   = ^['K'    ; { start 480  dots / line   }
  361.    Start960a  = ^['L'    ; { start 960a dots / line   }
  362.    Start960b  = ^['Y'    ; { start 960b dots / line   }
  363.    Start1920  = ^['Z'    ; { start 1920 dots / line   }
  364.  
  365.   var i,j,top:integer;
  366.       PrintByte:byte;
  367.  
  368.   procedure doline(top:integer);
  369.   var j : integer;
  370.     function ConstructByte(j,i:integer):byte;
  371.       const Bits:array [0..7] of byte=(128,64,32,16,8,4,2,1);
  372.       var CByte,k:byte;
  373.       begin
  374.         i:=i shl 3;
  375.         CByte:=0;
  376.         for k:=0 to top do
  377.           if GetPixel(j,i+k) > 0 then CByte:=CByte or Bits[k];
  378.         ConstructByte:=CByte;
  379.       end;
  380.     begin
  381.       case mode of  { Send IBM Proprinter codes. }
  382.          1 : Write(lst,Start480);
  383.          2 : Write(lst,Start960a);
  384.          3 : Write(lst,Start960b);
  385.          4 : Write(lst,Start1920);
  386.       end; { Case }
  387.       Write(lst,chr(lo(XPrnMax)),chr(Hi(XPrnMax)));
  388.       for j:=0 to XScreenMaxGlb do
  389.        begin
  390.         PrintByte:=ConstructByte(j,i);
  391.         if inverse then PrintByte:=not PrintByte;
  392.         if mode in [1..3] then
  393.         begin
  394.            if keypressed then exit else
  395.            Write(lst,chr(PrintByte));
  396.            if ((j-1) mod 4 = 0) and
  397.            (mode in [2,3]) then
  398.            Write(lst,chr(PrintByte)); { Extend horizontal size }
  399.         end else
  400.         begin
  401.            if keypressed then exit else
  402.            Write(lst,chr(PrintByte));
  403.         end;
  404.        end; { j }
  405.       if mode<>4 then Writeln(lst);
  406.     end;
  407.  
  408.   begin
  409.     top:=7;
  410.     mode:=mode and 7;
  411.     if (mode=5) or (mode=0) then mode:=4;
  412.     Write(lst,^['3'#24);
  413.     Writeln(lst,^['X'#1,#255);
  414.     for i:= 0 to ((YMaxGlb) shr 3)-1 do doline(7);
  415.     i:=((YMaxGlb) shr 3);
  416.     if (YMaxGlb) and 7<>0 then
  417.       doline((YMaxGlb) and 7);
  418.   end;
  419.  
  420. procedure hardcopy;
  421. Var
  422.    GraphDriver, GraphMode, i : Integer;
  423.  
  424. begin
  425.    XScreenMaxGlb := GetMaxX - 1; { Max number of PIXELS across screen. }
  426.    YMaxGlb       := GetMaxY - 1; { Max number of PIXELS down screen.   }
  427.    XPrnMax := 815;               { Max Proprinter PIXEL width.         }
  428.    SetBinBit; { Set LST device for binary data }
  429.    case PrnType of
  430.       1: if Upright then ProPrnt_hardcopy(inverse,mode,Start)
  431.          else
  432.          ProHrdCpySide(inverse,mode,start);
  433.  
  434.       2: if Upright then Epson_HardCopy(inverse,mode,start)
  435.          else
  436.          EpsHrdCpySide(inverse,mode,Start);
  437.  
  438.       3: if Upright then okidata_hardcopy(inverse,mode,Start)
  439.          else
  440.          OkiHrdCpySide(inverse,mode,Start);
  441.  
  442.    end; { Case }
  443.    UnSetBinBit;
  444.    Dump_Buffer; { For Network Use }
  445.  end;
  446. end.
  447.