home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / MAILER.ZIP / MAILER.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-02-28  |  16.1 KB  |  417 lines
  1. program mailer;
  2. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3.   mailer : Generated by DataGen
  4.   Copyright (C) January, 1988
  5. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  6. uses crt, dos, TAccess, io;
  7.  
  8. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  9.   mailer data structure definition section
  10. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  11. {$I mailer.typ}
  12. var     mailer_data   : mailer_structure;
  13.         mailer_file   : datafile;
  14.         index1           : indexfile;
  15.         index2           : indexfile;
  16.  
  17. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  18.   mailer global variable declarations.
  19. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  20. const   NEW_mailer = -1;
  21. var     mailer_record : longint;
  22.         search_index : longint;
  23.  
  24.  
  25. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  26.   mailer screen definition file.
  27. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  28. {$I mailer.scr}
  29. {
  30. *-----------------------------------------------------------------------*
  31.                            function upper_case
  32. *-----------------------------------------------------------------------*
  33. }
  34. function upper_case(in_string : medium_string ) : medium_string;
  35. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  36.   Accepts lower case string, returns upper case string as value of the
  37.   function.
  38. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  39.  
  40. var  out_string : medium_string;
  41.      i          : byte;
  42.  
  43. begin
  44.      out_string := '';
  45.      for i := 1 to length( in_string ) do
  46.          out_string := out_string + upcase( in_string[i] );
  47.      upper_case := out_string;
  48. end; {function upper_case}
  49. {
  50. *-----------------------------------------------------------------------*
  51.                           procedure rebuild_index
  52. *-----------------------------------------------------------------------*
  53. }
  54. procedure rebuild_index;
  55. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  56.   Rebuilds the indices.
  57. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  58. var  record_number : longint;
  59.      key_to_add    : medium_string;
  60. begin
  61.  
  62.         initindex;
  63.         message('Building Index files...',1);
  64.         makeindex( index1, 'mailer.ix1', sizeof(mailer_data.company)-1, 1 );
  65.         makeindex( index2, 'mailer.ix2', sizeof(mailer_data.contact)-1, 1 );
  66.         for record_number := 1 to filelen(mailer_file) - 1 do begin
  67.               getrec(mailer_file,record_number,mailer_data);
  68.               if mailer_data.status = 0 then begin
  69.                            key_to_add := upper_case(mailer_data.company);
  70.                            addkey( index1, record_number, key_to_add );
  71.         
  72.                            key_to_add := upper_case(mailer_data.contact);
  73.                            addkey( index2, record_number, key_to_add);
  74.  
  75.               end; {if}
  76.       end; {for}
  77.       message('Index Files Rebuilt.',1);
  78. end   { rebuild_index };
  79.  
  80. {
  81. *-----------------------------------------------------------------------*
  82.                      procedure open_mailer                            
  83. *-----------------------------------------------------------------------*
  84. }
  85. function open_mailer : boolean;
  86. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  87.   Opens files and returns true, false if user wants to QUIT.             
  88. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  89. begin
  90. open_mailer := true;
  91. OpenFile( mailer_file, 'mailer.dat', sizeof( mailer_data ));
  92. if not ok then begin
  93.        message('WELCOME TO mailer',1);
  94.        if get_menu('\1Yes\2Quit','',1,'\qFILES NOT FOUND, INITIALIZE? :') = 1 then begin
  95.          makefile( mailer_file, 'mailer.dat',sizeof(mailer_data));
  96.          makeindex( index1, 'mailer.ix1',sizeof( mailer_data.company)-1,1);
  97.          makeindex( index2, 'mailer.ix2',sizeof( mailer_data.contact)-1,1);
  98.        end {if}
  99.        else open_mailer := false;
  100.        exit;
  101. end {if}
  102. else begin
  103.          openindex(index1, 'mailer.ix1', sizeof( mailer_data.company)-1,1 );
  104.          openindex(index2, 'mailer.ix2', sizeof( mailer_data.contact)-1,1 );
  105.  
  106. end; {else}
  107. end; {function open_mailer}
  108. {
  109. *-----------------------------------------------------------------------*
  110.                         procedure close_mailer                        
  111. *-----------------------------------------------------------------------*
  112. }
  113. procedure close_mailer;
  114. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  115.   closes the mailer data and index files.                             
  116. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  117. begin
  118.          closefile( mailer_file );
  119.          closeindex( index1 );
  120.          closeindex( index2 );
  121. end; {procedure close_mailer}
  122. {
  123. *-----------------------------------------------------------------------*
  124.                      procedure retrieve_mailer
  125. *-----------------------------------------------------------------------*
  126. }
  127. procedure retrieve_mailer( param : byte ) ;
  128. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  129.   Brings in the next, previous, first, last record based on param.       
  130. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  131. var recnum        : longint;
  132.     key_to_search : long_string;
  133.  
  134. begin
  135.        if param in [1,2]  then case search_index of
  136.             2 : clearkey( index1 );
  137.             3 : clearkey( index2 );
  138.        end; {case}
  139.  
  140.        if param in [1,3] then case search_index of
  141.               2:   nextkey( index1, recnum, key_to_search );
  142.               3:   nextkey( index2, recnum, key_to_search );
  143.        end; {case}
  144.        if param in [2,4] then case search_index of
  145.               2:   prevkey( index1, recnum, key_to_search );
  146.               3:   prevkey( index2, recnum, key_to_search );
  147.        end; {case}
  148.  
  149.        if ok then begin
  150.              getrec(mailer_file, recnum, mailer_data);
  151.              mailer_record := recnum;
  152.              mailer_screen('\2');
  153.        end {if}
  154.        else message('NO RECORD',1);
  155.  
  156.  
  157. end; {procedure retrieve_mailer}
  158. {
  159. *-----------------------------------------------------------------------*
  160.                     procedure find_mailer
  161. *-----------------------------------------------------------------------*
  162. }
  163. procedure find_mailer;
  164. var recnum        : longint;
  165.     key_to_search : long_string;
  166. begin
  167.       if usedrecs( mailer_file ) = 0 then begin
  168.                    message('ERROR : FILE IS EMPTY',2);
  169.                    exit;
  170.       end;
  171.       case get_menu('\1First\2Last\3Search\4Rebuild\5Exit',
  172.            '\1First Record\2Last Record\3Search by Index\4Rebuild Index files',1,'\qOPTION : ') of
  173.  
  174.       1:  retrieve_mailer(1);
  175.       2:  retrieve_mailer(2);
  176.       3:  begin
  177.                  fillchar(mailer_data, sizeof(mailer_data), 0);
  178.                  mailer_screen('\2\3\index');
  179.                  case search_index of
  180.                  2 : begin key_to_search := upper_case(mailer_data.company);
  181.                                   searchkey( index1, recnum, key_to_search);
  182.                             end;
  183.         
  184.                  3 : begin key_to_search := upper_case(mailer_data.contact);
  185.                                   searchkey( index2, recnum, key_to_search);
  186.                             end;
  187.  
  188.                  end; {case}
  189.                  if ok then begin
  190.                          getrec( mailer_file, recnum, mailer_data);
  191.                          mailer_record := recnum;
  192.                          mailer_screen('\2');
  193.                  end {if}
  194.                  else retrieve_mailer(2);
  195.       end; {case 3}
  196.       4:      rebuild_index;
  197.       5:      ;
  198.  
  199.       end; {case}
  200. end; {procedure find_mailer}
  201.  
  202. {
  203. *---------------------------------------------------------------------*
  204.                       procedure fill_mailer                         
  205. *---------------------------------------------------------------------*
  206. }
  207. function fill_mailer : byte;
  208. var       select : integer;
  209.           mailer_save : mailer_structure;
  210. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  211.   Allows the user to Alter the contents of a passed mailer record.  
  212. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  213. begin
  214. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  215.   Save the old record in case they cancel session.
  216. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  217.         mailer_save := mailer_data;
  218.  
  219. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  220.   New record? blank out the data structure.
  221. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  222.         if mailer_record = NEW_mailer then begin
  223.                 fillchar( mailer_data, sizeof( mailer_data ), 0 );
  224.                 mailer_screen( '\2' );    {blank out the fields}
  225.         end; {if}
  226.         mailer_screen('\3');           {permit filling of fields}
  227.  
  228. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  229.   Permit the user to fill the mailer structure.
  230. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  231.         select :=2;
  232.         repeat
  233.                 select := get_menu('\1Edit\2Save\3Cancel',
  234.                 '\1Edit Screen Information\2Save Data\3Cancel & Return',
  235.                 select, '\qEDIT OPTION: ');
  236.  
  237.                 fill_mailer := select;
  238.  
  239.                 case select of
  240.                 1: mailer_screen('\3');
  241.                 2: exit;
  242.                 3: begin
  243.                         mailer_data := mailer_save;
  244.                         mailer_screen('\2');
  245.                         exit;
  246.                    end;
  247.                 end; {case}
  248.  
  249.         until false;
  250.  
  251. end; {procedure fill_mailer}
  252. {
  253. *-----------------------------------------------------------------------*
  254.                          procedure delete_mailer                      
  255. *-----------------------------------------------------------------------*
  256. }
  257. procedure delete_mailer;
  258. var key_to_delete : medium_string;
  259.  
  260. begin
  261.      if mailer_record = NEW_mailer then begin
  262.                      message('Please Select a Record for Deletion',2);
  263.                      exit;
  264.      end;
  265.      if get_menu('\1Yes\2Cancel','',1,'\qDELETE CURRENT RECORD? : ') = 1
  266.      then begin
  267.                key_to_delete := upper_case(mailer_data.company);
  268.                deletekey( index1, mailer_record, key_to_delete);
  269.         
  270.                key_to_delete := upper_case(mailer_data.contact);
  271.                deletekey( index2, mailer_record, key_to_delete);
  272.  
  273.                deleterec( mailer_file, mailer_record );
  274.                message('Deleted...',1);
  275.                mailer_record := NEW_mailer;
  276.                if usedrecs( mailer_file ) = 0 then begin
  277.                        clearkey( index1 );
  278.                        clearkey( index2 );
  279.  
  280.                        fillchar( mailer_data, sizeof( mailer_data ), 0);
  281.                        mailer_screen('\2');
  282.                        message('FILE IS EMPTY',1);
  283.                end {if}
  284.                else retrieve_mailer(1);
  285.      end; {if}
  286. end; {procedure delete_mailer}
  287.  
  288. {
  289. *-----------------------------------------------------------------------*
  290.                        procedure add_mailer
  291. *-----------------------------------------------------------------------*
  292. }
  293. procedure add_mailer;
  294. var key_string        : medium_string;
  295.     recnum            : longint;
  296.     save_mailer_record : longint;
  297.     key_to_add        : medium_string;
  298.  
  299. begin
  300.      save_mailer_record := mailer_record;
  301.      mailer_record := NEW_mailer;
  302.  
  303.      if fill_mailer = 3 then
  304.                     mailer_record := save_mailer_record
  305.      else begin
  306.                     addrec( mailer_file, recnum, mailer_data );
  307.                     mailer_record := recnum;
  308.                     key_to_add := upper_case(mailer_data.company);
  309.                     addkey( index1, recnum, key_to_add );
  310.         
  311.                     key_to_add := upper_case(mailer_data.contact);
  312.                     addkey( index2, recnum, key_to_add );
  313.  
  314.                     mailer_screen('\2');
  315.      end; {else}
  316. end; {procedure add_mailer}
  317. {
  318. *-----------------------------------------------------------------------*
  319.                            procedure edit_mailer                      
  320. *-----------------------------------------------------------------------*
  321. }
  322. procedure edit_mailer;
  323. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  324.   Allows the user to edit a mailer.                                   
  325. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  326.  
  327. var
  328.               save_company              : medium_string;
  329.               save_contact              : medium_string;
  330.               work_key                : medium_string;
  331.  
  332. begin
  333.       if mailer_record <> NEW_mailer then begin
  334.               save_company := mailer_data.company;
  335.               save_contact := mailer_data.contact;
  336.         if fill_mailer = 2 then
  337.               putrec(mailer_file, mailer_record, mailer_data);
  338.  
  339.         if upper_case(save_company) <> upper_case(mailer_data.company) then begin
  340.               work_key := upper_case( save_company );
  341.               deletekey( index1, mailer_record, work_key );
  342.               work_key := upper_case( mailer_data.company );
  343.               addkey( index1, mailer_record, work_key);
  344.         end; {if}
  345.         
  346.         if upper_case(save_contact) <> upper_case(mailer_data.contact) then begin
  347.               work_key := upper_case( save_contact );
  348.               deletekey( index2, mailer_record, work_key );
  349.               work_key := upper_case( mailer_data.contact );
  350.               addkey( index2, mailer_record, work_key);
  351.         end; {if}
  352.  
  353.       end {if}
  354.       else message('Please Select a Record for Editing',2);
  355. end; {procedure edit_mailer}
  356. {
  357. *---------------------------------------------------------------------*
  358.                 MAIN CODE FOR procedure maintain_mailer             
  359. *---------------------------------------------------------------------*
  360. }
  361. var     select : integer;
  362.  
  363. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  364.   Supervisory routine for mailer maintenance routines.
  365. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  366. begin
  367. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  368.   Initialize System and Database.
  369. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  370.         set_system;
  371.  
  372. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  373.   Show them a blank entry screen.                                      
  374. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  375.         search_index := 2;
  376.         clrscr;
  377.         if not open_mailer then begin
  378.                               set_cursor(1);
  379.                               exit;
  380.         end; {if}
  381.         mailer_record := NEW_mailer;
  382.         fillchar( mailer_data, sizeof( mailer_data ), 0);
  383.  
  384.         mailer_screen('\1\2');
  385.         message('mailer : Alared Software / 1650 Lexington Avenue / Lakewood, NJ 08701',1);
  386.  
  387. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  388.   Give them the mailer Menu.
  389. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  390.         select := 1;
  391.  
  392.         repeat
  393.                 select := get_menu( '\1Add\2Edit\3Delete\4Next\5Previous'+
  394.                 '\6Find\7Quit',
  395.                 '\1Add Record\2Edit Record\3Delete Record'+
  396.                 '\6First, Last, Search\7Exit to DOS',
  397.                 select, '\qOPTION: ');
  398.  
  399.         case select of
  400.         1:      add_mailer;
  401.         2:      edit_mailer;
  402.         3:      delete_mailer;
  403.         4:      retrieve_mailer(3);
  404.         5:      retrieve_mailer(4);
  405.         6:      find_mailer;
  406.         7:      begin   close_mailer;
  407.                         clrscr;
  408.                         gotoxy(homex, endscry);
  409.                         set_cursor(1);
  410.                         exit;
  411.                 end;
  412.         end; {case}
  413.  
  414.         until false;
  415.  
  416. end. {program mailer}
  417.