home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / gp / hpcopy.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-12-06  |  3.0 KB  |  144 lines
  1. UNIT HpCopy;
  2. { To allow dump of graphics images to HP LaserJet printer }
  3. { Supplied by BORLAND TECH SUPPORT }
  4.  
  5. Interface
  6.  
  7. USES Crt, Dos, Graph;
  8.  
  9. VAR
  10.   LST : Text;
  11.  
  12. Procedure HPHardCopy;
  13.  
  14. Implementation
  15.  
  16. Var
  17.   Aspekt, Width, Height : Word;
  18.   Vport : ViewPortType;
  19.  
  20.   {$F+}
  21.  
  22.   Function LSTNoFunction( Var F : TextRec) : Integer;
  23.   begin
  24.     LSTNoFunction := 0;
  25.   end;
  26.  
  27.   Function LSTOutPutToPrinter( var F : TextRec) : Integer;
  28.   Var
  29.     Regs : Registers;
  30.     P : Word;
  31.  
  32. Begin
  33.   With F DO
  34.   begin
  35.     P:=0;
  36.     Regs.AH:=16;
  37.     While ( P < BufPos ) and ((Regs.AH and 16)=16) DO
  38.     begin
  39.       Regs.AL:=Ord(BufPtr^[P]);
  40.       Regs.AH:=0;
  41.       Regs.DX:=UserData[1];
  42.       Intr($17,Regs);
  43.       Inc(P);
  44.     end;
  45.     BufPos :=0;
  46.   end;
  47.   If((Regs.AH and 16)=16) then
  48.     LstOutPutToPrinter :=0          { No Error }
  49.   Else
  50.     If ((Regs.AH and 32) =32) then
  51.       LSTOutPutToPrinter := 159      { out of paper }
  52.     else
  53.       LSTOutPutToPrinter := 160;      { Device Write Fault }
  54. end;
  55.  
  56. {$F-}
  57.  
  58. Procedure AssignLST(Port : Byte);
  59. begin
  60.   With TextRec(Lst) do
  61.   begin
  62.     Handle:=$FFF0;
  63.     Mode := fmOutput;
  64.     BufSize:= SizeOf(Buffer);
  65.     BufPtr:= @Buffer;
  66.     BufPos := 0;
  67.     OpenFunc := @LSTNoFunction;
  68.     InOutFunc:= @LSTOutPutToPrinter;
  69.     FlushFunc:= @LSTOutPutToPrinter;
  70.     CloseFunc:= @LSTOutPutToPrinter;
  71.     UserData[1]:=Port-1;
  72.   end;
  73. end;
  74.  
  75. Function GetAspectX : Word;
  76. begin
  77.   GetAspectX:=Word(Ptr(Seg(GraphFreeMemPtr),Ofs(GraphFreeMemPtr)+277)^);
  78. end;
  79.  
  80. Procedure SetAspectRatio( NewAspect : word);
  81. begin
  82.   Word(Ptr(Seg(GraphFreeMemPtr),Ofs(GraphFreeMemPtr)+277)^) := NewAspect;
  83. end;
  84.  
  85. Procedure HPHardCopy;
  86. Const DotsPerInch ='100';
  87. CursorPosition = '5';
  88. Esc = #27;
  89. Var
  90.   LineHeader : string[6];
  91.   LineLength : string[2];
  92.   Y : Integer;
  93.   Procedure DrawLine(Y:integer);
  94.   var
  95.    GraphStr : string[255];
  96.    Base : word;
  97.    BitNo, ByteNo,DataByte : Byte;
  98.  
  99.    begin
  100.      FillChar(GraphStr,SizeOf(GraphStr),#0);
  101.      GraphStr :=LineHeader;
  102.      for ByteNo := 0 to width do
  103.      begin
  104.        DataByte := 0;
  105.        Base := 8*ByteNo;
  106.        For BitNo := 0 to 7 do
  107.        begin
  108.          If GetPixel(BitNo+Base,Y) > 0
  109.            then
  110.              DataByte := DataByte + 128 Shr BitNo;
  111.        end;
  112.        GraphStr:=GraphStr+Chr(DataByte);
  113.      end;
  114.      write(Lst,GraphStr);
  115.    end; { of DrawLine }
  116.  
  117. begin { main HPCopy }
  118.   Aspekt := GetAspectX;
  119.   SetAspectRatio(4950);
  120.   FillChar(LineLength,SizeOf(LineLength),#0);
  121.   FillChar(LineHeader,SizeOf(LineHeader),#0);
  122.   GetViewSettings(Vport);
  123.   width:=(Vport.X2+1) - Vport.X1;
  124.   width:=((width-7) div 8);
  125.   Height:= Vport.Y2 - Vport.Y1;
  126.   write(lst,Esc+'E');
  127.   write(lst,Esc+'*t'+DotsPerInch+'R');
  128.   write(lst,Esc+'&a'+CursorPosition+'C');
  129.   write(lst,Esc+'*r1A');
  130.   Str(Width+1,LineLength);
  131.   LineHeader:=Esc+'*b'+LineLength+'W';
  132.   For Y := 0 to Height + 1 DO
  133.   begin
  134.     DrawLine(Y);
  135.     DrawLine(Y);
  136.   end;
  137.   write(lst,Esc+'*rB');
  138.   write(lst,Esc+'E');
  139. end;
  140. begin
  141.   assignLST(1);
  142. end.
  143.   SetAspectRatio(Aspekt);
  144. end.