home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / ifp1s157 / ifpscrpt.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-06-25  |  10.1 KB  |  410 lines
  1. unit IFPScrpt;
  2.  
  3. interface
  4.  
  5. uses Crt, Dos, IFPGlobl, IFPComon;
  6.  
  7. type
  8.   TPrinterRec = record
  9.                   Mode: char;
  10.                   Destination: char;
  11.                   Filename: PathStr;
  12.                   HiStrip: boolean;
  13.                   HeaderStr: string;
  14.                   ScreensPerPage: byte;
  15.                   ScreenCount: byte;
  16.                 end;
  17.  
  18. var
  19.   PrinterRec: TPrinterRec;
  20.  
  21. procedure ScreenPrint(Pg: byte; PgName, VerNum: string);
  22.  
  23. implementation
  24.  
  25. const
  26.   ESC = #27;
  27.  
  28. type
  29.   CharSet = set of char;
  30.  
  31. function GetKey(CS: CharSet): char;
  32.   var
  33.     c, x: char;
  34.  
  35.   begin
  36.   repeat
  37.     C:=UpCase(ReadKey);
  38.     if KeyPressed and (c = #0) then
  39.       x:=ReadKey;
  40.   until c in CS;
  41.   if Ord(c) > 31 then
  42.     Writeln(c);
  43.   GetKey:=c
  44.   end;
  45.  
  46. function Today: string;
  47.   const
  48.     DOWName: array[0..6] of string[3] = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu',
  49.                                          'Fri', 'Sat');
  50.     MonthName: array[1..12] of string[3] = ('Jan', 'Feb', 'Mar', 'Apr', 'May',
  51.                                             'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
  52.                                             'Nov', 'Dec');
  53.   var
  54.     Regs: Registers;
  55.     DayForm, Year, Month, Day, DOW: word;
  56.     YearStr, DayStr: string[5];
  57.     CInfo: array[0..$21] of byte;
  58.     temp: string;
  59.  
  60.   begin
  61.   GetDate(Year, Month, Day, DOW);
  62.   with Regs do
  63.     begin
  64.     AH:=$38;
  65.     AL:=0;
  66.     DS:=Seg(CInfo);
  67.     DX:=Ofs(CInfo);
  68.     MsDos(Regs);
  69.     Dayform:=CInfo[0] + (word(256) * CInfo[1]);
  70.     end;
  71.   Str(Day, Daystr);
  72.   Str(Year, Yearstr);
  73.   case DayForm of
  74.     0,3..$FFFF: temp:=Monthname[Month] + ' ' + DayStr + ', ' + YearStr;
  75.     1: temp:=DayStr + ' ' + Monthname[Month] + ', ' + YearStr;
  76.     2: temp:=YearStr + ' ' + Monthname[Month] + ' ' + DayStr;
  77.   end;
  78.   Today:=DOWName[DOW] + ', ' + temp
  79.   end; {Today}
  80.  
  81. function Time: string;
  82.   var
  83.     Regs: Registers;
  84.     Hour, Min, Sec, sec100: word;
  85.     HourStr, MinStr, SecStr: string[2];
  86.     Cinfo: array[0..$21] of byte;
  87.     TForm: byte;
  88.     TSep: char;
  89.     temp: string[11];
  90.  
  91.   begin
  92.   GetTime(Hour, Min, Sec, Sec100);
  93.   with Regs do
  94.     begin
  95.     AH:=$38;
  96.     AL:=0;
  97.     DS:=Seg(CInfo);
  98.     DX:=Ofs(CInfo);
  99.     MsDos(Regs);
  100.     TForm:=CInfo[$11];
  101.     TSep:=Chr(CInfo[$D]);
  102.     end;
  103.   Str(Hour, HourStr);
  104.   if (Hour > 12) and (TForm and 1 = 0) then
  105.     Str(Hour - 12, HourStr);
  106.   if (Hour = 0) and (TForm and 1 = 0) then
  107.      HourStr:='12';
  108.   Str(Min, MinStr);
  109.   if Length(MinStr) = 1 then
  110.     MinStr:='0' + MinStr;
  111.   Str(Sec, Secstr);
  112.   if Length(SecStr) = 1 then
  113.     SecStr:='0' + SecStr;
  114.   temp:=HourStr + TSep + MinStr + TSep + SecStr;
  115.   if (TForm and 1 = 0) then
  116.     if Hour > 11 then
  117.       temp:=temp + ' pm'
  118.     else
  119.       temp:=temp + ' am';
  120.   Time:=temp
  121.   end; {Time}
  122.  
  123. procedure ScreenPrint(Pg: byte; PgName, VerNum: string);
  124.   const
  125.     LoChars: array[#0..#$1F] of char = ' abcdefghijklmno' +
  126.                                        'pqrstuvwxyz<+>^v';
  127.  
  128.     HiChars: array[#$80..#$FF] of char = 'cueaaaaceeeiiiAA' +
  129.                                   {90h}  'EaAooouuyOUcLYPf' +
  130.                                   {A0h}  'aiounNao?++24i<>' +
  131.                                   {B0h}  '.oO|++++++|+++++' +
  132.                                   {C0h}  '++++-++++++++-++' +
  133.                                   {D0h}  '++++++++++++_||~' +
  134.                                   {E0h}  'aBr#Eout00^o80EU' +
  135.                                   {F0h}  '=+><fj-~oOojn2O ';
  136.     Dashes: string[79] = '----------------------------------------' +
  137.                          '---------------------------------------';
  138.  
  139.   var
  140.     ScrBuf: array[0..9599] of char;
  141.     VidMode, VidLength, VidPg, OldAttr, OldX, OldY: byte;
  142.     VidSize, Position, VidWidth, x, y, BytesPerLine, BytesPerScreen, CharCount, first, last: word;
  143.     OldWindMin, OldWindMax: word;
  144.     Regs: Registers;
  145.     OutFile: text;
  146.     FileName: PathStr;
  147.     MonoScrn: array[0..3999] of char absolute $B000:0;
  148.     ColorScrn: array[0..9599] of char absolute $B800:0;
  149.     c: char;
  150.     StripHi: boolean;
  151.     ExtraStr: string;
  152.     FirstRun: boolean;
  153.     SingleScreen: boolean;
  154.  
  155.   procedure Cleanup;
  156.     var
  157.       x, y: word;
  158.  
  159.     begin
  160.     Position:=0;
  161.     if DirectVideo then
  162.       if VidMode = 7 then
  163.         Move(ScrBuf, MonoScrn, VidSize)
  164.       else
  165.         Move(ScrBuf, ColorScrn, VidSize)
  166.     else
  167.       for y:=0 to VidLength - 1 do
  168.         for x:=0 to VidWidth -1 do
  169.           with Regs do
  170.             begin
  171.             AH:=2;
  172.             BH:=VidPg;
  173.             DH:=y;
  174.             DL:=x;
  175.             Intr($10, Regs);
  176.             AH:=9;
  177.             AL:=Ord(ScrBuf[Position]);
  178.             BH:=VidPg;
  179.             BL:=Ord(ScrBuf[Position + 1]);
  180.             CX:=1;
  181.             Intr($10, Regs);
  182.             Inc(Position, 2);
  183.             end;
  184.     TextAttr:=OldAttr;
  185.     WindMin:=OldWindMin;
  186.     WindMax:=OldWindMax;
  187.     GotoXY(OldX, OldY);
  188.     end;
  189.  
  190.   begin
  191.   if (PrinterRec.Mode = 'A') and (PrinterRec.Destination = '?') then
  192.     FirstRun:=true
  193.   else
  194.     FirstRun:=false;
  195.   if PrinterRec.Mode <> 'A' then
  196.     SingleScreen:=true
  197.   else
  198.     SingleScreen:=false;
  199.   OldAttr:=TextAttr;
  200.   OldWindMin:=WindMin;
  201.   OldWindMax:=WindMax;
  202.   OldX:=WhereX;
  203.   OldY:=WhereY;
  204.   ModeInfo(VidMode, VidLength, VidPg, VidWidth);
  205.   VidSize:=(VidWidth * VidLength) * 2;
  206.   Position:=0;
  207.   if DirectVideo then
  208.     if VidMode = 7 then
  209.       Move(MonoScrn, ScrBuf, VidSize)
  210.     else
  211.       Move(ColorScrn, ScrBuf, VidSize)
  212.   else
  213.     for y:=0 to VidLength - 1 do
  214.       for x:=0 to VidWidth - 1 do
  215.         with Regs do
  216.           begin
  217.           AH:=2;
  218.           BH:=VidPg;
  219.           DH:=y;
  220.           DL:=x;
  221.           Intr($10, Regs);
  222.           AH:=8;
  223.           BH:=VidPg;
  224.           Intr($10, Regs);
  225.           ScrBuf[Position]:=Chr(AL);
  226.           ScrBuf[Position + 1]:=Chr(AH);
  227.           Inc(Position, 2);
  228.           end;
  229.   if FirstRun or SingleScreen then
  230.     begin
  231.     TextColor(White);
  232.     TextBackground(Blue);
  233.     Window(5, (VidLength div 2) - 5, 75, (VidLength div 2) + 5);
  234.     box;
  235.     TextBackground(LightGray);
  236.     TextColor(Black);
  237.     ClrScr;
  238.     Write('Dump screen to a <F>ile or the <P>rinter.=>');
  239.     c:=GetKey([ESC, 'F', 'P']);
  240.     if c = ESC then
  241.       begin
  242.       Cleanup;
  243.       PrinterRec.Mode:='S';
  244.       Exit
  245.       end;
  246.     end
  247.   else
  248.     c:=PrinterRec.Destination;
  249.   if c = 'P' then
  250.     begin
  251.     Assign(OutFile, 'PRN');
  252.     ReWrite(OutFile);
  253.     if not SingleScreen then
  254.       PrinterRec.Destination:='P'
  255.     end
  256.   else
  257.     begin
  258.     if FirstRun or SingleScreen then
  259.       begin
  260.       Write('Filename to use.=>');
  261.       Readln(FileName);
  262.       if FileName = '' then
  263.         begin
  264.         Cleanup;
  265.         Exit
  266.         end;
  267.       end
  268.     else
  269.       FileName:=PrinterRec.Filename;
  270.     FileName:=FExpand(FileName);
  271.     Assign(OutFile, FileName);
  272.     {$I-} Reset(OutFile); {$I+}
  273.     if IOResult = 0 then
  274.       begin
  275.       if FirstRun or SingleScreen then
  276.         begin
  277.         Write(FileName, ' exists! <O>verwrite, <A>ppend, <Q>uit.=>');
  278.         c:=GetKey([ESC, 'O', 'A', 'Q']);
  279.         end
  280.       else
  281.         c:='A';
  282.       case c of
  283.         ESC, 'Q': begin
  284.                   Close(OutFile);
  285.                   Cleanup;
  286.                   PrinterRec.Mode:='S';
  287.                   Exit
  288.                   end;
  289.         'A': begin
  290.              Close(OutFile);
  291.              Append(OutFile)
  292.              end;
  293.         'O': begin
  294.              Close(OutFile);
  295.              ReWrite(OutFile)
  296.              end
  297.       end
  298.       end
  299.     else
  300.       ReWrite(OutFile);
  301.     if not SingleScreen then
  302.       PrinterRec.Destination:='F';
  303.     if FirstRun then
  304.       PrinterRec.Filename:=FileName;
  305.     end;
  306.   if SingleScreen or FirstRun then
  307.     begin
  308.     Write('<N>ormal ASCII or <I>BM ASCII.=>');
  309.     c:=GetKey([ESC, 'N', 'I']);
  310.     if c = ESC then
  311.       begin
  312.       Cleanup;
  313.       PrinterRec.Mode:='S';
  314.       Exit
  315.       end;
  316.     if c = 'N' then
  317.       StripHi:=true
  318.     else
  319.       StripHi:=false;
  320.     if FirstRun then
  321.       PrinterRec.HiStrip:=StripHi;
  322.     end
  323.   else
  324.     StripHi:=PrinterRec.HiStrip;
  325.   if FirstRun or SingleScreen then
  326.     begin
  327.     Write('Do you wish to add an extra header line? <Y> or <N>.=>');
  328.     c:=GetKey([ESC, 'Y', 'N']);
  329.     if c = ESC then
  330.       begin
  331.       Cleanup;
  332.       PrinterRec.Mode:='S';
  333.       Exit
  334.       end;
  335.     ExtraStr:='';
  336.     if c = 'Y' then
  337.       begin
  338.       Write('Header>');
  339.       Readln(ExtraStr);
  340.       if FirstRun then
  341.         PrinterRec.HeaderStr:=ExtraStr;
  342.       end;
  343.     end
  344.   else
  345.     ExtraStr:=PrinterRec.HeaderStr;
  346.   if FirstRun then
  347.       begin
  348.       Write('Number of Screens per page (0=no form feed).=> ');
  349.       Readln(PrinterRec.ScreensPerPage);
  350.       end;
  351.   BytesPerLine:=VidWidth * 2;
  352.   BytesPerScreen:=BytesPerLine * VidLength;
  353.   {0 is top, print from line 2 to VidLength-2}
  354.   CharCount:=0;
  355.   first:=BytesPerLine * 2;
  356.   last:=BytesPerScreen - (BytesPerLine * 2) - 1;
  357.   Writeln(OutFile, Dashes);
  358.   if Length(ExtraStr) > 0 then
  359.     Writeln(OutFile, ExtraStr);
  360.   Writeln(OutFile, 'Infoplus ', VerNum, '   Page ', Pg, ' - ', PgName);
  361.   Writeln(OutFile, 'Generated: ', Today, ' at ', Time);
  362.   Writeln(OutFile, Dashes);
  363.   x:=first;
  364.   repeat
  365.     c:=ScrBuf[x];
  366.     if Ord(c) < 31 then
  367.       c:=LoChars[c];
  368.     if StripHi and (Ord(c) > 127) then
  369.       c:=HiChars[c];
  370.     Write(OutFile, c);
  371.     Inc(CharCount);
  372.     if CharCount = 80 then
  373.       begin
  374.       Writeln(OutFile);
  375.       CharCount:=0;
  376.       end;
  377.     Inc(x, 2);
  378.   until x >= last;
  379.   Writeln(OutFile);
  380.   if not SingleScreen then
  381.     with PrinterRec do
  382.       begin
  383.       if ScreensPerPage <> 0 then
  384.         Inc(ScreenCount);
  385.       if (ScreenCount < ScreensPerPage) or (ScreensPerPage = 0) then
  386.         Writeln(OutFile)
  387.       else
  388.         begin
  389.         Writeln(OutFile, ^L);
  390.         ScreenCount:=0;
  391.         end
  392.       end
  393.   else
  394.     Writeln(OutFile, ^L);
  395.   Close(OutFile);
  396.   Cleanup;
  397.   end;
  398.  
  399. begin
  400. with PrinterRec do
  401.   begin
  402.   Mode:='S';
  403.   Destination:='?';
  404.   Filename:='';
  405.   HiStrip:=true;
  406.   HeaderStr:='';
  407.   ScreensPerPage:=2;
  408.   ScreenCount:=0;
  409.   end;
  410. end.