home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TFF120.ZIP / F42.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-01-04  |  13.3 KB  |  468 lines
  1. program fetch42;    { ljr }
  2.  
  3. { tss text file database fetch and show, ver 1.00, 2/20/89 }
  4. { install file lock/unlock for LAN }
  5. { modify, 7/25/89 }
  6.  
  7. {$M 16384,1024,16384}
  8.  
  9. USES DOS, CRT, MAXVAR, MAXUTIL, MAXKBRD, MAXDBF;
  10.  
  11. const
  12.   NormalVideo  = $07;
  13.   ReverseVideo = $70;
  14.  
  15. type
  16.   str80 = string[80];
  17. var
  18.   KeyHead  : word absolute $0000:$041A;
  19.   KeyTail  : word absolute $0000:$041C;
  20.   PrgmName : string[12];
  21.   WFetchF  : string[12];
  22.   FetchF   : array [1..20] of string[12];
  23.   Dbf      : dFile;
  24.   F        : str255;
  25.   FileName : string[12];
  26.   Key_1    : string[12];
  27.   FetchK1  : array [1..20] of string[12];
  28.   Key_2    : string[12];
  29.   FetchK2  : array [1..20] of string[12];
  30.   Key_3    : string[12];
  31.   FetchK3  : array [1..20] of string[12];
  32.   Key_4    : string[12];
  33.   FetchK4  : array [1..20] of string[12];
  34.   Buffer   : array [1..61] of char;
  35.   StrBuf   : array [1..5] of Str80;
  36.   FldName  : array [1..5] of Str10;
  37.   RecNum   : RecNr;
  38.   Status   : integer;
  39.   KeyWord1 : string[12];
  40.   KeyWord2 : string[12];
  41.   KeyWord3 : string[12];
  42.   KeyWord4 : string[12];
  43.   NmbrofKeys : byte;
  44.   NmbrofMatches : byte;
  45.   ii : byte;
  46.   iii : byte;
  47.   Ch : char;
  48.   Match    : boolean;
  49.   Abort    : boolean;
  50.   EscPress : boolean;
  51.  
  52. Procedure Beep;
  53. begin
  54.    Sound(554); Delay(25);
  55.    NoSound;    Delay(25);
  56.    Sound(415); Delay(50);
  57.    NoSound;
  58. end;
  59.  
  60. Procedure Scrn;
  61. begin
  62.    ClrScr;
  63.    TextAttr := ReverseVideo;
  64.    GoToXY(5,1);
  65.    WriteLn(' TEXT FILE ''FETCH'' ( text file fetch and display program ) ver 1.10 ');
  66.    TextAttr := NormalVideo;
  67.    GoToXY (1,25); Write('                                                                        ');
  68.    GoToXY(12,25); Write('TO EXIT THE PROGRAM, JUST PRESS <RTN> ONLY! ');
  69. end;
  70.  
  71. Procedure OpenFile;
  72. begin
  73.    F := 'FETCH.DBF';
  74.    Result := dp_OpenDBF(F,dplShared,Dbf);
  75.     if Result <> Success then
  76.       begin
  77.          GoToXY (25,12); Beep; Write( ' ERROR WITH FILE ',F,'.');
  78.          GoToXY (34,14); Write( ' Error #',Result:3,'.');
  79.          GoToXY (30,16); Write( ' Program terminating.');
  80.          Halt;
  81.       end;
  82. end;
  83.  
  84. Procedure CloseFile;
  85. begin
  86.    Result := dp_CloseDBF(Dbf);
  87.    Delay(500);
  88.    if Result <> Success then
  89.      begin
  90.        GoToXY (25,12); Beep; Write( ' ERROR WITH FILE ',F,'.');
  91.        GoToXY (34,14); Write( ' Error #',Result:3,'.');
  92.        Delay(3000);
  93.      end;
  94. end;
  95.  
  96. Procedure FldNm;
  97. begin
  98.    FldName[1]     := 'FILENAME';
  99.    FldName[2]     := 'KEY_1';
  100.    FldName[3]     := 'KEY_2';
  101.    FldName[4]     := 'KEY_3';
  102.    FldName[5]     := 'KEY_4';
  103. end;
  104.  
  105. Procedure ClrStrBuf;
  106. var
  107.    i : integer;
  108. begin
  109.    For i := 1 to 5 do StrBuf[i,0] := #0;
  110. end;
  111.  
  112. Procedure ClrVar;
  113. begin
  114.    FileName[0] := #0;
  115.    Key_1[0]    := #0;
  116.    Key_2[0]    := #0;
  117.    Key_3[0]    := #0;
  118.    Key_4[0]    := #0;
  119. end;
  120.  
  121. Procedure ClrFetchF;
  122. var
  123.    i : integer;
  124. begin
  125.    For i := 1 to 20 do FetchF[i,0] := #0;
  126. end;
  127.  
  128. Procedure GetKeyWords;
  129. begin
  130.    Scrn;
  131.    NmbrofKeys := 0;
  132.    KeyWord1[0] := #0;
  133.    KeyWord2[0] := #0;
  134.    KeyWord3[0] := #0;
  135.    KeyWord4[0] := #0;
  136.    GoToXY(20,3);
  137.    Write( 'Please enter the 1st key word: ');
  138.    ReadLn(KeyWord1);
  139.    if KeyWord1 <> '' then
  140.    begin
  141.      NmbrofKeys := succ(NmbrofKeys); { I got the first one, bump the count }
  142.      GoToXY(1,4);                    { now go ask for the second }
  143.      Write( 'Please enter the 2nd key word, or <RTN> to start: ');
  144.      ReadLn(KeyWord2);
  145.      if KeyWord2 <> '' then
  146.      begin
  147.        NmbrofKeys := succ(NmbrofKeys); { got the second, bump the count }
  148.        GoToXY(1,5);                    { now ask for the third }
  149.        Write( 'Please enter the 3rd key word, or <RTN> to start: ');
  150.        ReadLn(KeyWord3);
  151.        if KeyWord3 <> '' then
  152.        begin
  153.          NmbrofKeys := succ(NmbrofKeys); { got the third }
  154.          GoToXY(1,6);                    { ask for fourth }
  155.          Write( 'Please enter the 4th key word, or <RTN> to start: ');
  156.          ReadLn(KeyWord4);
  157.          if KeyWord4 <> '' then
  158.            NmbrofKeys := succ(NmbrofKeys); { got the fourth and last one! }
  159.        end;
  160.      end;
  161.    end;
  162. end;
  163.  
  164. Procedure GetValues;
  165. var
  166.    X : Char;
  167.    i : integer;
  168. begin
  169.    For i := 1 to 5 do
  170.    begin
  171.       Result := dp_Value(Dbf,FldName[i],X,Buffer,StrBuf[i]);
  172.       if Result <> Success then
  173.       begin
  174.          GoToXY (25,12); Beep; Write( ' ERROR WITH FILE ',F,'.');
  175.          GoToXY (34,14); Write( ' Error #',Result:3,'.');
  176.          GoToXY (26,16); Write( 'Values Not Fetched From Buffer !');
  177.          GoToXY (28,18); Write( 'Field Name: ',FldName[i]:10,'.');
  178.          Delay(3000);
  179.       end;
  180.    end;
  181. end;
  182.  
  183. Procedure ReadRecord;
  184. begin
  185.    Abort := TRUE;
  186.    Result := dp_GetRec(Dbf,RecNum,Buffer,Status);
  187.    if Result <> Success then
  188.    begin
  189.       GoToXY (25,12); Beep; Write( ' ERROR WITH FILE ',F,'.');
  190.       GoToXY (34,14); Write( ' Error #',Result:3,'.');
  191.       GoToXY (26,16); Write( ' - Can`t Get Record! ');
  192.       Delay(3000);
  193.    end;
  194.    if Status <> Active then exit;
  195.    GetValues;
  196.    Abort := FALSE;
  197. end;
  198.  
  199. Function StripBlankEnds( var s : str80) : str80;
  200. var
  201.    slen : byte absolute s;
  202.    stop : integer;
  203. begin
  204.    stop := slen;
  205.    while (s[stop] = ' ') do
  206.       dec(stop);
  207.    slen := stop;
  208.    StripBlankEnds := s;
  209. end;
  210.  
  211. Procedure Extract;
  212. begin
  213.    FileName := StripBlankEnds(Strbuf[1]);
  214.    Key_1    := StripBlankEnds(Strbuf[2]);
  215.    Key_2    := StripBlankEnds(Strbuf[3]);
  216.    Key_3    := StripBlankEnds(Strbuf[4]);
  217.    Key_4    := StripBlankEnds(Strbuf[5]);
  218. end;
  219.  
  220. Procedure MatchTest;
  221. begin
  222.   Match := false;
  223.   if (Key_1 = KeyWord1) then
  224.     if NmbrofKeys > 1 then
  225.       if (Key_2 = KeyWord2) then
  226.         if NmbrofKeys > 2 then
  227.           if (Key_3 = KeyWord3) then
  228.             if NmbrofKeys > 3 then
  229.               if (Key_4 = KeyWord4) then
  230.               begin
  231.                 WFetchF := FileName; { match 4 }
  232.                 Match := true;
  233.               end
  234.               else Match := false { 4th keyword failed match, switch T to F }
  235.             else { match 3 and no more key to test }
  236.             begin
  237.               WFetchF := FileName;
  238.               Match := true;
  239.             end
  240.           else Match := false { 3rd keyword failed match }
  241.         else { match 2 and no more key to test }
  242.         begin
  243.           WFetchF := FileName;
  244.           Match := true;
  245.         end
  246.       else Match := false { 2nd keyword failed match }
  247.     else { match 1 and no more key to test }
  248.     begin
  249.       WFetchF := FileName;
  250.       Match := true;
  251.     end;
  252. end;
  253.  
  254. Procedure ScanDbf;
  255. var
  256.    i,
  257.    total : integer;
  258. begin
  259.    i := 0;
  260.    RecNum := 1;
  261.    total := Dbf^.hdr.RecCnt;
  262.    GoToXY (1,3);
  263.    Write('                                                               ');
  264.    GoToXY (1,4);
  265.    Write('                                                               ');
  266.    GoToXY (1,5);
  267.    Write('                                                               ');
  268.    GoToXY (1,6);
  269.    Write('                                                               ');
  270.    GoToXY (1,3);
  271.    WriteLn('Total Records being scanned are ',total,'.');
  272.    GoToXY (1,4);
  273.    WriteLn('════════════════════════════════════════════════════════════════════════════════');
  274.    repeat
  275.      repeat
  276.        begin
  277.          ReadRecord;
  278.          Extract;
  279.          MatchTest;
  280.          RecNum := RecNum + 1;
  281.        end;
  282.      until (Match) or (RecNum = succ(total));
  283.  
  284.      if (match) and (i < 20) then  { only allow 20 max }
  285.        begin
  286.          i := succ(i);
  287.          FetchF[i]  := WFetchF;
  288.          FetchK1[i] := Key_1;
  289.          FetchK2[i] := Key_2;
  290.          FetchK3[i] := Key_3;
  291.          FetchK4[i] := Key_4;
  292.          GoToXY(1,4 + i);
  293.          if i < 10 then
  294.            Write('Match: ')
  295.          else
  296.            Write('Match:');
  297.          Write(i,'=> ',FileName,', ',Key_1,', ',
  298.           Key_2,', ',Key_3,', ',Key_4);
  299.          Match := false;
  300.        end;
  301.  
  302.      if (match) and (i = 20) then  { only allow 20 max }
  303.        begin
  304.          GoToXY (1,25); Write('                                                                        ');
  305.          GoToXY (22,25);
  306.          Beep;
  307.          TextAttr := ReverseVideo;
  308.          Write('  MORE THAN 20 MATCHES FOUND!  ');
  309.          delay(4000);
  310.          TextAttr := NormalVideo;
  311.          GoToXY (22,25);
  312.          Write('                               ');
  313.  
  314.          { because it has collected 20, lets force the loop to a stop }
  315.          RecNum := succ(total);
  316. {         i := pred(i);                }
  317.          Match := false;
  318.        end;
  319.  
  320.    until RecNum = succ(total);
  321.    NmbrofMatches := i;
  322.    if WFetchF = '' then
  323.      begin
  324.        TextAttr := ReverseVideo;
  325.        GoToXY (18,12); Beep; Write( ' NO MATCHES FOUND IN ',F,'.');
  326.        delay(2000);
  327.        TextAttr := NormalVideo;
  328.        GoToXY (18,12); Write('                                   ');
  329.      end;
  330. end;
  331.  
  332. procedure Showit;
  333. begin
  334.   WFetchF := FetchF[ii];
  335.   GoToXY(1,4 + ii);
  336.   if ii < 10 then
  337.     Write('Match: ')
  338.   else
  339.     Write('Match:');
  340.     Write(ii,'=> ',FetchF[ii],', ',FetchK1[ii],', ',
  341.     FetchK2[ii],', ',FetchK3[ii],', ',FetchK4[ii]);
  342. end;
  343.  
  344. begin                          { M A I N }
  345.   directvideo := false;
  346.   TextAttr := (NormalVideo);
  347.   FileMode := $42;  { hex number: sharing mode = full access permitted }
  348.                     { see INT 21, function 3D, open a file }
  349.   OpenFile;
  350.   FldNm;
  351.   ClrStrBuf;
  352.   ClrVar;
  353.   ClrFetchF;
  354.   PrgmName := 'XLIST.COM';
  355.   WFetchF[0] := #0;
  356.   repeat
  357.     GetKeyWords;
  358.     if KeyWord1 <> '' then ScanDbf; { scan all the db's, find all matches }
  359.  
  360.     if WFetchF <> '' then
  361.       begin
  362.         ii := 0;
  363.         GoToXY (1,25); Write('                                                                        ');
  364.         GoToXY (1,25); Write('PRESS HOME, END, UP/DOWN ARROW TO SELECT: <RTN> TO VIEW: <ESC> TO EXIT!');
  365.  
  366.         repeat          { the main loop }
  367.           EscPress := false;
  368.           ii := succ(ii);
  369.           iii := 0;
  370.           GoToXY (1,3);
  371.           Write('Total Records scanned were ',Dbf^.hdr.RecCnt,'.');
  372.           WriteLn('   Total Matches found were ',NmbrofMatches,'.');
  373.           GoToXY (1,4);
  374.           WriteLn('════════════════════════════════════════════════════════════════════════════════');
  375.  
  376.           repeat        { a sub loop, to show all the matches found }
  377.             iii := succ(iii);
  378.             WFetchF := FetchF[iii];
  379.             GoToXY(1,4 + iii);
  380.             if iii < 10 then
  381.               Write('Match: ')
  382.             else
  383.               Write('Match:');
  384.             Write(iii,'=> ',FetchF[iii],', ',FetchK1[iii],', ',
  385.              FetchK2[iii],', ',FetchK3[iii],', ',FetchK4[iii]);
  386.           until iii = NmbrofMatches;
  387.  
  388.           repeat
  389.             TextAttr := ReverseVideo; { initially, highlight the top one }
  390.             ShowIt;
  391.             TextAttr := NormalVideo;
  392.  
  393.             Ch := ReadKey;
  394.             if Ch = #27 then
  395.               begin
  396.                 EscPress := true;
  397.                 Ch       := #13;
  398.               end;
  399.             if Ch = #0 then begin
  400.               Ch := ReadKey;
  401.               case Ch of
  402.                 #71 : if (ii <> 1) then             {go to the top}
  403.                   begin
  404.                     ShowIt;                  { un-highlight the current one }
  405.                     ii := 1;
  406.                     TextAttr := ReverseVideo;   { now highlight the top one }
  407.                     ShowIt;
  408.                     TextAttr := NormalVideo;
  409.                   end;
  410.                 #72, #73 : if (ii > 1) then           {go upward}
  411.                   begin
  412.                     ShowIt;
  413.                     Dec(ii);
  414.                     TextAttr := ReverseVideo;  { highlight the next one }
  415.                     ShowIt;
  416.                     TextAttr := NormalVideo;
  417.                   end;
  418.                 #79 : if (ii <> NmbrofMatches) then   {go to the bottom}
  419.                   begin
  420.                     ShowIt;
  421.                     ii := NmbrofMatches;
  422.                     TextAttr := ReverseVideo;  { highlight the bottom one }
  423.                     ShowIt;
  424.                     TextAttr := NormalVideo;
  425.                   end;
  426.                 #80, #81 : if (ii < NmbrofMatches) then   {go downward}
  427.                   begin
  428.                     ShowIt;
  429.                     Inc(ii);
  430.                     TextAttr := ReverseVideo;  { highlight the top one }
  431.                     ShowIt;
  432.                     TextAttr := NormalVideo;
  433.                   end;
  434.               end; { case }
  435.             end; { if ch = #0 }
  436.           until ch = #13;
  437.  
  438.           if EscPress then
  439.             begin
  440.               ii := NmbrofMatches;
  441.             end
  442.           else
  443.             begin
  444.  
  445.           SwapVectors;
  446.           KeyTail := KeyHead;  { clr the keyboard buffer, via pointers }
  447.           Exec( PrgmName, WFetchF );
  448.           SwapVectors;
  449.  
  450.             end;
  451.           Scrn;
  452.           GoToXY (1,25); Write('PRESS HOME, END, UP/DOWN ARROW TO SELECT: <RTN> TO VIEW: <ESC> TO EXIT!');
  453.         until ii = NmbrofMatches;
  454.  
  455.         WFetchF[0] := #0;   { re-zero the file name }
  456.         ClrScr;         { to wash the xlist screen away }
  457.         if DosError <> 0 then
  458.           begin
  459.             WriteLn('Dos error #', DosError);
  460.             WriteLn('Couldn''t find the XLIST program');
  461.           end;
  462.         WriteLn;
  463.       end;
  464.   until KeyWord1 = '';
  465.   CloseFile;
  466.   ClrScr;
  467. end.
  468.