home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / GRAPHICS / MISC / POSTOGRF.ZIP / OPENPRT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-06-06  |  3.7 KB  |  106 lines
  1. { procedure OpenPrtFile
  2.      for use with LIPSogrf/POSTogrf.
  3.      Written by Thomas B. Passin in TurboPascal 5.0.
  4.      Opens file for output.
  5.    v1.2 17 Apr 89.  Removed setting Statcode to #0 if ESC was pressed.
  6.      Calling program will now figure out what to do.
  7.    v1.1  15 Sept 88.
  8.    v1.2 17 Feb 89.  Added clrEOL to exit when filename = ''.  Deleted
  9.       reversing colors if in graphics mode. NOTE: this depends on the
  10.       using program setting DirectVideo to false.
  11.    v1.3  4 Ap 89.  Now doesn't ask for comfirmation for output filenames
  12.       of con, com1, com2, lpt1, lpt2, prn}
  13. (*{$DEFINE testprt}*)
  14. {$IFDEF testprt}
  15. uses CRT;
  16. {$ENDIF}
  17. {$IFNDEF strings}
  18. {$I strings.src}
  19. {$ENDIF}
  20.  
  21. Procedure OpenPrtFile(var outfile:text; var name:string80; default:string80;
  22.           var statcode:char);
  23. const SP = #32;
  24. var error, t1, t2, i :integer;  ans:char; s1:string80;
  25.     addon : boolean;
  26.  
  27. begin {OpenPrtFile}
  28.   name := '####';
  29.   repeat
  30.      GoTOXY(1,wherey);
  31.      ReadRaw(s1,'output filename? ', default );
  32.      case s1[1] of
  33.           CR: Name := default;
  34.           SP, ESC: begin GoToXY(1,wherey); clrEOL; Name := ''; end;
  35.      else Name := s1;
  36.      end; {case}
  37.      if Name = ''
  38.      then begin
  39.             if s1[1] <> ESC then statcode := #0
  40.             else statcode := ESC;
  41.             clrEOL; exit;
  42.            end  { exit code for MAIN }
  43.      else begin
  44.                Assign(outfile, name);
  45.                {$I-} Reset(outfile); {$I+}
  46.                error := IOResult;
  47.                if error <> 0 { couldn't open existing file }
  48.                then begin
  49.                        {$I-} rewrite(outfile); {$I+} (* it's a new file *)
  50.                        error := IOResult;
  51.                        If error = 0
  52.                        then (* opened it *)
  53.                        else begin
  54.                                GoToXY(1,wherey);
  55.                                writeln('couldn''t open file ', name);
  56.                                clreol;
  57.                                name := '####';
  58.                              end
  59.                     end
  60.                 else begin  { did open existing file }
  61.                        Close(outfile);
  62.                        GoToXY(1,wherey); clreol;
  63.  
  64.                        s1 := prtfilename;
  65.                        for i := 1 to length(s1) do
  66.                            s1[i] := upcase(s1[i]);
  67.                        if (s1 = 'COM1') or (s1 = 'COM2')
  68.                           or (s1 = 'LPT1') or (s1 = 'LPT2')
  69.                           or (s1 = 'PRN')
  70.                        then ans := 'y'
  71.                        ELSE begin
  72.                           GoToXY(1,1); clreol;
  73.                           write(PrtFileName, ' exists - replace it (y/n)? ');
  74.                                ans := Readkey; write(ans);
  75.                             end; {else}
  76.                        If ans in Yes then ReWrite(outfile)
  77.                        else begin
  78.                                name := '####';
  79.                             end;
  80.                     end;
  81.         end;
  82.     until name <> '####';
  83.  
  84.     statcode := CR;         { needed for MAIN to decide correct exit }
  85. end;
  86.  
  87. Procedure ClosePrtFile(var outfile:text; name:string80);
  88. begin
  89.      if name = '' then exit else
  90.      Close(outfile);
  91. end;
  92.  
  93.  
  94. { -------------------------------------------------------------------
  95.              main program fragment for testing
  96.   ------------------------------------------------------------------- }
  97. (*
  98. const default = 'd:zzz';
  99. var fil:text; name:string80; status:char;
  100. begin
  101.      write('open file: ');
  102.      OpenPrtfile(fil, name, default, status);
  103.      if status = CR then close(fil);
  104.      if name <> ESC then writeln('that filename was: ', name);
  105. end.*)
  106.