home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 10 / titel / hardcopy.pas next >
Encoding:
Pascal/Delphi Source File  |  1989-07-26  |  7.1 KB  |  257 lines
  1. (* ------------------------------------------------- *)
  2. (*                HARDCOPY.PAS                       *)
  3. (*            HARDCOPY-Bibliothek                    *)
  4. (*  (C) 1989 by W. Amslinger, P. Kurzweil & TOOLBOX  *)
  5. (* ------------------------------------------------- *)
  6.  
  7. UNIT HardcopyBib;
  8.  
  9. INTERFACE
  10.  
  11. USES Dos, Crt, Printer, Graph;
  12.  
  13. TYPE
  14.   strg255 = STRING[255];
  15. VAR
  16.   Regs : Registers;
  17.  
  18. PROCEDURE HardCopyOn;
  19.                  { Methode1: Aktiviert [SHIFT PrtScr] }
  20. PROCEDURE HardCopyOff;
  21.                         { Desaktiviert [SHIFT PrtScr] }
  22. PROCEDURE TestHardCopy;
  23.                { Methode2: Hardcopy mit anderer Taste }
  24.  
  25. IMPLEMENTATION
  26.  
  27. CONST
  28.   LPT = 1;
  29.        { Schnittstelle 1 = LPT1:, 2 = LPT2:, 3 = LPT: }
  30. VAR
  31.   OldVec, NewVec : POINTER;
  32.   error, active  : BOOLEAN;
  33.  
  34.   PROCEDURE PrintByte(ch : CHAR);
  35.          { Zeichen auf Parallelschnittstelle ausgeben }
  36.   VAR
  37.     status : BYTE;
  38.          i : WORD;
  39.   BEGIN
  40.     error := FALSE; i := 0;
  41.     REPEAT
  42.       i := Succ(i);                  { Printer status }
  43.       Regs.ah := $02;
  44.       Regs.dx := LPT - 1;
  45.       Intr($17, Regs);
  46.       status := Regs.ah;
  47.       error := ((status AND $29) > 0);     { 00101001 }
  48.       IF i > 20000 THEN BEGIN
  49.         error := TRUE;
  50.         Exit;
  51.       END;                                  { Timeout }
  52.     UNTIL ((status AND $90) XOR $90) = 0;
  53.     Regs.ah := $00;
  54.     Regs.dx := LPT - 1;
  55.     Regs.al := Ord(ch);                 { Byte senden }
  56.     Intr($17, Regs);
  57.   END;
  58.  
  59.   PROCEDURE PrintString(s : strg255);
  60.           { String auf Parallelschnittstelle ausgeben }
  61.   VAR
  62.     i : INTEGER;
  63.   BEGIN
  64.     error := FALSE;
  65.     FOR i := 1 TO Length(s) DO BEGIN
  66.       PrintByte(s[i]);
  67.       IF error THEN Exit;
  68.     END;
  69.   END;
  70.  
  71.   PROCEDURE HGChardCopy;
  72.   LABEL 1;
  73.   CONST
  74.     xres = 720; yres = 348;
  75.     p : ARRAY[0..7] OF BYTE = (128,64,32,16,8,4,2,1);
  76.   VAR
  77.     x, y, i, j, n1, n2 : INTEGER;
  78.     v, b, d            : BYTE;
  79.   BEGIN
  80.     PrintString(#27#64);
  81.     IF error THEN GOTO 1;             { ESC @ = reset }
  82.     PrintString(#27#85#49);
  83.     IF error THEN GOTO 1;  { ESC U 1 = unidirectional }
  84.     PrintString(#27#51#21);
  85.     IF error THEN GOTO 1;    { ESC 3 21 = 21/216 Zoll }
  86.     n2 := xres DIV 256;
  87.     n1 := xres MOD 256;
  88.     FOR i:= 0 TO Pred(yres DIV 8) DO BEGIN
  89.       PrintString(#9#27#76 + Chr(n1) + Chr(n2));
  90.       IF error THEN GOTO 1;
  91.       FOR x := 0 TO Pred(xres) DO BEGIN
  92.         b := x MOD 8;
  93.         d := 0;
  94.         FOR j := 0 TO 7 DO BEGIN
  95.           y := i * 8 + j;
  96.           v := Mem[$B000:$2000 * (y MOD 4) +
  97.                            90 * (y SHR 2) + (x SHR 3)];
  98.           IF (v AND p[b]) > 0 THEN d := d + p[j];
  99.         END;
  100.         PrintString(Chr(d));
  101.         IF error THEN GOTO 1;
  102.       END;
  103.       PrintString(#13#10);
  104.       IF error THEN GOTO 1;
  105.     END;
  106.     IF (yres MOD 8) <> 0 THEN BEGIN    { letzte Zeile }
  107.       PrintString(#9#27#76 + Chr(n1) + Chr(n2));
  108.       IF error THEN GOTO 1;
  109.       FOR x := 0 TO Pred(xres) DO BEGIN
  110.         b := x MOD 8;
  111.         d := 0;
  112.         FOR y := 8*(yres DIV 8) TO Pred(yres) DO BEGIN
  113.           v := Mem[$B000:$2000 * (y MOD 4) +
  114.                            90 * (y SHR 2) + (x SHR 3)];
  115.           IF (v AND p[b]) > 0 THEN d := d + p[y MOD 8];
  116.         END;
  117.         PrintString(Chr(d));
  118.       IF error THEN GOTO 1;
  119.     END;
  120.     PrintString(#13#10);
  121.     IF error THEN GOTO 1;
  122.   END;
  123.   PrintString(#27#65#12#27#50);
  124.   IF error THEN GOTO 1;                 { 12/72" Zoll }
  125.   PrintString(#27#85#48);
  126.   IF error THEN GOTO 1;    { ESC U 0 = unidirect. off }
  127.   PrintString(#27#64);                        { Reset }
  128. 1:
  129.   END;
  130.  
  131.   PROCEDURE IBMHardCopy;
  132.   LABEL 9;
  133.   CONST
  134.     p : ARRAY[0..7] OF BYTE = (128,64,32,16,8,4,2,1);
  135.   VAR
  136.     modus, page, d                 : BYTE;
  137.     x, y, i, j, n1, n2, xres, yres : WORD;
  138.   BEGIN
  139.     Regs.ah := $0F;
  140.     Intr($10, Regs);
  141.     modus := Regs.al;
  142.     page := Regs.bh;
  143.     CASE modus OF
  144.       $04, $05, $0d, $13 : BEGIN
  145.                              xres := 320; yres := 200;
  146.                            END;
  147.       $06, $0E           : BEGIN
  148.                              xres := 640; yres := 200;
  149.                            END;
  150.       $40, $48           : BEGIN
  151.                              xres := 640; yres := 400;
  152.                            END;
  153.       $0F, $10, $2d      : BEGIN
  154.                              xres := 640; yres := 350;
  155.                            END;
  156.       $11, $12, $25, $2E : BEGIN
  157.                              xres := 640; yres := 480;
  158.                            END;
  159.       $29, $30           : BEGIN
  160.                              xres := 800; yres := 600;
  161.                            END;
  162.     END;
  163.     n2 := xres DIV 256;
  164.     n1 := xres MOD 256;
  165.     PrintString(#27#64);
  166.     IF error THEN GOTO 9;             { ESC @ = reset }
  167.     PrintString(#27#85#49);
  168.     IF error THEN GOTO 9;  { ESC U 1 = unidirectional }
  169.     PrintString(#27#51#21);
  170.     IF error THEN GOTO 9;    { ESC 3 21 = 21/216 Zoll }
  171.     FOR i := 0 TO (yres DIV 8) DO BEGIN
  172.       PrintString(#9#27#76 + Chr(n1) + Chr(n2));
  173.       IF error THEN GOTO 9;   { TAB ESC L }
  174.       FOR x := 0 TO Pred(xres) DO BEGIN
  175.         d := 0;
  176.         FOR j := 0 TO 7 DO BEGIN
  177.           y := i * 8 + j;
  178.           Regs.ah := $0d;
  179.           Regs.bh := page;
  180.           Regs.cx := x;
  181.           Regs.dx := y;
  182.           Intr($10, Regs);
  183.           IF Regs.al > 0 THEN d := d + p[j];
  184.         END;
  185.         PrintString(Chr(d));
  186.         IF error THEN GOTO 9;
  187.       END;
  188.       PrintString(#13#10);
  189.       IF error THEN GOTO 9;
  190.     END;
  191.     PrintString(#27#65#12#27#50);
  192.     IF error THEN GOTO 9;               { 12/72" Zoll }
  193.     PrintString(#27#85#48);
  194.     IF error THEN GOTO 9;  { ESC U 0 = unidirect. off }
  195.     PrintString(#27#64);                      { Reset }
  196. 9:
  197.   END;
  198.  
  199. {$F+}
  200.   PROCEDURE HardCopy; INTERRUPT;
  201.                          { Aufruf über [SHIFT PrtScr] }
  202.   BEGIN
  203.     IF NOT active THEN BEGIN
  204.       active := TRUE;
  205.       error := FALSE;
  206.       IF ((GetMaxX = 719) AND (GetMaxY = 347)) THEN
  207.         HGCHardCopy
  208.       ELSE
  209.         IBMHardCopy;
  210.       IF error THEN Write(#7#7#7);
  211.       active := FALSE;
  212.     END;
  213.   END;
  214. {$F-}
  215.  
  216.   PROCEDURE HardCopyOn;
  217.                      { Aktiviert [SHIFT PrtScr]-Taste }
  218.   BEGIN
  219.     NewVec := @HardCopy;
  220.               { Interrupt 5 startet Prozedur Hardcopy }
  221.     GetIntVec($5, OldVec);
  222.     SetIntVec($5, NewVec);
  223.     active := FALSE;
  224.   END;
  225.  
  226. {$F+}
  227.   PROCEDURE HardCopyOff;
  228.                    { Deaktiviert [SHIFT PrtScr]-Taste }
  229.   BEGIN
  230.     SetIntVec($5, OldVec);
  231.   END;
  232. {$F-}
  233.  
  234.   PROCEDURE TestHardCopy;
  235.                       { Löst Hardcopy mit *-Taste aus }
  236.   VAR
  237.     ch : CHAR;
  238.   BEGIN
  239.     REPEAT
  240.       ch := ReadKey;
  241.       IF ch = '*' THEN BEGIN
  242.         IF ((GetMaxX = 719) AND (GetMaxY = 347)) THEN
  243.           HGChardcopy
  244.         ELSE
  245.           IBMhardcopy;
  246.         IF error THEN BEGIN
  247.           Write(#7#7#7);
  248.           Exit;
  249.         END;
  250.       END;
  251.     UNTIL ch IN ['*',#27,#13];
  252.                         { ESC oder RETURN -> Abbrechen }
  253.   END;
  254.  
  255. END.
  256. (* ------------------------------------------------------ *)
  257. (*                Ende von HARDCOPY.PAS                   *)