home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / HPDUMP01.ZIP / EGAPRTSC.PAS
Encoding:
Pascal/Delphi Source File  |  1992-06-10  |  4.8 KB  |  148 lines
  1. {---------------------------------------------------------------}
  2. { Turbo Pascal unit to dump a graphics screen to an HP Laserjet }
  3. { compatible printer.                                           }
  4. { Written by Bob Beauchaine, May 1990                           }
  5.  
  6. { No user documentation necessary.  Simply include a            }
  7. { "Uses egaprtsc" clause in your main program.  When you want a }
  8. { screen dump to the laser printer, make a call to dumpscreen.  }
  9. { Printing can be aborted at any time by pressing the ESC key.  }
  10. { Works with printers attached to the Comm ports if the         }
  11. { appropriate MODE command has been issued at the dos prompt.   }
  12. { Note that this is *not* a BGI driver.  Output resolution is   }
  13. { limited to that of the display adapter in use.                }
  14. {---------------------------------------------------------------}
  15.  
  16. unit egaprtsc;
  17.  
  18. interface
  19.  
  20. uses crt,printer,dos,graph;
  21.  
  22. var abort : boolean;
  23.  
  24. { This is the procedure to call from your program when you want }
  25. { a hardcopy.                                                   }
  26. procedure dumpscreen;
  27.  
  28. implementation
  29.  
  30. const ESC = #27;
  31.       one : word = 1;
  32.  
  33. var   regs : registers;
  34.       start_from_left,move_vertically : string;
  35.  
  36. procedure sendstring(var s : string);
  37. { Procedure to dump the accumulated data string to the laserjet }
  38.  
  39. inline($5B/              { POP BX (GET STRING OFFSET) }
  40.        $5A/              { POP DX (GET STRING SEGMENT) }
  41.        $1E/              { PUSH DS (SAVE DS REGISTER) }
  42.        $8E/$DA/          { MOV DS,DX (ALLOW ACCESS TO STRING DATA) }
  43.        $8A/$0F/          { MOV CL,[BX] (GET S[0],LENGTH OF STRING) }
  44.        $30/$ED/          { XOR CH,CH   }
  45.        $31/$D2/          { XOR DX,DX   (SELECT LPT1) }
  46.        $43/              { INC BX      (POINT TO NEXT COMPONENT OF S) }
  47.        $8A/$07/          { MOV AL,[BX] (PUT NEXT CHARACTER IN AL) }
  48.        $30/$E4/          { XOR AH,AH   (SELECT FUNCTION 0) }
  49.        $CD/$17/          { INT $17     (BIOS PRINTER OUTPUT) }
  50.        $E2/$F7/          { LOOP -9     (GET NEXT CHARACTER) }
  51.        $1F);             { POP DS      (RESTORE DS REGISTER) }
  52.  
  53. procedure set_resolution(res : integer);
  54. { Sets 75,100,150, or 300 dpi resolution }
  55.  
  56.   var s : string;
  57.  
  58.   begin
  59.     s := ESC + '*t';
  60.     case res of
  61.       75 : s := s + '75';
  62.       100 : s := s + '100';
  63.       150 : s := s + '150';
  64.       300 : s := s + '300';
  65.     end;
  66.     s := s + 'R';
  67.     sendstring(s);
  68.   end;
  69.  
  70. procedure start_raster_graphics(number : integer);
  71. { Places the Laserjet into graphics mode, telling it how many bytes }
  72. { to expect and interpret as graphics                               }
  73.  
  74.   var s,dummy : string;
  75.  
  76.   begin
  77.     s := ESC + '*b';
  78.     str(number:0,dummy);
  79.     s := s + dummy + 'W';
  80.     sendstring(s);
  81.   end;
  82.  
  83. procedure end_raster_Graphics;
  84. { Print one line of graphics }
  85.  
  86.   var s : string;
  87.  
  88.   begin
  89.     s := ESC + '*rB';
  90.     sendstring(s);
  91.   end;
  92.  
  93. procedure dumpscreen;
  94. { Call this from main program.  You *must* be in graphics mode (note
  95.   the BGI calls or the program will abort with the familiar "Error: BGI
  96.   not initialized.  Use initgraph" message . }
  97.  
  98.   const   start_from_left : string = ESC + '*r0A';
  99.           move_vertically : string = ESC + '*p+2Y';
  100.  
  101.   label 100;
  102.  
  103.   var i,j,k : integer;
  104.       graphics : string;
  105.       sbyte : word;
  106.       temp : word;
  107.       view : viewporttype;
  108.       gdriver : string;
  109.       gmode : integer;
  110.  
  111. begin
  112.   abort := false;                    { Reset abort flag }
  113.   getviewsettings(view);             { Save current view settings for later }
  114.   setviewport(0,0,getmaxx,getmaxy,clipon);
  115.   gdriver := GetDriverName;           { Find graphics mode and driver }
  116.   gmode := getgraphmode;
  117.   { Set the size depending of how many horizontal pixels are present }
  118.   if ((gdriver = 'EGAVGA') and (gmode = 2)) or (gdriver = 'HERC')
  119.     then set_resolution(150) else set_resolution(100);
  120.   for i := 0 to getmaxx do begin
  121.     graphics := '';                     { Initialize graphics string }
  122.     for j := round(getmaxy / 8) downto 0 do begin
  123.       sbyte := 0;
  124.       for k := 7 downto 0 do begin
  125.         temp := getpixel(i,j shl 3 + k);
  126.         if temp <> 0 then begin
  127.           sbyte := sbyte + one shl (2 * k);
  128.           sbyte := sbyte + one shl (k * 2 + 1);
  129.         end;
  130.       end;
  131.       { Check for the Escape key for abort signal }
  132.       if keypressed then if readkey = #27 then goto 100;
  133.       graphics := graphics + char(hi(sbyte));
  134.       graphics := graphics + char(lo(sbyte));
  135.     end;
  136.     { Now pipe it out }
  137.     sendstring(start_from_left);
  138.     start_raster_graphics(length(graphics));
  139.     sendstring(graphics);
  140.     end_raster_graphics;
  141.     sendstring(move_vertically);
  142.   end;
  143.   100:
  144.   write(lst,#12);
  145.   with view do setviewport(x1,y1,x2,y2,clip);
  146. end;
  147.  
  148. end.