home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TFF120.ZIP / F32.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-01-04  |  19.1 KB  |  687 lines
  1. Program FETCH32;  { ljr, 07/23/89, }
  2.  
  3. { (DPMAX) Tech Support Systems LAN INFO TO MEMO GRABBER  }
  4. { the maintainance program with all kinds of locking going on }
  5.  
  6. {$M 32768,13100,65530}
  7.  
  8. USES CRT, MAXVAR, MAXUTIL, MAXKBRD, MAXDBF, MAXLOCK;
  9.  
  10. { used db3 compatable tpu package from: }
  11. { Max Software Consultants Inc          }
  12. {      4101 Greenmount Ave.             }
  13. {  Baltimore, Maryland   21218          }
  14. {          301-323-5996                 }
  15.  
  16. const
  17.    NormalVideo = $07;
  18.    ReverseVideo = $70;
  19.    ScrnSize    = 79;
  20. type
  21.    BuffType = array [1..61] of char;
  22.    String12 = string[12];
  23. Var
  24.    Menu          : char;
  25.    Dbf           : dFile;
  26.    F             : string12;
  27.    FileName      : string12;
  28.    Key_1         : string12;
  29.    Key_2         : string12;
  30.    Key_3         : string12;
  31.    Key_4         : string12;
  32.    Buffer1       : BuffType;                { first get }
  33.    Buffer2       : BuffType;                 { working got }
  34.    Buffer3       : BuffType;                  { re-get before put }
  35.    StrBuf        : array[1..5] of String12;
  36.    FldName       : array[1..5] of Str10;
  37.    RecNum        : RecNr;
  38.    Status        : integer;
  39.    Chr1          : char;    { in CharAdd }
  40.    Sel           : boolean;
  41.    SearchFld     : integer;
  42.    Format        : integer;
  43.    LSTDEV        : Text;
  44.    DeviceName    : String12;
  45.    OutBuf        : String[80];
  46.    Abort         : boolean;
  47.    ReReadOk      : boolean;
  48.  
  49. Procedure Scrn;
  50. begin
  51.    ClrScr;
  52.    TextAttr := (ReverseVideo);
  53.    GoToXY(11,1);
  54.    WriteLn( ' TEXT FILE ''FETCH'' ( DATABASE MAINTAINANCE PROGRAM ) ');
  55.    TextAttr := (NormalVideo);
  56. end;
  57.  
  58. Procedure ReadIn(Var S: String12);
  59. var
  60.    PosE,PosS,PosC: integer;
  61.    OverWrite     : boolean;
  62.  
  63.    Procedure ChrRgt;
  64.    begin
  65.       If PosE < PosC then PosE := PosE + 1 ;
  66.       GoToXY(dp_Abs2X(PosS+PosE,ScrnSize),dp_Abs2Y(PosS+PosE,ScrnSize));
  67.    end;
  68.  
  69.    Procedure ChrLft;
  70.    begin
  71.       If PosE > 0 then PosE := PosE - 1 ;
  72.       GoToXY(dp_Abs2X(PosS+PosE,ScrnSize),dp_Abs2Y(PosS+PosE,ScrnSize));
  73.    end;
  74.  
  75.    Procedure BackSpace;   { Procedure local to ReadIn }
  76.    begin
  77.       If PosE > 0 then
  78.       begin
  79.          GoToXY(dp_Abs2X(PosS+PosE-1,ScrnSize),dp_Abs2Y(PosS+PosE-1,ScrnSize));
  80.          Write(Copy(S, PosE + 1, PosC - PosE)+' ');
  81.          S := Copy(S,1,PosE-1)+Copy(S,PosE+1,PosC-PosE);
  82.          PosE := PosE - 1;
  83.          PosC := PosC - 1;
  84.          GoToXY(dp_Abs2X(PosS+PosE,ScrnSize),dp_Abs2Y(PosS+PosE,ScrnSize));
  85.       end;
  86.    end;
  87.  
  88.    Procedure ChrAdd;   { Procedure local to ReadIn }
  89.    begin
  90.       If Not OverWrite then
  91.       { Insert Characters Mode }
  92.       begin
  93.          if PosC < 12 then
  94.          begin
  95.            GoToXY(dp_Abs2X(PosS+PosE,ScrnSize),dp_Abs2Y(PosS+PosE,ScrnSize));
  96.            Write(Chr1,Copy(S,PosE+1,PosC-PosE));
  97.            S := Copy(S,1,PosE)+Chr1+Copy(S,PosE+1,PosC-PosE);
  98.            PosC := PosC + 1;
  99.            PosE := PosE + 1;
  100.            GoToXY(dp_Abs2X(PosS+PosE,ScrnSize),dp_Abs2Y(PosS+PosE,ScrnSize));
  101.          end
  102.       end
  103.       else
  104.       { Overwrite Characters Mode }
  105.       begin
  106.          if PosC < 12 then
  107.          begin
  108.            GoToXY(dp_Abs2X(PosS+PosE,ScrnSize),dp_Abs2Y(PosS+PosE,ScrnSize));
  109.            Write(Chr1,Copy(S,PosE+2,PosC-PosE-1));
  110.            S := Copy(S,1,PosE)+Chr1+Copy(S,PosE+2,PosC-PosE-1);
  111.            If (PosE = PosC) then PosC := PosC + 1;
  112.            PosE := PosE + 1;
  113.            GoToXY(dp_Abs2X(PosS+PosE,ScrnSize),dp_Abs2Y(PosS+PosE,ScrnSize));
  114.          end;
  115.       end;
  116.    end;
  117.  
  118.    Procedure ChrDel;   { Procedure local to ReadIn }
  119.    begin
  120.       if PosE < PosC Then
  121.       begin
  122.          GoToXY(dp_Abs2X(PosS+PosE,ScrnSize),dp_Abs2Y(PosS+PosE,ScrnSize));
  123.          Write(Copy(S,PosE+2,PosC-PosE-1),' ');
  124.          S := Copy(S, 1, PosE) + Copy(S, PosE + 2, PosC - PosE-1);
  125.          PosC := PosC - 1;
  126.          GoToXY(dp_Abs2X(PosS+PosE,ScrnSize),dp_Abs2Y(PosS+PosE,ScrnSize));
  127.       end;
  128.    end;
  129.  
  130.    Procedure OverWriteChar;
  131.    begin
  132.       OverWrite := NOT Overwrite;
  133.    end;
  134.  
  135. begin
  136.    S := dp_Trim(S);
  137.    PosS := dp_XY2Abs(WhereX,WhereY,ScrnSize);
  138.    PosC := Length(S);
  139.    PosE := PosC;
  140.    Write(S);
  141.    gotoXY (dp_Abs2X(PosC+PosS,ScrnSize),dp_Abs2Y(PosC+PosS,ScrnSize));
  142.    OverWrite := TRUE;
  143.    Abort := TRUE;
  144.    Repeat
  145.       Repeat Until dp_kbrd (Chr1);
  146.       if chr1 = #27 then
  147.       begin
  148.          WriteLn;
  149.          exit;
  150.       end;
  151.       Case Chr1 of
  152.          #8    : if (Length(S)>0) then BackSpace;  { Backspace}
  153.          #203  : ChrLft;                           { Left Arrow}
  154.          #205  : ChrRgt;                           { Rght Arrow}
  155.          #211  : ChrDel;                           { Delete Chr1}
  156.          #210  : OverWriteChar;                    { Insert Chr1}
  157.          else if Chr1 <> #13 then ChrAdd;
  158.       end;
  159.    until Chr1 = #13;
  160.    WriteLn;
  161.    Abort := FALSE;
  162. end;
  163.  
  164. Procedure Menu1;
  165. begin
  166.    GoToXY (22,5);  Write ('Select Function:');
  167.    GoToXY (25,8);  Write ('(1) E N T E R');
  168.    GoToXY (25,10); Write ('(2) E D I T');
  169.    GoToXY (25,12); Write ('(3) R E M O V E');
  170.    GoToXY (25,14); Write ('(4) P R I N T');
  171.    GoToXY (25,16); Write ('(5) E X I T');
  172.  
  173.    TextAttr := (ReverseVideo);
  174.    GoToXY (29,8);  Write ('E');
  175.    GoToXY (31,10); Write ('D');
  176.    GoToXY (29,12); Write ('R');
  177.    GoToXY (29,14); Write ('P');
  178.    GoToXY (31,16); Write ('X');
  179.    TextAttr := (NormalVideo);
  180.    Sel := FALSE;
  181.    Repeat
  182.       GoToXY (29,20);
  183.       Repeat Until dp_kbrd (Chr1);
  184.       if Chr1 IN ['1','2','3','4','5','e','E','d','D','r','R','p','P','x','X'] then sel := TRUE;
  185.    Until Sel;
  186.    menu := chr1;
  187. {   Menu := ORD(Chr1) - 48;  }
  188.    WriteLn(Menu);
  189. end;
  190.  
  191. Procedure Extract;
  192. begin
  193.    FileName      := strbuf[1];
  194.    Key_1         := strbuf[2];
  195.    Key_2         := strbuf[3];
  196.    Key_3         := strbuf[4];
  197.    Key_4         := strbuf[5];
  198. end;
  199.  
  200. Procedure FldNm;
  201. begin
  202.    FldName[1]     := 'FILENAME';
  203.    FldName[2]     := 'KEY_1';
  204.    FldName[3]     := 'KEY_2';
  205.    FldName[4]     := 'KEY_3';
  206.    FldName[5]     := 'KEY_4';
  207. end;
  208.  
  209. Procedure ClrStrBuf;
  210. var
  211.    i : integer;
  212. begin
  213.    For i := 1 to 5 do StrBuf[i] := '';
  214. end;
  215.  
  216. Procedure ClrVar;
  217. begin
  218.    FileName[0]  := #0;
  219.    Key_1[0]     := #0;
  220.    Key_2[0]     := #0;
  221.    Key_3[0]     := #0;
  222.    Key_4[0]     := #0;
  223. end;
  224.  
  225. Procedure OpenFiles;
  226. var
  227.    i : integer;
  228. begin
  229.    Scrn;
  230.    GoToXY (25,5);
  231.    Write (' Please Wait - Opening Files ');
  232.    F := 'FETCH.DBF';
  233.    Result := dp_OpenDBF(F,dplShared,Dbf);
  234.    if Result <> Success then
  235.    begin
  236.       GoToXY (25,12); Write( #07,' ERROR WITH FILE ',F,'.');
  237.       GoToXY (34,14); Write( ' Error #',Result:3,'.');
  238.       GoToXY (30,16); Write( ' Program terminating.');
  239.       Halt;
  240.    end;
  241. end;
  242.  
  243. Procedure CloseFiles;
  244. var
  245.    i : integer;
  246. begin
  247.    Scrn;
  248.    GoToXY (25,5);
  249.    Write (' Please Wait - Closing Files ');
  250.    Result := dp_CloseDBF(Dbf);
  251.    if Result <> Success then
  252.    begin
  253.       GoToXY (25,12); Write( #07,' ERROR WITH FILE ',F,'.');
  254.       GoToXY (34,14); Write( ' Error #',Result:3,'.');
  255.       Delay(3000);
  256.    end;
  257. end;
  258.  
  259. Procedure PutValues;                     { use buffer #2 }
  260. var
  261.    X : Char;
  262.    i : integer;
  263. begin
  264.    FillChar (Buffer2,Sizeof(Buffer2),#32);
  265.    For i := 1 to 5 do
  266.    begin
  267.       Result := dp_PutValue(Dbf,FldName[i],X,Buffer2,StrBuf[i]);
  268.       if Result <> Success then
  269.       begin
  270.          GoToXY (25,12); Write( #07,' ERROR WITH FILE ',F,'.');
  271.          GoToXY (34,14); Write( ' Error #',Result:3,'.');
  272.          GoToXY (26,16); Write( 'Values Not Put into Buffer !');
  273.          GoToXY (28,18); Write( 'Field Name: ',FldName[i]:10,'.');
  274.          Delay(3000);
  275.       end;
  276.    end;
  277. end;
  278.  
  279. Procedure GetValues;                     { use buffer #2 }
  280. var
  281.    X : Char;
  282.    i : integer;
  283. begin
  284.    For i := 1 to 5 do
  285.    begin
  286.       Result := dp_Value(Dbf,FldName[i],X,Buffer2,StrBuf[i]);
  287.       if Result <> Success then
  288.       begin
  289.          GoToXY (25,12); Write( #07,' ERROR WITH FILE ',F,'.');
  290.          GoToXY (34,14); Write( ' Error #',Result:3,'.');
  291.          GoToXY (26,16); Write( 'Values Not Put into Buffer !');
  292.          GoToXY (28,18); Write( 'Field Name: ',FldName[i]:10,'.');
  293.          Delay(3000);
  294.       end;
  295.    end;
  296. end;
  297.  
  298. Procedure ReadRecord;       { use buffer #1 }
  299. begin
  300.    Abort := TRUE;
  301.    Result := dp_LockRec(Dbf,RecNum,1,0);              { lock wait }
  302.    if Result = Success then
  303.      Result := dp_GetRec(Dbf,RecNum,Buffer1,Status);   { get }
  304.    Result := dp_LockRec(Dbf,RecNum,1,2);              { unlock }
  305.    if Result <> Success then
  306.    begin
  307.       GoToXY (25,12); Write( #07,' ERROR WITH FILE ',F,'.');
  308.       GoToXY (34,14); Write( ' Error #',Result:3,'.');
  309.       GoToXY (26,16); Write( ' - Can`t Get Record! ');
  310.       Delay(3000);
  311.    end;
  312.    if Status <> Active then exit;
  313.    Buffer2 := Buffer1;               { **** pass the salt, please }
  314.    GetValues;
  315.    Abort := FALSE;
  316. end;
  317.  
  318. Procedure ReReadRecord;     { use buffer #3 }
  319. begin
  320.    Abort := TRUE;
  321.    Result := dp_LockRec(Dbf,RecNum,1,0);              { lock wait }
  322.    if Result = Success then
  323.      Result := dp_GetRec(Dbf,RecNum,Buffer3,Status);   { get }
  324.    Result := dp_LockRec(Dbf,RecNum,1,2);              { unlock }
  325.  
  326.    if Buffer3 <> Buffer1 then ReReadOk := false;     { the BIG test! }
  327.    if Result <> Success then
  328.    begin
  329.       GoToXY (25,12); Write( #07,' ERROR WITH FILE ',F,'.');
  330.       GoToXY (34,14); Write( ' Error #',Result:3,'.');
  331.       GoToXY (26,16); Write( ' - Can`t Re-Get Record! ');
  332.       Delay(3000);
  333.    end;
  334.    if Status <> Active then exit;
  335.    Abort := FALSE;
  336. end;
  337.  
  338. Procedure AppendRecord;
  339. begin
  340.   Result := dp_LockRec(Dbf,RecNum,1,0);         { lock wait }
  341.   if Result = Success then
  342.     Result := dp_PutRec(Dbf,Append,Buffer2);     { put }
  343.   Result := dp_LockRec(Dbf,RecNum,1,2);         { unlock }
  344.   RecNum := Dbf^.hdr.RecCnt;
  345.   if Result <> Success then
  346.   begin
  347.     GoToXY (25,12); Write( #07,' ERROR WITH FILE ',F,'.');
  348.     GoToXY (34,14); Write( ' Error #',Result:3,'.');
  349.     GoToXY (26,16); Write( 'Values Not Put into DBF !');
  350.     Delay(3000);
  351.   end;
  352. end;
  353.  
  354. Procedure ReSaveRecord;
  355. begin
  356.  { first test the original buf ( got a while back ) with the buf right now  }
  357.  { if they are the same, write it out. if they are different, tell the user }
  358.  { that his rec was changed by someone else.                                }
  359.    ReReadOk := true;
  360.    ReReadRecord;
  361.    if ReReadOk = true then
  362.    begin
  363.      Result := dp_LockRec(Dbf,RecNum,1,0);          { lock wait }
  364.      if Result = Success then
  365.        Result := dp_UpDr(Dbf,RecNum,Buffer2);        { re-save }
  366.      Result := dp_LockRec(Dbf,RecNum,1,2);          { unlock }
  367.      if Result <> Success then
  368.      begin
  369.        GoToXY (25,12); Write( #07,' ERROR WITH FILE ',F,'.');
  370.        GoToXY (34,14); Write( ' Error #',Result:3,'.');
  371.        GoToXY (26,16); Write( 'Values Not Put into DBF!');
  372.        Delay(3000);
  373.      end;
  374.    end
  375.    else
  376.    begin
  377.      GoToXY (25,12); Write( #07,' ERROR WITH FILE ',F,'.');
  378.      GoToXY (26,14); Write( 'Values Not Put into DBF !');
  379.      GoToXY (26,16); Write( 'Someone changed your Record !');
  380.      Delay(3500);
  381.    end;
  382. end;
  383.  
  384. procedure Mini_wipe;
  385. begin
  386.   GoToXY(1,5);
  387.   Writeln('                                            '); {5}
  388.   Writeln('                                            '); {6}
  389.   Writeln('                                            '); {7}
  390.   Writeln('                                            '); {8}
  391.   Writeln('                                            '); {9}
  392.   Writeln('                                            '); {10}
  393.   Writeln('                                            '); {11}
  394.   Writeln('                                            '); {12}
  395.   Writeln('                                            '); {13}
  396.   Writeln('                                            '); {14}
  397.   Writeln('                                            '); {15}
  398.   Writeln('                                            '); {16}
  399.   Writeln('                                            '); {17}
  400.   GoToXY(1,5);
  401. end;
  402.  
  403. Procedure Enter;
  404. var
  405.   i : integer;
  406.   done : boolean;
  407. begin
  408.    Abort := TRUE;
  409.    done := false;
  410.    Scrn;
  411.    GoToXY(1,25);
  412.    Write(' To exit press the <ESC> key...');
  413.    GoToXY(1,3);
  414.    WriteLn( 'ENTER FUNCTION ');
  415.    WriteLn;
  416. { ??? }
  417.   repeat
  418.    WriteLn( 'Current Record Count is ',Dbf^.hdr.RecCnt,'.');
  419.    WriteLn;
  420.    ClrStrBuf;
  421.    For i := 1 to 5 do
  422.    begin
  423.       Write(FldName[i],'? ');
  424.       ReadIn(StrBuf[i]);
  425.       if Abort then exit;
  426.    end;
  427.    PutValues;
  428.    if Result = Success then AppendRecord;    { of the put action }
  429.    if Result = Success then                  { of the append action }
  430.    begin
  431.      WriteLn;
  432.      WriteLn(' Success, Record Count is now ',Dbf^.hdr.RecCnt,'.');
  433.      Delay(500);
  434.    end;
  435.    Writeln;
  436.    Write(' Add another at this time? ');
  437.    Repeat Until dp_kbrd (Chr1);
  438.    WriteLn(Chr1);
  439.    if not (Chr1 IN [ 'Y','y']) then done := true;
  440.    if (Chr1 IN [ 'Y','y']) then mini_wipe;
  441.  
  442.    until done;
  443.    Abort := FALSE;
  444. end;
  445.  
  446. Procedure Edit;
  447. var
  448.    i    : integer;
  449.    Temp : string12;
  450. begin
  451.    Abort := TRUE;
  452.    Scrn;
  453.    GoToXY(1,25);
  454.    Write(' To exit press the <ESC> key...');
  455.    GoToXY(1,3);
  456.    WriteLn( 'EDIT FUNCTION ');
  457.    WriteLn;
  458.    Temp := '';
  459.    repeat
  460.       GoToXY(1,5);
  461.       Write( 'Type Record Number to edit: ');
  462.       ReadIn(Temp);
  463.       if Abort then exit;
  464.       Val (Temp,RecNum,i);
  465.       if (Recnum < 1) or (RecNum > Dbf^.hdr.RecCnt) then
  466.       begin
  467.          Write('Record Number out of range.');
  468.          i := 1;
  469.       end;
  470.    Until i = 0;
  471.    WriteLn;
  472.    ReadRecord;
  473.    if Abort then exit;
  474.    For i := 1 to 5 do
  475.    begin
  476.       WriteLn(FldName[i]+': ':12,StrBuf[i]);
  477.       Write('New ? ':12);
  478.       Temp := StrBuf[i];
  479.       ReadIn(Temp);
  480.       if Abort then exit;
  481.       StrBuf[i] := Temp
  482.    end;
  483.    PutValues;
  484.    ResaveRecord;
  485.  
  486.    while not ReReadOk do           { do it over till okay }
  487.    begin
  488.    ReadRecord;
  489.    if Abort then exit;
  490.    GoToXY(1,7);
  491.    For i := 1 to 5 do
  492.      begin
  493.        WriteLn(FldName[i]+': ':12,StrBuf[i]);
  494.        Write('New ? ':12);
  495.        Temp := StrBuf[i];
  496.        ReadIn(Temp);
  497.        if Abort then exit;
  498.        StrBuf[i] := Temp
  499.      end;
  500.      PutValues;
  501.      if Result = Success then ResaveRecord;
  502.    end;
  503.    if ReReadOk then
  504.    begin
  505.      WriteLn;
  506.      WriteLn(' Success! Record edit saved.');
  507.      Delay(2000);
  508.    end;
  509.    Abort := FALSE;
  510. end;
  511.  
  512. Procedure Remove;
  513. var
  514.    Temp : string12;
  515.    i    : integer;
  516.    LongInteger, Max : LongInt;
  517. begin
  518.    Scrn;
  519.    GoToXY(1,25);
  520.    Write(' To exit press the <ESC> key...');
  521.    GoToXY(1,3);
  522.    WriteLn( 'REMOVAL FUNCTION ');
  523.    WriteLn;
  524.    Temp := '';
  525.    repeat
  526.       GoToXY(1,5);
  527.       Write( 'Type Record Number to remove: ');
  528.       ReadIn(Temp);
  529.       if Abort then exit;
  530.       Val (Temp,RecNum,i);
  531.       if (Recnum < 1) or (RecNum > Dbf^.hdr.RecCnt) then
  532.       begin
  533.          Write('Record Number out of range.');
  534.          i := 1;
  535.       end;
  536.    Until i = 0;
  537.    WriteLn;
  538.    ReadRecord;
  539.    if Abort then exit;
  540.    For i := 1 to 5 do WriteLn(FldName[i]+': ':12,StrBuf[i]);
  541.    WriteLn;
  542.    Write('Remove this record, are you sure? ');
  543.    Repeat Until dp_kbrd (Chr1);
  544.    WriteLn(Chr1);
  545.    if not (Chr1 IN [ 'Y','y']) then exit;
  546.    WriteLn(' Deletion in progress. ');
  547.  
  548.    { mark it for deletion }
  549.    Result := dp_delrec ( Dbf,RecNum );
  550.    if Result <> Success then
  551.    begin
  552.       GoToXY (25,18); Write( #07,' ERROR WITH FILE ',F,'.');
  553.       GoToXY (34,20); Write( ' Error #',Result:3,'.');
  554.       GoToXY (26,22); Write( 'Record not marked for removal !');
  555.       Delay(3000);
  556.    end;
  557.  
  558.    if Result = Success then     { walk through the db and PACK it }
  559.    begin
  560.       Max := Dbf^.hdr.RecCnt;
  561.       LongInteger := 1;
  562.       while (LongInteger <= Max) do
  563.       begin
  564.          RecNum := LongInteger;    { convert type }
  565.          Result := dp_LockRec(Dbf,RecNum,1,0);              { lock it }
  566.          if Result = Success then
  567.            Result := dp_GetRec(Dbf,RecNum,Buffer1,Status);  { get it }
  568.          Result := dp_LockRec(Dbf,RecNum,1,2);              { unlock it }
  569.          if (Result = Success) and (Status = Inactive) then
  570.          begin
  571.             Result := dp_LockRec(Dbf,RecNum,1,0);         { lock again }
  572.             if Result = Success then
  573.               Result := dp_rmvrec ( Dbf,RecNum );         { remove! }
  574.             Result := dp_LockRec(Dbf,RecNum,1,2);         { unlock again }
  575.             if ( Result = Success ) then
  576.                LongInteger := LongInteger - 1
  577.             else
  578.             begin
  579.               GoToXY (25,18); Write( #07,' ERROR WITH FILE ',F,'.');
  580.               GoToXY (34,20); Write( ' Error #',Result:3,'.');
  581.               GoToXY (26,22); Write( 'Record not removed !');
  582.               Delay(3000);
  583.             end;
  584.          end;
  585.          LongInteger := LongInteger + 1;
  586.       end;
  587.    end;
  588.    if Result = Success then
  589.    begin
  590.      WriteLn;
  591.      WriteLn(' Success! Record marked, removed, repacked.');
  592.      Delay(2000);
  593.    end;
  594. end;
  595.  
  596. Procedure PrintMaster;
  597. begin
  598.    OutBuf := '';
  599.    OutBuf := FileName + ' ' + Key_1  + ' ' + Key_2 + ' ' + Key_3 + ' ' + Key_4;
  600.    Writeln(LSTDEV,OutBuf);
  601. end;
  602.  
  603. Procedure PrintRecords;
  604. var
  605.    i : integer;
  606. begin
  607.    RecNum := 1;
  608.    WriteLn(LSTDEV,'Total Available Records are ',Dbf^.hdr.RecCnt,'.');
  609.    WriteLn(LSTDEV,'═════════════════════════════════════════════════════════════════════');
  610.    For i := 1 to Dbf^.hdr.RecCnt do
  611.      begin
  612.        ReadRecord;
  613.        GetValues;
  614.        Extract;
  615.        PrintMaster;
  616.        RecNum := RecNum + 1;
  617.      end;
  618.    if (DeviceName = 'CON') or (DeviceName = 'con') then
  619.    begin
  620.      Write(LSTDEV,'Press any key to continue...');
  621.      repeat until keypressed;
  622.    end;
  623. end;
  624.  
  625. Procedure SelectDevice;
  626. begin
  627.    Abort := TRUE;
  628.    Sel := FALSE;
  629.    DeviceName := 'PRN';
  630.    Repeat
  631.       GoToXY(1,3);
  632.       WriteLn ( 'Select Output Device');
  633.       GoToXY(1,10);
  634.       WriteLn ( '["CON" is okay, a File are okay also, however, it will be overwritten.]');
  635.       Write   ( 'Device Name: ');
  636.       ReadIn  ( DeviceName );
  637.       if Abort then exit;
  638.       {$I-} Assign (LSTDEV,DeviceName); {$I+}
  639.       Result := IOResult;
  640.       if Result = Success then
  641.       begin
  642.          {$I-} ReWrite (LSTDEV); {$I+}
  643.          Result := IOResult;
  644.       end;
  645.       if Result = Success then Sel := TRUE;
  646.    Until Sel;
  647.    Abort := FALSE;
  648. end;
  649.  
  650. Procedure Print;
  651. begin
  652.    Abort := TRUE;
  653.    Scrn;
  654.    GoToXY(1,25);
  655.    Write(' To exit press the <ESC> key...');
  656.    GoToXY(1,3);
  657.    WriteLn( 'PRINT FUNCTION ');
  658.    SelectDevice;
  659.    if Abort then Exit;
  660.    PrintRecords;
  661.    Abort := FALSE;
  662. end;
  663.  
  664.                { M A I N }
  665. begin
  666.    directvideo := false;
  667.    TextAttr := (NormalVideo);
  668.    FileMode := $42;          { LAN sharing mode, full access permitted }
  669.                        { see Dos Tech Ref, INT 21, funct 3D, file open }
  670.    OpenFiles;
  671.    FldNm;
  672.    ClrStrBuf;
  673.    ClrVar;
  674.    Repeat
  675.       Scrn;
  676.       Menu1;
  677.       Case Menu of
  678.          '1','E','e' : Enter;
  679.          '2','D','d' : Edit;
  680.          '3','R','r' : Remove;
  681.          '4','P','p' : Print;
  682.       end;
  683.    Until ((Menu = '5') or (Menu = 'X') or (Menu = 'x'));
  684.    CloseFiles;
  685.    ClrScr;
  686. end.
  687.