home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / DATABASE / MAIL32.LBR / MAIL.PQS / MAIL.PAS
Pascal/Delphi Source File  |  2000-06-30  |  16KB  |  594 lines
  1.  
  2. program mail_Version_3_2;
  3.  
  4.  
  5. var
  6.  
  7. FLAG3  , IOErr: boolean;
  8. KEY, ONO, CM, RE, RET, YN : char;
  9. REC, E1L, E2L, E3L, E4L, E5L, E6L, E7L : string[60];
  10. MAILFILE2,MAILFILE : file of string[60];
  11. NUM, X, COPY, OPT, OPTION, POPT, NOS, RECNO : integer;
  12.  
  13. const
  14.  A=#27;     { ESCAPE CODE  }
  15.  B=#112;     { HIGHLIGHT ON }
  16.  C=#113;     { HIGHLIGHT OFF}
  17.  D=#64;     { RESETS PRINTER TO POWER UP STATE }
  18.  E=#71;     { DOUBLESTRIKE MODE }
  19.  F=#8;     { PAPER END DETECTION OVERRIDDEN  }
  20.  G=#15;     { CONDENSED MODE  }
  21.  H=#87 ;     { ENLARGED MODE   }
  22.  I=#01;
  23.  J=#99;     { RESETS PRINTER TO CONTINUOUS SHEET**AMSTRAD PCW8512 }
  24.  K=#79;     { RESETS GAP LENGTH OF PAPER TO 0**AMSTRAD PCW8512}
  25.  
  26.  
  27.  
  28.  
  29. procedure Menu;
  30. begin
  31.      clrscr;
  32.      writeln('____________________MAILING_LABELS__________________');
  33.      writeln('                                         version 3.2');
  34.      writeln('                                         8th Jan 1987');
  35.      writeln('                               Mailing Label Program');
  36.      writeln; writeln; writeln; writeln; writeln; writeln; writeln; writeln;
  37.      writeln('                                                1986');
  38.      writeln('                                                  by');
  39.      writeln; writeln; writeln;
  40.      writeln('                                     J.FRANCIS & Co.');
  41.      writeln('                                   52 Chester Square');
  42.      writeln('                                   London,   England');
  43.      writeln('                                   SW1W 9EA');
  44.      writeln;
  45.      writeln('                   ',A ,B ,'Hit > RETURN <',A ,C);
  46.      readln(RET);
  47. end;
  48.  
  49.  
  50.  
  51. procedure Dwrite;
  52. begin
  53.      clrscr;
  54.      assign(MAILFILE,'MAILFILE.DAT');
  55.      reset(MAILFILE);
  56.      writeln(A,B,'     Please Wait while Writing to disk........',A,C);
  57.      seek(MAILFILE,Filesize(MAILFILE));
  58.      write(MAILFILE,E1L);
  59.      write(MAILFILE,E2L);
  60.      write(MAILFILE,E3L);
  61.      write(MAILFILE,E4L);
  62.      write(MAILFILE,E5L);
  63.      write(MAILFILE,E6L);
  64.      write(MAILFILE,E7L);
  65.      close(MAILFILE);
  66.  end;
  67.  
  68.  
  69. procedure Retr;
  70. begin
  71.      read(MAILFILE,E1L);
  72.      read(MAILFILE,E2L);
  73.      read(MAILFILE,E3L);
  74.      read(MAILFILE,E4L);
  75.      read(MAILFILE,E5L);
  76.      read(MAILFILE,E6L);
  77.      read(MAILFILE,E7L);
  78. end;
  79.  
  80.  
  81. procedure Oldfile;
  82. begin
  83.      clrscr;
  84.      gotoxy(10,10);
  85.      writeln('                ',A,B,'READING DATA FROM DISC......',A,C);
  86.      assign(MAILFILE,'MAILFILE.DAT');
  87.      reset(MAILFILE);
  88.      repeat
  89.      retr;
  90.      until eof(MAILFILE);
  91.      close(MAILFILE);
  92. end;
  93.  
  94.  
  95. procedure Disp1;
  96. begin
  97.      retr;
  98.      writeln(E1L);
  99. end;
  100.  
  101.  
  102. procedure Print;
  103. begin
  104.      writeln(Lst,A,F,A,J,A,K);
  105.      writeln(Lst,E1L);
  106.      writeln(Lst,E2L);
  107.      writeln(Lst,E3L);
  108.      writeln(Lst,E4L);
  109.      writeln(Lst,E5L);
  110.      writeln(Lst,E6L);
  111.      writeln(Lst,E7L);
  112.      writeln(Lst);
  113. end;
  114.  
  115. procedure Copies;
  116. begin
  117.      writeln;
  118.      write( A,B,'How many copies do you require ?'  ,A,C);Readln(Copy);
  119.      for X:=1 to Copy do
  120.      print;
  121. end;
  122.  
  123.  
  124. procedure Display;
  125. begin
  126.      clrscr;
  127.      assign(MAILFILE,'MAILFILE.DAT');
  128.      reset(MAILFILE);
  129. repeat
  130.      Disp1;
  131. until eof(MAILFILE);
  132.      close (MAILFILE);
  133.      writeln;
  134.      writeln('                ',A ,B ,'Hit CARRIAGE RETURN....',A ,C);
  135.      readln(RET);
  136. end;
  137.  
  138.  
  139. procedure Printall;
  140. begin
  141.      clrscr;
  142.      writeln('This program will print standard 102mm * 36mm labels ');
  143.      writeln;
  144.      writeln('The  print  out is spaced for a  printer setting  of');
  145.      writeln('6 lines  per  inch and  10 characters per inch. This');
  146.      writeln('is the default setting  of most dot matrix printers.');
  147.      writeln('If  you  wish to  set the  character  spacing  for a');
  148.      writeln('different value or for narrower labels, please leave');
  149.      writeln('a  message  in the bulletin board to Walter  Francis');
  150.      writeln;
  151.      writeln('                ',A,B,'PRESS CARRIAGE RETURN TO CONTINUE ',A ,C);
  152.      readln(RET);
  153.      clrscr;
  154.      gotoxy(12,20);
  155.      writeln(A,B,  '  P R I N T I N G !!!!!!!!',A,C);
  156.      assign(MAILFILE,'MAILFILE.DAT');
  157.      reset(MAILFILE);
  158. repeat
  159.      Retr;
  160.      writeln; writeln;
  161.      print;
  162. until eof(MAILFILE);
  163.      close(MAILFILE);
  164. end;
  165.  
  166.  
  167.  
  168.  
  169. procedure Quit;
  170. begin
  171. clrscr;
  172.      writeln;
  173.      writeln('           Hit > RETURN < to go Menu,');
  174.      writeln('           Hit >    Q   < to Quit to C/PM,');
  175.      writeln;
  176.      write(A,B,'OPTION >> ',A,C); read(kbd,RET);
  177. end;
  178.  
  179.  
  180.  
  181. procedure Quit2;
  182. begin
  183.      clrscr;
  184.      writeln(lst);
  185.      writeln;
  186.      writeln; writeln; writeln; writeln;
  187.      writeln('              C  return to C/PM');
  188.      writeln('      Any other key to  return to Menu');
  189.      write(A ,B ,'OPTION >> ',A ,C); read(kbd,CM);
  190.      CM:=upcase(CM);
  191.      if CM = 'C' then Quit;
  192.      if CM <> 'C' then
  193. end;
  194.  
  195.  
  196. procedure Clear;
  197. begin
  198.      writeln(lst,A ,D, 'Line 1. This is a ');
  199.      writeln(lst,      'Line 2. Test to   ');
  200.      writeln(lst,      'Line 3. Line up '  );
  201.      writeln(lst,      'Line 4. Your paper');
  202.      writeln(lst,      'Line 5. Ready for' );
  203.      writeln(lst,      'Line 6. Your final');
  204.      write(lst,        'Line 7. Printout !!');
  205. end;
  206.  
  207.  
  208.  
  209. procedure Doublestrike;
  210. begin
  211.      clear;
  212.      writeln(lst,A ,E );
  213.      Quit2;
  214. end;
  215.  
  216. procedure Condensed;
  217. begin
  218.      clear;
  219.      writeln(lst,A ,G );
  220.      Quit2;
  221. end;
  222.  
  223.  
  224. procedure Enlarged;
  225. begin
  226.      clear;
  227.      writeln(lst,A ,H ,I);
  228.      Quit2;
  229. end;
  230.  
  231.  
  232. procedure Draft;
  233. begin
  234.      clear;
  235.      writeln(lst,A,D);
  236.      Quit2;
  237. end;
  238.  
  239.  
  240. procedure Menu4;
  241. begin
  242.      clrscr;
  243.      writeln;
  244.      writeln;
  245.      writeln;
  246.      writeln('                         C = Clear printer buffer');
  247.      writeln('                         X = eXit to C/PM');
  248.      writeln('                         Q = Quit to Main Menu');
  249.      writeln('                         B = douBlestrike');
  250.      writeln('                         O = cOndensed');
  251.      writeln('                         E = Enlarged');
  252.      writeln('                         D = Draft');
  253.      writeln;
  254.      writeln;
  255.      writeln;
  256.      write(A ,B ,'OPTION >> ',A ,C); read(kbd,YN);
  257.      YN := upcase(YN);
  258.         if YN ='C' then Clear;
  259.         if YN ='X' then Quit;
  260.         if YN ='B' then Doublestrike;
  261.         if YN ='O' then Condensed;
  262.         if YN ='E' then Enlarged;
  263.         if YN ='D' then Draft;
  264.         if YN ='Q' then Quit;
  265. end;
  266.  
  267.  
  268.  
  269. procedure Save;
  270. begin
  271.      clrscr;
  272.      writeln(' Only Type ',A,B,'"Y"',A,C,'  to the next question if ');
  273.      writeln('        the data is ',A,B,' CORRECT !!!!!!!',A,C);
  274.      writeln;
  275.      write('             ',A,B,'Save data to disk (Y/N) ?',A,C);
  276.      writeln;writeln;
  277.      write(A ,B ,'OPTION >> ',A ,C); read(kbd,YN);
  278.      YN := upcase(YN);
  279.      if YN = 'Y' then Dwrite;
  280.      begin
  281.      end;
  282. end;
  283.  
  284.  
  285. procedure Append;
  286. begin
  287.      clrscr;
  288.      writeln('ENTER NAME AND ADDRESS, LINE BY LINE.');
  289.      writeln('            or            ');
  290.      writeln('TYPE ',A,B,'"END"',A,C,' in First Line  TO FINISH ENTRY');
  291.      writeln; writeln;
  292.      write('Enter First   Line........? '); readln(E1L);
  293.      if (E1L = 'END') or (E1L = 'end' ) then Quit;
  294.      if E1L <> 'END' then begin
  295.      if E1L <> 'end' then begin
  296.      write('Enter Second  Line........? '); readln(E2L);
  297.      write('Enter Third   Line........? '); readln(E3L);
  298.      write('Enter Fourth  Line........? '); readln(E4L);
  299.      write('Enter Fifth   Line........? '); readln(E5L);
  300.      write('Enter Sixth   Line........? '); readln(E6L);
  301.      write('Enter Seventh Line........? '); readln(E7L);
  302.      clrscr;
  303.      writeln; writeln;
  304.      writeln(A,B,'NAME AND ADDRESS IS.....',A,C);
  305.      writeln;
  306.      writeln(E1L);
  307.      writeln(E2L);
  308.      writeln(E3L);
  309.      writeln(E4L);
  310.      writeln(E5L);
  311.      writeln(E6L);
  312.      writeln(E7L);
  313.      writeln;
  314.      writeln(A,B,'IF  NAME  AND  ADDRESS  ARE  CORRECT  PRESS',A,C);
  315.      writeln('                      > RETURN <   To enter ');
  316.      readln(RET);
  317.      save;
  318.      end;
  319.      end;
  320. end;
  321.  
  322. procedure Erasure;
  323. begin
  324.      clrscr;
  325.      assign(MAILFILE,'MAILFILE.DAT');
  326.      rewrite(MAILFILE);
  327.      close(MAILFILE);
  328.      Append;
  329. end;
  330.  
  331.  
  332. procedure Newfile;
  333. begin
  334.      clrscr;
  335.      writeln; writeln; writeln;
  336.      writeln('NN     NN      OOOOOOO      TTTTTTTTTT     EEEEEEEE ');
  337.      writeln('NNN    NN     OOOOOOOOO     TTTTTTTTTT     EEEEEEEE ');
  338.      writeln('NNNN   NN     OO     OO         TT         EE       ');
  339.      writeln('NN NN  NN     OO     OO         TT         EEEEEEEE ');
  340.      writeln('NN  NNNNN     OO     OO         TT         EE       ');
  341.      writeln('NN   NNNN     OOOOOOOOO         TT         EEEEEEEE ');
  342.      writeln('NN    NNN      OOOOOOO          TT         EEEEEEEE ');
  343.      writeln; writeln;
  344.      writeln('THE INITIALISATION OF THE DATA FILE WILL ERASE');
  345.      writeln('           ALL EXISTING DATA');
  346.      writeln;
  347.      writeln; writeln(' DO YOU WISH TO CONTINUE Y/N ?');
  348.      write(A ,B ,'OPTION >> ',A ,C); read(kbd,YN);
  349.      YN := upcase(YN);
  350.      if YN = 'Y' then Erasure;
  351.      if YN <> 'Y' then Menu;
  352.      clrscr;
  353. end;
  354.  
  355.  
  356. procedure Menu3;
  357. begin
  358.      clrscr;
  359.      writeln; writeln;
  360.      writeln('THIS PROGRAM IS TO CREATE AND MAINTAIN A NAME AND ');
  361.      writeln;
  362.      writeln('ADDRESS FILE AND TO PRINT THE CONTENTS OF THE FILE');
  363.      writeln;
  364.      writeln('     IN A FORMAT SUITABLE FOR LABELS !   ');
  365.      writeln; writeln; writeln; writeln; writeln;
  366.      writeln('1. DO YOU WISH TO CREATE A NEW FILE       ?');
  367.      writeln;
  368.      writeln('2. DO YOU WISH TO ACCESS AN EXISTING FILE ?');
  369.      writeln; writeln;
  370.      writeln(A,B,'YOU MUST ANSWER AS QUESTION 1 ON YOUR FIRST ATTEMPT !!!!!',A,C);
  371.      writeln;writeln;
  372.      write(A ,B ,'OPTION >> ',A ,C); read(kbd,ONO);
  373.      ONO:=upcase(ONO);
  374.      if ONO = '1' then Newfile;
  375.      if ONO = '2' then Oldfile;
  376. end;
  377.  
  378.  
  379. procedure IOError;
  380. begin
  381.     Num:=0;
  382.     IOErr := false;
  383.     Num := IOresult;
  384.     IOErr := (Num <> 0);
  385.     if IOErr then
  386. begin
  387.       write(chr(7));
  388.       clrscr;
  389.       gotoxy(10,10);
  390.       case Num of
  391.       $99: write(REC,'  <:::::',A,B,'I N P U T   D A T A   I S  I N C O R R E C T',A,C);
  392.  end;
  393.       writeln;writeln;
  394.       writeln('          You Are Being Returned To The MAIN MENU !!!!!!!!!!!!!');
  395.       writeln('                 Type any key to continue..........');
  396.       read(kbd,Key);
  397.       assign(MAILFILE,'MAIL.COM');
  398.       execute(MAILFILE);
  399.       end;
  400. end;
  401.  
  402.  
  403. procedure Printone;
  404. begin
  405. {$I-}
  406.      assign(MAILFILE,'MAILFILE.DAT');
  407.      reset(MAILFILE);
  408.      clrscr;
  409. repeat
  410.      Disp1;
  411. until eof(MAILFILE);
  412.      close(MAILFILE);
  413.      writeln; writeln;
  414.      writeln(A ,B ,'Input FIRST LINE to Recognize:',A ,C);
  415.      writeln;
  416.      writeln('"FIRST LINE " data MUST be exactly as seen !!!!!');
  417.      writeln('                   ^^^^ ');
  418.      writeln;
  419.      readln(REC);
  420.      assign(MAILFILE,'MAILFILE.DAT');
  421.      reset(MAILFILE);
  422. repeat
  423. IOERROR;
  424.      read(MAILFILE,E1L);
  425.      read(MAILFILE,E2L);
  426.      read(MAILFILE,E3L);
  427.      read(MAILFILE,E4L);
  428.      read(MAILFILE,E5L);
  429.      read(MAILFILE,E6L);
  430.      read(MAILFILE,E7L);
  431.  until REC =E1L;
  432.  clrscr;
  433.      writeln; writeln;
  434.      writeln(A,B,'NAME AND ADDRESS SELECTED:-',A,C);
  435.      writeln; writeln;
  436.      writeln(E1L);
  437.      writeln(E2L);
  438.      writeln(E3L);
  439.      writeln(E4L);
  440.      writeln(E5L);
  441.      writeln(E6L);
  442.      writeln(E7L);
  443.      writeln; writeln;
  444.      writeln('ENTER OPTION REQUIRED');
  445.      writeln;
  446.      writeln('          1.  PRINT LABEL');
  447.      writeln('          2.  SELECT NEW NAME');
  448.      writeln('          3.  RETURN TO MAIN MENU');
  449.      writeln;
  450.      write(A ,B ,'OPTION >> ',A ,C); read(kbd,ONO);
  451.      ONO:= upcase(ONO);
  452.      if ONO = '1' then Copies ;
  453.      if ONO = '2' then Printone;
  454.      if ONO = '3' then
  455. {$I+}
  456. end;
  457.  
  458.  
  459. procedure Wrtmail2;
  460. begin
  461.      write(mailfile2,E1L);
  462.      write(mailfile2,E2L);
  463.      write(mailfile2,E3L);
  464.      write(mailfile2,E4L);
  465.      write(mailfile2,E5L);
  466.      write(mailfile2,E6L);
  467.      write(mailfile2,E7L);
  468. end;
  469.  
  470.  
  471.  
  472. procedure Remove;
  473. begin
  474. {$I-}
  475.      flag3:=false;
  476.      assign(MAILFILE,'MAILFILE.DAT');
  477.      reset(MAILFILE);
  478.      clrscr;
  479. repeat
  480.      Disp1;
  481. until eof(MAILFILE);
  482.      close(MAILFILE);
  483.      writeln; writeln;
  484.      writeln(A ,B ,'Input FIRST LINE to Recognize:',A ,C);
  485.      writeln;
  486.      writeln('"FIRST LINE " data MUST be exactly as seen !!!!!');
  487.      writeln('                   ^^^^ ');
  488.      writeln;
  489.      readln(REC);
  490.      assign(MAILFILE,'MAILFILE.DAT');
  491.      reset(MAILFILE);
  492. repeat
  493.      IOError;
  494.      read(MAILFILE,E1L);
  495.      read(MAILFILE,E2L);
  496.      read(MAILFILE,E3L);
  497.      read(MAILFILE,E4L);
  498.      read(MAILFILE,E5L);
  499.      read(MAILFILE,E6L);
  500.      read(MAILFILE,E7L);
  501. until REC = E1L ;
  502.      clrscr;
  503.      writeln; writeln;
  504.      writeln(A,B,'NAME AND ADDRESS SELECTED:-',A,C);
  505.      writeln; writeln;
  506.      writeln(E1L);
  507.      writeln(E2L);
  508.      writeln(E3L);
  509.      writeln(E4L);
  510.      writeln(E5L);
  511.      writeln(E6L);
  512.      writeln(E7L);
  513.      close(MAILFILE);
  514.      writeln; writeln;
  515.      writeln('ENTER OPTION REQUIRED');
  516.      writeln;
  517.      writeln('          1.  DELETE RECORD THIS RECORD ?');
  518.      writeln('          2.  RETURN TO MAIN MENU');
  519.      writeln;
  520.      write(A ,B ,'OPTION >> ',A ,C); read(kbd,ONO);
  521.      ONO:= upcase(ONO);
  522.      if ONO = '1' then flag3 := true;
  523.      if flag3 then
  524. begin
  525.      assign( MAILFILE,'MAILFILE.DAT');
  526.      reset (mailfile);
  527.      assign(mailfile2,'mailfile.tmp');
  528.      rewrite(mailfile2);
  529. repeat
  530.      read(MAILFILE,E1L);
  531.      read(MAILFILE,E2L);
  532.      read(MAILFILE,E3L);
  533.      read(MAILFILE,E4L);
  534.      read(MAILFILE,E5L);
  535.      read(MAILFILE,E6L);
  536.      read(MAILFILE,E7L);
  537.     seek(mailfile2,filesize(mailfile2));
  538. if REC <> E1L then
  539.      Wrtmail2;
  540.     until eof(mailfile);
  541. close(mailfile);
  542. close(mailfile2);
  543.      erase(mailfile);
  544.      rename(mailfile2,'mailfile.dat');
  545. end;
  546. {$I+}
  547. end;
  548.  
  549.  
  550. procedure Menu2;
  551. begin
  552.      clrscr;
  553.      writeln('____________________MAILING_LABELS_________________');
  554.      writeln('                                        version 3.2');
  555.      writeln;
  556.      writeln; writeln; writeln; writeln;
  557.      writeln('DO YOU WISH TO ');
  558.      writeln('      1.  INPUT MORE NAMES     ?     ',A ,B ,'EDITORS',A ,C);
  559.      writeln('      2.  PRINT OUT ALL LABELS ?     Walter Francis');
  560.      writeln('      3.  PRINT OUT ONE LABEL  ?     Jules  Francis');
  561.      writeln('      4.  DISPLAY ALL DATA     ?');
  562.      writeln('      5.  CHANGE FONT          ?');
  563.      writeln('      6.  ERASE ALL DATA       ?     ',A ,B ,'PROGRAMMER',A ,C);
  564.      writeln('      7.  EXIT TO C/PM         ?     Jules Francis');
  565.      writeln('      8.  DELETE a RECORD      ?');
  566.      writeln;
  567.      writeln('                                     ',A ,B ,'ENHANCER &',A ,C);
  568.      writeln('                                     ',A ,B ,'DEBUGGER',A ,C);
  569.      writeln('                                     Walter Francis');
  570.      write(A ,B ,'OPTION >> ',A ,C); read(kbd,ONO);
  571.      ONO:=upcase(ONO);
  572.      writeln;
  573.      if ONO = '1' then Append;
  574.      if ONO = '2' then Printall;
  575.      if ONO = '3' then Printone;
  576.      if ONO = '4' then Display;
  577.      if ONO = '5' then Menu4;
  578.      if ONO = '6' then Newfile;
  579.      if ONO = '7' then Quit;
  580.      if ONO = '8' then Remove;
  581. end;
  582.  
  583.  
  584.  
  585. begin
  586.      Menu;
  587.      Menu3;
  588. repeat Menu2;
  589. until upcase(RET) in ['Q'] ;
  590.      clrscr;
  591.     gotoxy(1,15);
  592.      writeln('Exiting.............................................BYE For Now Folks!.');
  593.      writeln(lst,A,D);
  594. end.