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 / PROGRAMS / LIST / LBLMKR4.LBR / LBLMKR4.PZS / LBLMKR4.PAS
Pascal/Delphi Source File  |  2000-06-30  |  33KB  |  1,010 lines
  1. program Labelmaker(Addresses);
  2.  
  3. type Addresses=record
  4.                 LName:string [18];
  5.                 FName :string [18];
  6.                 Apmt:string [30];
  7.                 Strt:string [30];
  8.                 Cty : string [15];
  9.                 State:string[10];
  10.                 Zp: string [10];
  11.                 end;
  12.      Labfile = FILE OF integer;
  13.      Addressfile = FILE OF Addresses;
  14.      Entries = array[1..40] of Addresses;
  15.      nametype = string[18];
  16.      strtype = string [30];
  17.      ctytype = string [15];
  18.      ziptype = string [10];
  19.  
  20. var   lab :Labfile;
  21.       entry:Entries;
  22.       input:char;
  23.       no1,no2,Addr:Addresses;
  24.       second,temp,Address:Addressfile;
  25.       beth,alph,which : char;
  26.       updtno,z,q,r,c : integer;
  27.       flname,ln,fn : nametype;
  28.       apt,st : strtype;
  29.       cy : ctytype;
  30.       sta,code : ziptype;
  31.       newfl,ok : boolean;
  32. (*$R+*)
  33.  
  34. Procedure Switchfiles(var Addr:Addresses;var Address:Addressfile;var Alph,Beth:
  35.                          char; var z:integer;var flname:nametype);
  36. var ok,newfl: boolean;
  37.  
  38. Begin
  39.         REPEAT
  40.      writeln ('Enter name of file you wish to deal with. ');
  41.      readln (flname);
  42.      if length(flname) > 8 then writeln ('only 8 letters in a filename allowed.');
  43.         UNTIL length (flname) <= 8;
  44.      flname:= concat(flname,'.LBL');
  45.      Assign(Address,flname);
  46.      (*$I-*) reset (Address) (*$I+*);
  47.      ok := (IOresult =0);
  48.      if not ok then newfl:= true
  49.      else newfl:= false;
  50.      if newfl = true then begin
  51.         rewrite (Address);
  52.         writeln ('New file ',flname,' created.');
  53.                 REPEAT
  54.         writeln ('Do you wish this file to be sorted by  0: last names; ');
  55.         writeln ('1: Cities;  2: States;  3: zip codes ?');
  56.         readln (Alph);
  57.              UNTIL Alph in ['0','1','2','3'];
  58.         Addr.LName := Alph;
  59.              REPEAT
  60.         writeln ('Do you wish to print 4 lines for each address rather than 3?');
  61.         writeln('(Y/N or T for 3 lines and telephone #)');
  62.         readln (Beth);
  63.              UNTIL Beth in ['Y','y','N','n','t','T'];
  64.         Addr.FName:= Beth;
  65.         write (Address,Addr);
  66.         end;
  67.      z:= filesize(Address);
  68.      z:= z-1;
  69.      if newfl = false then begin
  70.         read (Address,Addr);
  71.         Alph:= Addr.LName;
  72.         Beth:= Addr.FName;
  73.      end;
  74.      close (Address);
  75.      writeln ('There are ',z,' names in this file');
  76. end; (*switchfiles *)
  77.  
  78. Procedure Erase (var z:integer);
  79.    Begin
  80.       z:=0;
  81.       Assign(Address,flname);
  82.       rewrite (Address);
  83.       close (Address);
  84.    end;
  85.  
  86. Procedure Rewritefile (var Entry:Entries;var Addr:Addresses;var
  87.               Address,temp:Addressfile; r:integer; fl:boolean);
  88. var    b: integer;
  89.  
  90. Begin
  91.    if fl = true then begin
  92.      if r >= 40 then begin
  93.         repeat
  94.         for b:= 1 to 40 do read (Address,Entry[b]);
  95.         for b:= 1 to 40 do write(temp,Entry[b]);
  96.         r:= r-40;
  97.         until r < 40;
  98.      end;
  99.      if r >= 20 then begin
  100.         for b:= 1 to 20 do read (Address,Entry[b]);
  101.         for b:= 1 to 20 do write(temp,Entry[b]);
  102.         r:= r-20;
  103.      end;
  104.      if r >= 10 then begin
  105.         for b:= 1 to 10 do read (Address,Entry[b]);
  106.         for b:= 1 to 10 do write(temp,Entry[b]);
  107.         r:= r-10;
  108.      end;
  109.      if r >= 5 then begin
  110.         for b:= 1 to 5 do read (Address,Entry[b]);
  111.         for b:= 1 to 5 do write(temp,Entry[b]);
  112.         r:= r-5;
  113.      end;
  114.      if r > 0 then begin
  115.         for b:= 1 to r do begin
  116.            read (Address,Addr);
  117.            write(temp,Addr);
  118.         end;
  119.      end;
  120.   end; (* fl=true *)
  121.   if fl= false then begin
  122.      if r >= 40 then begin
  123.            repeat
  124.         for b:= 1 to 40 do read (temp,Entry[b]); write(b);
  125.         for b:= 1 to 40 do write(Address,Entry[b]); write(b);
  126.         r:= r-40;
  127.         until r < 40; writeln;
  128.      end;
  129.      if r >= 20 then begin
  130.         for b:= 1 to 20 do read (temp,Entry[b]); write(b);
  131.         for b:= 1 to 20 do write(Address,Entry[b]); write(b);
  132.         r:= r-20;
  133.         writeln;
  134.      end;
  135.      if r >= 10 then begin
  136.         for b:= 1 to 10 do read (temp,Entry[b]);
  137.         for b:= 1 to 10 do write(Address,Entry[b]);
  138.         r:= r-10;
  139.      end;
  140.      if r >= 5 then begin
  141.         for b:= 1 to 5 do read (temp,Entry[b]);
  142.         for b:= 1 to 5 do write(Address,Entry[b]);
  143.         r:= r-5;
  144.      end;
  145.      if r > 0 then begin
  146.         for b:= 1 to r do begin
  147.            read (temp,Addr);
  148.            write(Address,Addr);
  149.         end;
  150.      end;
  151.   end; (* if fl=false *)
  152. end; (* Rewritefile *)
  153.  
  154.  
  155. Procedure Bubblesort (var Entry:Entries; r:integer;Alph:char);
  156. var last: 2..10;
  157.     curr,temp: 1..11;
  158.     bubb: boolean;
  159. Begin
  160.      temp:= 11;
  161.      for last:= r downto 2 do
  162.          for curr:= 1 to last-1 do begin
  163.      if alph = '0' then if Entry[curr].LName > Entry[curr+1].LName then bubb:=true
  164.      else bubb := false;
  165.      if alph='1' then if Entry[curr].Cty >Entry[curr+1].Cty then bubb := true
  166.      else bubb := false;
  167.      if alph='2' then if Entry[curr].State >Entry[curr+1].State then bubb :=true
  168.      else bubb := false;
  169.      if alph='3' then if Entry[curr].Zp >Entry[curr+1].Zp then bubb := true
  170.      else bubb := false;
  171.              if bubb = true then begin
  172.                 Entry[temp]:= Entry[curr];
  173.                 Entry[curr]:= Entry[curr+1];
  174.                 Entry[curr+1]:= Entry[temp];
  175.              end; (* if *)
  176.          end; (* current for *)
  177. end; (* Bubblesort *)
  178.  
  179. Procedure Alphabetize (var Entry:Entries; var Addr:Addresses;var Address,
  180.                           temp:Addressfile; r,z:integer; new:boolean;
  181.                           Alph: char);
  182. var l,t,c:integer;
  183.     sort,fl: boolean;
  184.  
  185. Begin
  186.      if r > 1 then Bubblesort(Entry,r,Alph);
  187.      Assign (Address,flname);
  188.      reset (Address);  read (Address,Addr);
  189.    if new = false then begin
  190.      Assign (temp,'TEMP.UPD');
  191.      rewrite (temp); write (temp,Addr);
  192.      while not eof(Address) do begin
  193.            read (Address,Addr); t:= 0;
  194.                if r > 0 then begin
  195.                    repeat
  196.                t:= t+ 1;
  197.      if alph = '0' then if Entry[t].LName < Addr.LName then sort:=true
  198.      else sort := false;
  199.      if alph='1' then if Entry[t].Cty < Addr.Cty then sort := true
  200.      else sort := false;
  201.      if alph='2' then if Entry[t].State < Addr.State then sort:=true
  202.      else sort := false;
  203.      if alph='3' then if Entry[t].Zp < Addr.Zp then sort := true
  204.      else sort := false;
  205.                if sort = true then begin
  206.                   write (temp,Entry[t]);
  207.                   writeln(entry[t].LName,' written to temp');
  208.                   r:= r-1;
  209.                   if t < r+1 then begin
  210.                      for c:= t to r do begin
  211.                          Entry[c]:= Entry[c+1];
  212.                      end;
  213.                   t:= t- 1;
  214.                   end;  (* if t *)
  215. end; (* Entry if *)
  216.              if r = 0 then t:= r;
  217.              until t= r;
  218.             end; (* r>0 *)
  219.            write (temp,Addr);
  220.     end; (* while *)
  221.     if r > 0 then begin
  222.        for t:= 1 to r do write (temp,Entry[t]);
  223.     end;
  224.     writeln (' Updating ',flname,' file. ');
  225.     rewrite(Address);
  226.     reset (temp);
  227.     l:= filesize (temp);
  228.     fl:= false;
  229.     r:= l; writeln('size of ',flname,' is ',r-1);
  230.     Rewritefile(Entry,Addr,Address,temp,r,fl);
  231.     close (temp);
  232.     close (Address);
  233. end; (* if new *)
  234. if new= true then begin
  235.    for c:= 1 to r do write (Address,Entry[c]);
  236.    close (Address);
  237. end; (* if *)
  238. end; (* Alphabetize *)
  239. Procedure Secondfile (var Entry:Entries;var Addr:Addresses;var second,
  240.                  Address:Addressfile; var Alph:char;var Beth:char; z:integer);
  241. var tp,ans:string[15];
  242.     new,ok,yes:boolean;
  243.     c,y,n,r,x:integer;
  244.     be,al,answ,repl: char;
  245. Begin
  246.      writeln(' Enter name of second file you wish to create or add to.');
  247.           REPEAT
  248.      readln (ans);
  249.      if length(ans) > 8 then writeln ('only 8 letters in a filename allowed.');
  250.         UNTIL length(ans)<= 8;
  251.      ans:= concat (ans,'.LBL');
  252.            repeat
  253. if ans = flname then begin
  254.         writeln ('you are already using that filename. Try again');
  255.         readln (ans);
  256.         end;
  257.            until ans <> flname;
  258.      Assign (second,ans);
  259.      (*$I-*) reset (second) (*$I+*);
  260.      ok:= (IOresult = 0);
  261.      if not ok then new:= true
  262.      else new:= false;
  263.      if new = true then begin
  264.         rewrite (second);
  265.         writeln (' New file ',ans,' created.');
  266.         new:= true;
  267.         al:= Alph; be:= Beth;
  268.               REPEAT
  269.         writeln ('Do you wish it to be sorted by : 0:Last Name ');
  270.         writeln ('1: City;  2: State;  3: Zip code? ');
  271.         readln (Alph);
  272.               UNTIL Alph in ['0','1','2','3'];
  273.         Addr.LName:= Alph;
  274.              REPEAT
  275.         writeln ('Do you wish ',ans,' file to have 4 lines in the addresses ');
  276.         writeln ('rather than 3? (Y/N or T for 3 lines and telephone #)');
  277.         readln (Beth);
  278.              UNTIL Beth in ['Y','y','N','n','T','t'];
  279.         Addr.FName:= Beth;
  280.         write (second,Addr);
  281.         reset (second);
  282.      end; (* if new=true *)
  283.      y:= filesize (second); y:= y-1;
  284.      read (second,Addr);
  285.      if new = false then begin
  286.         al:= Alph; be:= Beth;
  287.         Alph:= Addr.LName; Beth:= Addr.FName;
  288.      end;
  289.      Assign (Address,flname);
  290.      reset (Address);
  291.      writeln (' Enter 0 to quit.');
  292.      c:= 0; n:= 1; z:= z+1;
  293.      read (address,addr);
  294.          REPEAT
  295.      read (Address,Addr);
  296.      writeln (Addr.FName,' ',Addr.LName);
  297.      if Beth in ['Y','y'] then writeln (Addr.Apmt);
  298.      writeln (Addr.Strt);
  299.      writeln (Addr.Cty,' ',Addr.State,' ',Addr.Zp);
  300.      writeln (' Do you wish to select this to include in ',ans,' file? Y/N');
  301.      readln (repl);
  302.      if repl in ['y','Y'] then yes:= true
  303.      else yes:= false;
  304.      n:= n+1;
  305.      if repl = '0' then n:= z;
  306.      if yes = true then begin
  307.         c:= c+1;
  308.         Entry[c]:= Addr;
  309.         if c = 10 then begin
  310.            r:= c; y:= y+c;
  311.            close (Address); close (second);
  312.            tp:=flname;flname:= ans;
  313.            writeln ('Writing to ',ans,' file. ');
  314.            if new = false then Alphabetize(Entry,Addr,Address,temp,r,z,new,Alph);
  315.            if new = true then begin
  316.               assign (second,ans); reset (second);
  317.               r:= 10; read (second,Addr);
  318.               Bubblesort(Entry,r,Alph);
  319.               for x:= 1 to 10 do write (second,Entry[x]);
  320.            end;
  321.            new:= false;
  322.            flname:= tp;
  323.            c:= 0; x:= n;
  324.            assign (Address,flname);
  325.            reset (Address);
  326.            for x:= 1 to n do read (Address,Addr);
  327.         end; (* if c=10 *)
  328.      end; (* if yes=true *)
  329.      until n = z;
  330.      if c = 0 then close (second);
  331.      if c > 0 then begin
  332.         r:= c; y:= y+c;
  333.         close (Address); close (second);
  334.         tp:= flname; flname:=ans;
  335.         if new= false then Alphabetize(Entry,Addr,Address,temp,r,z,new,Alph);
  336.         if new= true then begin
  337.            assign(second,ans); reset (second);
  338.            read (second,Addr);
  339.            Bubblesort(Entry,r,Alph);
  340.            for x:= 1 to c do write (second,Entry[x]);
  341.            close (second);
  342.         end;
  343.         new := false;
  344.         flname:= tp;
  345.         end; (* c>0 *)
  346. Alph:= al;Beth:= be;
  347. end; (* Secondfile *)
  348.  
  349. Procedure Enter(var Addr:Addresses;var Address:Addressfile;
  350.                            var z:integer; Alph,Beth:char);
  351. var
  352.    r,n:integer;
  353.    ans:char;
  354.    new,yes:boolean;
  355. Begin
  356.      if z=0 then new:= true
  357.      else new:= false;
  358.      n:= 1;
  359.         repeat
  360.   with Entry[n] do begin
  361.    writeln('Enter last name  ');
  362.    readln(LName);
  363.    writeln('Enter first name  ');
  364.    readln(FName);
  365.    if Beth in ['Y','y'] then writeln ('Enter company or apartment no.');
  366.    if Beth in ['Y','y'] then readln (Apmt);
  367.    writeln ('Enter street address  ');
  368.    readln (Strt);
  369.    writeln ('Enter city ');
  370.    readln (Cty);
  371.    writeln ('Enter State ');
  372.    readln (State);
  373.    writeln ('Enter zip code  ');
  374.    readln (Zp);
  375.    if Beth in ['T','t'] then begin
  376.       writeln ('Enter telephone no.');
  377.       readln (Apmt);
  378.    end; (* if beth *)
  379.     end;
  380.    writeln ('Continue to enter addresses? Y/N ');
  381.    readln (ans);
  382.    if ans in ['Y','y'] then yes:= true
  383.    else yes := false;
  384.    n:= n + 1;
  385.    if n = 11 then begin
  386.       r:= n-1; z:= z+r;
  387.       writeln ('Updating file ');
  388.       Alphabetize(Entry,Addr,Address,temp,r,z,new,Alph);
  389.       n:= 1; new:= false;
  390.    end;
  391.         until yes = false;
  392.    if n <> 1 then begin
  393.       r:= (n-1);  z:= z+r;
  394.       writeln ('Updating file ');
  395.       Alphabetize(Entry,Addr,Address,temp,r,z,new,Alph);
  396.    end; (* if *)
  397. end; (* Enter *)
  398.  
  399. Procedure Update (var Addr:Addresses;q,z:integer; var temp:Addressfile;
  400.                          var Address:Addressfile; Alph,Beth:char);
  401. var
  402.    updtno,n,num,r : integer;
  403.    fn,ln : nametype;
  404.    apt,st,tp : strtype;
  405.    cy : ctytype;
  406.    code,sta : ziptype;
  407.    fl:boolean;
  408. Begin
  409.    writeln ('Enter 0 to leave a field unchanged.');
  410.      updtno:=q;
  411.    writeln ('Enter last name  ');
  412.    readln (tp);if tp <> '0' then ln:= tp
  413.    else ln:= Addr.LName;
  414.    writeln('Enter first name  ');
  415.    readln(tp);if tp <> '0' then fn:= tp
  416.    else fn:= Addr.FName;
  417.    if Beth in ['Y','y'] then begin
  418.       writeln ('Enter company or apartment no.');
  419.       readln(tp); if tp <> '0' then apt:= tp
  420.       else apt:= Addr.Apmt;
  421.    end;
  422.    writeln ('Enter street address  ');
  423.    readln (tp);if tp <> '0' then st:= tp
  424.    else st:= Addr.Strt;
  425.    writeln ('Enter city ');
  426.    readln (tp);if tp <> '0' then cy:= tp
  427.    else cy:= Addr.Cty;
  428.    writeln ('Enter state ');
  429.    readln (tp); if tp <> '0' then sta:= tp
  430.    else sta:= Addr.State;
  431.    writeln ('Enter zip code  ');
  432.    readln (tp); if tp <> '0' then code := tp
  433.    else code := Addr.Zp;
  434.    if Beth in ['t','T'] then begin
  435.       writeln ('Enter telephone no.');
  436.       readln(tp); if tp <> '0' then apt:= tp
  437.       else apt:= Addr.Apmt;
  438.    end;
  439. Assign (Address,flname);
  440. reset (Address);
  441. Assign (temp,'NAMES.UPD');
  442. rewrite (temp);
  443.         if updtno > 1 then begin
  444.            r:= updtno-1;
  445.            fl:= true;
  446.            Rewritefile(Entry,Addr,Address,temp,r,fl);
  447.         end;
  448.    n:= updtno;
  449.        Addr.LName:=ln; Addr.FName:=fn;
  450.        if Beth in ['Y','y','T','t'] then Addr.Apmt:= apt;
  451.        Addr.Strt := st;
  452.        Addr.Cty := cy; Addr.State:= sta; Addr.Zp:= code;
  453.        write (Temp,Addr);
  454.        read (Address,Addr);
  455.        if n < z then begin
  456.            r:= z - (updtno);
  457.            fl:= true;
  458.            Rewritefile(Entry,Addr,Address,temp,r,fl);
  459.        end;
  460.        r:= z;
  461.        fl:= false;
  462.        rewrite (Address); reset (temp);
  463.        Rewritefile(Entry,Addr,Address,temp,r,fl);
  464.        close(Address);
  465.        close(temp);
  466. end; (* Update *)
  467.  
  468. Procedure PrintAllNames (var Entry:Entries; var Addr:Addresses; var
  469.                               Address:Addressfile; z:integer; Beth:char);
  470. var
  471.    c,n,d,p,l,bl,b:integer;
  472.    ch: char;
  473.    even:boolean;
  474.    tp1,tp2,tp3,line:strtype;
  475. Begin
  476.      writeln ('filesize = ',z,' filename = ',flname);
  477.    assign (Address, flname);
  478.    reset (Address);
  479.    read (Address,Addr);
  480.    if z mod 2 = 0 then even:= true
  481.    else even:= false;
  482.    n:= 0; p:= 0; c:= 1;ch:= '6';
  483.    writeln ('Press  >return< to continue, 0 to quit. ');
  484.    if z > 1 then begin
  485.       if even = false then z:= z-1;
  486.           repeat
  487.       read (Address,Entry[c]);
  488.       read (Address,Entry[c+1]);
  489.       n:= n+2; p:= p+2;
  490.      write (entry[c].FName,' ',entry[c].LName);
  491.      tp1:= entry[c].FName; tp2:= entry[c].LName;
  492.      line:= concat(tp1,' ',tp2);
  493.      l:= length(line);
  494.      bl:= (40- l);
  495.      if bl > 0 then begin
  496.         for b:= 1 to bl do write (' ');
  497.      end;
  498.      writeln (entry[c+1].FName,' ',entry[c+1].LName);
  499.      if Beth in ['Y','y'] then begin
  500.         write (entry[c].apmt);
  501.         line:= entry[c].apmt;
  502.         l:= length(line);
  503.         bl:= (40 - l);
  504.         if bl > 0 then begin
  505.            for b:= 1 to bl do write (' ');
  506.         end;
  507.         writeln (entry[c+1].Apmt);
  508.      end; (* if Beth *)
  509.      write (entry[c].strt);
  510.      line:= entry[c].strt;
  511.      l:= length(line);
  512.      bl:= (40 - l);
  513.      if bl > 0 then begin
  514.         for b:= 1 to bl do write (' ');
  515.      end;
  516.      writeln (entry[c+1].Strt);
  517.      write (entry[c].Cty,' ',entry[c].State,' ',entry[c].Zp);
  518.      tp1:= entry[c].Cty; tp2:= entry[c].Zp; tp3:= entry[c].State;
  519.      line:= concat(tp1,' ',tp2,' ',tp3);
  520.      l:= length(line);
  521.      bl:= (40 - l);
  522.      if bl > 0 then begin
  523.         for b:= 1 to bl do write (' ');
  524.      end;
  525.      writeln (entry[c+1].Cty,' ',entry[c+1].State,' ',entry[c+1].Zp);
  526.      if Beth in ['T','t'] then begin
  527.         write (entry[c].apmt);
  528.         line:= entry[c].apmt;
  529.         l:= length(line);
  530.         bl:= (40 - l);
  531.         if bl > 0 then for b:= 1 to bl do write (' ');
  532.         writeln (entry[c+1].Apmt);
  533.      end; (* if Beth *)
  534.      writeln;
  535.      if Beth in ['Y','y','T','t'] then begin
  536.         if n mod 8 = 0 then read (ch);
  537.      end;
  538.      if Beth in ['n','N'] then begin
  539.         if n mod 10 = 0 then read (ch);
  540.      end;
  541.      if ch = '0' then n:= z;
  542.      UNTIL n = z;
  543.   end; (* if z>1 *)
  544.  if ch <> '0' then begin
  545.    while not eof(Address) do begin
  546.        read (Address, Addr);
  547.        writeln (Addr.FName,' ',Addr.LName);
  548.        if beth in ['Y','y'] then writeln (Addr.Apmt);
  549.        writeln (Addr.Strt);
  550.        write (Addr.Cty,' ');write (Addr.State,' ');
  551.        writeln (Addr.Zp);
  552.        if beth in ['T','t'] then writeln (Addr.Apmt);
  553.        writeln;
  554.   end;  (* begin *)
  555. end; (* if ch<>0 *)
  556.   close (Address);
  557.  readln(ch);  writeln;
  558. end;
  559.  
  560. Procedure Retrieve (var Addr: Addresses; var Address:Addressfile; z: integer;
  561.                                        var q:integer; Beth:char);
  562.  var
  563.     ln,Last:nametype;
  564.     yesno,print: boolean;
  565.     ans : char;
  566.     p:integer;
  567. Begin
  568.      z:= z+1;
  569.      print:= false;
  570.      assign (Address,flname);
  571.      reset (Address);
  572.      writeln ('Enter last name you wish to retrieve');
  573.      readln (Last);
  574.      clrscr;
  575.      p:= 1;
  576.      while p <= z do begin
  577.        read (Address, Addr);
  578.        ln:=Addr.LName;
  579.        if Last = ln then begin
  580.               writeln('p',p,'z',z);
  581.               write (Addr.FName); write (' '); writeln (Addr.LName);
  582.               if beth in ['Y','y'] then writeln (Addr.Apmt);
  583.               writeln (Addr.Strt);
  584.               writeln (Addr.Cty,' ',Addr.State,' ',Addr.Zp);
  585.               if beth in ['T','t'] then writeln (Addr.Apmt);
  586.               q:=p;
  587.               print:= true;
  588.               writeln ('Do you wish to update this name? (Y/N)');
  589.               readln (ans);
  590.               if ans in ['y','Y'] then yesno:= true
  591.               else yesno:= false;
  592.               if yesno = true then begin
  593.                  close (Address);
  594.                  Update (Addr,q,z,temp,Address,Alph,Beth);
  595.                  p:= z+1;
  596.               end;  (*begin *)
  597.          end; (* if last=ln *)
  598.       if p = z then  close (Address);
  599.      p:= p+1;
  600.      end; (* while *)
  601.  if print = false then
  602.    writeln(' There is no name like that in the file');
  603.   end;
  604.  
  605. Procedure Delete(var Addr:addresses; var Address:Addressfile;
  606.                           var temp:Addressfile; var z:integer);
  607. var
  608.    Last:nametype;
  609.    p,n,tmp : integer;
  610.    fl,yes : boolean;
  611.    ans: char;
  612. Begin
  613.      z:= z+1;
  614.      writeln ('Enter last name to delete ');
  615.      readln (Last);
  616.      Assign (Address, flname);
  617.      reset (Address);
  618.      Assign (temp, 'NAMES.UPD');
  619.      rewrite (temp);
  620.      yes:= false; n:= 1; tmp:= 1;
  621.      if not eof(Address) then begin
  622.         while n <= z do begin
  623.             tmp:= n;
  624.             read (Address, Addr);
  625.             if Addr.LName = Last then begin
  626.                writeln (Addr.FName,' ',Addr.LName);
  627.                writeln ('Is this the name you wish to delete? ');
  628.                readln (ans);
  629.                if ans in ['Y','y'] then yes:= true
  630.             end;(* if *)
  631.             if yes = false then n:= n+1
  632.             else n := z+1;
  633.                end; (* while *)
  634.          end; (* if *)
  635.        reset (Address);
  636.    if yes = true then begin
  637.        n:= tmp;
  638.      if n > 1 then begin
  639.         fl:= true; r:= n-1;
  640.         Rewritefile(Entry,Addr,Address,temp,r,fl);
  641.      end;
  642.      read (Address,Addr);
  643.      if n < z then begin
  644.         fl:= true; r:= z-n;
  645.         Rewritefile(Entry,Addr,Address,temp,r,fl);
  646.      end; (* if *)
  647.      rewrite (Address); reset (temp);
  648.      z:= z-1;
  649.      fl:= false; r:= z;
  650.          Rewritefile(Entry,Addr,Address,temp,r,fl);
  651.    end; (* yes=true*)
  652.          close (Address);
  653.          rewrite (temp);
  654.          close (temp);
  655.          z:= z-1;
  656. end; (* Delete *)Procedure DesignLabels (var lab:Labfile);
  657. var
  658.    tp,sp,adsp,across,col1,col2,col3,col4 : integer;
  659. Begin
  660.      Assign (lab,'LABEL.DES');
  661.      (*$I-*) reset (lab) (*$I+*);
  662.      ok := (IOresult = 0);
  663.      if ok = false then begin
  664.         rewrite (lab);
  665.         sp:=100;adsp:= 100; across:= 20;
  666.         col1:= 100; col2:= 200; col3:= 300;
  667.      end
  668.      else if not eof(lab) then
  669.           read (lab,sp,adsp,across,col1,col2,col3);
  670.      close (lab);
  671.      writeln ('Press >0< to keep value unchanged.');
  672.      writeln ('Enter # for linespacing within an address. For instance,');
  673.      writeln ('1 for singlespacing, 2 for doublespacing, etc.');
  674.      writeln ('Current value is ',sp);
  675.      readln (tp); if tp in [1..1000] then sp:= tp;
  676.      writeln ('How many blank lines up and down between addresses?');
  677.      writeln ('Current value is ',adsp);
  678.      readln (tp); if tp in [1..1000]then adsp:= tp;
  679.      writeln ('First address to start at column # ?');
  680.      writeln ('Current column is ',col1);
  681.      readln (tp); if tp in [1..1000] then col1:= tp;
  682.      writeln ('How many addresses across on the page? (1-3)');
  683.      writeln ('Current number is ',across);
  684.      readln (tp); if tp in [1..3] then across:= tp;
  685.      if across = 1 then begin
  686.         col2:= 100; col3 := 200; col4:= 400;
  687.      end;
  688.      if across >= 2 then begin
  689.         writeln ('At what column do you wish to start the second address?');
  690.         writeln ('Current column is ',col2);
  691.         readln (tp); if tp in [1..1000] then col2:= tp;
  692.         if across = 2 then begin
  693.            col3:= 200; col4:= 400;
  694.         end;
  695.     end;
  696.     if across >= 3 then begin
  697.        writeln ('At what column do you wish to start the 3rd address?');
  698.        writeln ('Current column is ',col3);
  699.        readln (tp); if tp in [1..1000] then col3:= tp;
  700.        if across = 3 then col4:= 400;
  701.     end;
  702.     writeln ('Well, it''s your design...');
  703.     Assign (lab,'LABEL.DES');
  704.     rewrite (lab);
  705.     write (lab, sp,adsp,across,col1,col2,col3,col4);
  706.     close (lab);
  707. end;
  708.  
  709. Procedure Singlelist (var Addr:Addresses;n,sp,adsp,col1:integer; Beth:char);
  710. var b:integer;
  711. Begin
  712.      if col1 > 1 then for b:= 2 to col1 do write (lst,' ');
  713.      writeln(lst,Addr.FName,' ',Addr.LName);
  714.      if sp > 1 then for b:= 2 to sp do writeln(lst);
  715.      if Beth in ['Y','y'] then begin
  716.         if col1 > 1 then for b:= 2 to col1 do write (lst,' ');
  717.         Writeln (lst,Addr.Apmt);
  718.         if sp > 1 then for b:= 2 to sp do writeln (lst);
  719.      end; (* if Beth *)
  720.       if col1 > 1 then for b:= 2 to col1 do write (lst,' ');
  721.      Writeln (lst,Addr.Strt);
  722.      if sp > 1 then for b:= 2 to sp do writeln (lst);
  723.      if col1 > 1 then for b:= 2 to col1 do write (lst,' ');
  724.      writeln (lst,Addr.Cty,' ',Addr.State,' ',Addr.Zp);
  725.      if Beth in ['T','t'] then begin
  726.         if sp > 1 then for b:= 2 to sp do writeln (lst);
  727.         if col1 > 1 then for b:= 2 to col1 do write (lst,' ');
  728.         Writeln (lst,Addr.Apmt);
  729.      end; (* if Beth *)
  730.      if adsp > 0 then for b:= 1 to adsp do writeln (lst);
  731. end; (*Singlelist *)
  732.  
  733. Procedure zpr (var Entry:Entries; col1,col2,colm,col,d,n,c:integer);
  734. var tp1,tp2,tp3,line:strtype;
  735.     b,bl,l: integer;
  736. Begin
  737.    if colm = col1 then begin
  738.      if colm > 1 then begin
  739.         for b:= 2 to colm do write (lst,' ');
  740.      end;
  741.      write (lst,entry[c].Cty,' ',entry[c].State,' ',entry[c].Zp);
  742.    end;
  743.      tp1:= Entry[c].Cty; tp2:= Entry[c].Zp; tp3:= Entry[c].State;
  744.      line:= concat(tp1,' ',tp2,' ',tp3);
  745.      l:= length(line);
  746.      if colm=col1 then bl:= (col-(l+col1))
  747.      else bl:= (col-(l+col2));
  748.      if bl > 0 then begin
  749.         for b:= 1 to bl do write (lst,' ');
  750.      end;
  751.      write(lst,Entry[c+1].Cty,' ',Entry[c+1].State,' ',Entry[c+1].Zp);
  752. end;
  753.  
  754. Procedure stpr (var Entry:Entries; col1,col2,colm,col,d,n,c: integer);
  755. var tp1:strtype;
  756.     b,bl,l: integer;
  757. Begin
  758.    if colm = col1 then begin
  759.      if colm > 1 then begin
  760.         for b:= 2 to colm do write (lst,' ');
  761.      end;
  762.      write (lst,entry[c].Strt);
  763.    end;
  764.      tp1:= entry[c].Strt;
  765.      l:= length(tp1);
  766.      if colm=col1 then bl:= (col-(l+col1))
  767.      else bl:= (col-(l+col2));
  768.      if bl > 0 then begin
  769.         for b:= 1 to bl do write (lst,' ');
  770.      end;
  771.      write (lst,entry[c+1].Strt);
  772. end;
  773.  
  774. Procedure apmtpr (var Entry:Entries; col1,col2,colm,col,d,n,c: integer);
  775. var tp1:strtype;
  776.     b,bl,l: integer;
  777. Begin
  778.    if colm = col1 then begin
  779.      if colm > 1 then begin
  780.         for b:= 2 to colm do write (lst,' ');
  781.      end;
  782.      write (lst,entry[c].Apmt);
  783.    end;
  784.      tp1:= entry[c].Apmt;
  785.      l:= length(tp1);
  786.      if colm=col1 then bl:= (col-(l+col1))
  787.      else bl:= (col-(l+col2));
  788.      if bl > 0 then begin
  789.         for b:= 1 to bl do write (lst,' ');
  790.      end;
  791.      write (lst,entry[c+1].Apmt);
  792. end;
  793.  
  794. Procedure namepr(var Entry:Entries; col1,col2,colm,col,d,n,c:integer);
  795. var tp1,tp2,line:strtype;
  796.     b,bl,l : integer;
  797. Begin
  798. if colm = col1 then begin
  799.  if colm > 1 then begin
  800.         for b:= 2 to colm do write (lst,' ');
  801.      end;
  802.      write (lst,entry[c].FName,' ',entry[c].LName);
  803. end;
  804.      tp1:= entry[c].FName; tp2:= entry[c].LName;
  805.      line:= concat(tp1,' ',tp2);
  806.      l:= length(line);
  807.      if colm=col1 then bl:= (col-(l+col1))
  808.      else bl:= (col-(l+col2));
  809.      if bl > 0 then begin
  810.         for b:= 1 to bl do write (lst,' ');
  811.      end;
  812.      write (lst,entry[c+1].FName,' ',entry[c+1].LName);
  813. end;
  814.  
  815. Procedure List2 (var Entry:Entries; var Address:Addressfile;sp,adsp,across,
  816.          col1,col2,z,c:integer; fl:boolean; var Addr:Addresses; Beth:char);
  817. var even : boolean;
  818.     b,n,d,colm,col: integer;
  819. Begin
  820.    if fl = false then begin
  821.      Assign(Address,flname);
  822.      reset (Address);
  823.      read (Address,Addr);
  824.      end;
  825.      if (z mod 2) = 1 then even:= false
  826.      else even:= true;
  827.      d:= 1;
  828.      if fl = false then n:= 0
  829.      else n:= z-2;
  830.    if z > 1 then begin
  831.     if fl = false then begin
  832.      if even = false then z:= z-1;
  833.     end;
  834.      colm:= col1; col:= col2; c:= 1;
  835.      repeat
  836.      n:= n+2;
  837.      read (Address,entry[c]);
  838.      read (Address, entry[c+1]);
  839.      namepr(Entry,col1,col2,colm,col,d,n,c);
  840.         for b:= 1 to sp do writeln(lst);
  841.      if Beth in ['Y','y'] then begin
  842.         apmtpr(Entry,col1,col2,colm,col,d,n,c);
  843.         for b:= 1 to sp do writeln(lst);
  844.      end;
  845.      stpr(Entry,col1,col2,colm,col,d,n,c);
  846.         for b:= 1 to sp do writeln(lst);
  847.      zpr (Entry,col1,col2,colm,col,d,n,c);
  848.      if Beth in ['T','t'] then begin
  849.         for b:= 1 to sp do writeln(lst);
  850.         apmtpr(Entry,col1,col2,colm,col,d,n,c);
  851.      end;
  852.         for b:= 0 to adsp do writeln (lst);
  853.      until n = z;
  854.   end;
  855.      if fl=true then even:= true;
  856.      if even = false then begin
  857.         n:= n+1;
  858.         read (Address,Addr);
  859.         Singlelist(Addr,n,sp,adsp,col1,Beth);
  860.      end;
  861.     close (Address);
  862. end; (* list2 *)
  863.  
  864. Procedure List3 (var Entry:Entries; var Address:Addressfile;sp,adsp,across,
  865.   col1,col2,col3,z,c: integer; var fl: boolean; var Addr:Addresses; Beth:char);
  866. var l,b,n,d,colm,col,extra: integer;
  867.     tp1,tp2,line: strtype;
  868. Begin
  869.    if fl = false then begin
  870.      Assign(Address,flname);
  871.      reset (Address);
  872.      read (Address,Addr);
  873.      end;
  874.      extra := z mod 3;
  875.      n:= 0;
  876.   if z > 2 then begin
  877.      z:= z - extra;
  878.        repeat
  879.      colm:= col1; col:= col2;
  880.      n:= n+3; d:= 2; c:= 1;
  881.      read (Address,Entry[c]);
  882.      read (Address,Entry[c+1]);
  883.      read (Address, Entry[c+2]);
  884.      namepr(Entry,col1,col2,colm,col,d,n,c);
  885.      col:= col3;colm:= col2; d:= 1; c:=2;
  886.      namepr (Entry,col1,col2,colm,col,d,n,c);
  887.         for b:= 1 to sp do writeln(lst);
  888.      if Beth in ['Y','y'] then begin
  889.         col:= col2; colm:= col1; d:= 2; c:= 1;
  890.         apmtpr(Entry,col1,col2,colm,col,d,n,c);
  891.         col:= col3; colm:= col2; d:= 1; c:= 2;
  892.         apmtpr(Entry,col1,col2,colm,col,d,n,c);
  893.          for b:= 1 to sp do writeln(lst);
  894.      end; (* if Beth *)
  895.      col:= col2; colm:= col1; d:= 2; c:= 1;
  896.      stpr(Entry,col1,col2,colm,col,d,n,c);
  897.      col:= col3; colm:= col2; d:= 1; c:= 2;
  898.      stpr (Entry,col1,col2,colm,col,d,n,c);
  899.          for b:= 1 to sp do writeln(lst);
  900.      col:= col2; colm:= col1; d:= 2; c:= 1;
  901.      zpr (Entry,col1,col2,colm,col,d,n,c);
  902.      col:= col3; colm:= col2; d:= 1; c:= 2;
  903.      zpr (Entry,col1,col2,colm,col,d,n,c);
  904.      if Beth in ['T','t'] then begin
  905.         for b:= 1 to sp do writeln(lst);
  906.         col:= col2; colm:= col1; d:= 2; c:= 1;
  907.         apmtpr(Entry,col1,col2,colm,col,d,n,c);
  908.         col:= col3; colm:= col2; d:= 1; c:= 2;
  909.         apmtpr(Entry,col1,col2,colm,col,d,n,c);
  910.      end; (* if Beth *)
  911.         for b:= 0 to adsp do writeln(lst);
  912.      until n = z;
  913.      z:= z + extra;
  914.   end; (* if z>2 *)
  915.      if extra = 1 then begin
  916.         read (Address,Addr);
  917.         Singlelist (Addr,n,sp,adsp,col1,Beth);
  918.      end;
  919.      if extra = 2 then begin
  920.         fl:= true; (* open *)
  921.         c:= 1;
  922.         List2 (Entry,Address,sp,adsp,across,col1,col2,z,c,fl,Addr,Beth);
  923.      end;
  924.   if fl = false then close (Address);
  925. end;  (* List3 *)
  926.  
  927. Procedure List1 (var Addr:Addresses; var Address:Addressfile;sp,adsp,across,
  928.                            col1,col2,col3,z:integer; fl:boolean; Beth:char);
  929. var n:integer;
  930.  
  931. Begin
  932.    if fl = false then begin
  933.      Assign (Address,flname);
  934.      reset (Address);
  935.      read (Address,Addr);
  936.      end;
  937.      for n:= 1 to z  do begin
  938.          read (Address, Addr);
  939.          Singlelist (Addr,n,sp,adsp,col1,Beth);
  940.      end;
  941.      if fl = false then close (Address);
  942. end;
  943.  
  944. Procedure List (var Addr:Addresses; var lab:labfile; z:integer; Beth:char);
  945. var
  946.    b,n,sp,adsp,across,col1,col2,col3,col4 : integer;
  947.    fl,ok,design : boolean;
  948. Begin
  949.      Assign (lab,'LABEL.DES');
  950.      (*$I-*) reset (lab) (*$I+*);
  951.      ok:= (IOresult = 0);
  952.      if not ok then design:= false
  953.      else design:= true;
  954. if design = false then begin
  955.     writeln ('You must design label format (#6) before labels can be printed');
  956. end;
  957. if design = true then begin
  958.      read (lab,sp,adsp,across,col1,col2,col3,col4);
  959.      close (lab);
  960.      fl:= false;
  961.  
  962.  if across = 1 then List1(Addr,Address,sp,adsp,across,col1,col2,col3,z,fl,Beth);
  963.  if across = 2 then List2 (Entry,Address,sp,adsp,across,col1,col2,z,c,fl,Addr,Beth);
  964.  if across = 3 then List3(Entry,Address,sp,adsp,across,col1,col2,col3,z,c,fl,
  965.                                  Addr,Beth);
  966. end; (* if design=true *)
  967. end;
  968. Procedure MainMenu;
  969.  
  970. Begin
  971.    writeln ('0: Quit');
  972.    writeln ('1: Enter new name & address');
  973.    writeln ('2: Retrieve/Update');
  974.    writeln ('3: Erase or start ERASES WHOLE FILE OF ADDRESSES');
  975.    writeln ('4: View whole file');
  976.    writeln ('5: Delete');
  977.    writeln ('6: Design Labels');
  978.    writeln ('7: Output to printer');
  979.    writeln ('8: Create or add to another file');
  980.    writeln ('9: Switch to another file');
  981.    writeln ('Which? ');
  982.    readln (which);
  983.       case which of
  984.       '0':  ;
  985.       '1': Enter(Addr,Address,z,Alph,Beth);
  986.       '2': Retrieve(Addr,Address,z,q,Beth);
  987.       '3': Erase (z);
  988.       '4': PrintAllNames (Entry,Addr,Address,z,Beth);
  989.       '5': Delete(Addr,Address,temp,z);
  990.       '6': DesignLabels(lab);
  991.       '7': List (Addr,lab,z,Beth);
  992.       '8': Secondfile (Entry,Addr,Address,second,Alph,Beth,z);
  993.       '9': Switchfiles(Addr,Address,Alph,Beth,z,flname);
  994.       end;
  995. end;
  996.  
  997. Begin
  998.   Switchfiles(Addr,Address,Alph,Beth,z,flname);
  999.   MainMenu;
  1000.   while which <> '0' do
  1001.         repeat
  1002.   MainMenu;
  1003.     until which= '0';
  1004.   writeln ('Labelmaker was written by Ian Richmond.  I have put it in the public');
  1005.   writeln ('domain with only one stipulation: that it not be sold by anyone but');
  1006.   writeln ('distributed freely.  I cannot be responsible for any damages caused');
  1007.   writeln ('by it operating improperly.  But I will try to back it up.  If you ');
  1008.   writeln (' have any problems with it or want help changing it to fit your ');
  1009.   writeln ('purposes better, call me at: (215) 649-1198 eves. 6-12.');
  1010. end.