home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / database / gsdb28 / gs_db3wk.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-02-24  |  13.2 KB  |  449 lines
  1. Unit GS_dB3Wk;
  2. {------------------------------------------------------------------------------
  3.                               DBase File Builder
  4.  
  5.        Copyright (c)  Richard F. Griffin
  6.  
  7.        20 February 1992
  8.  
  9.        102 Molded Stone Pl
  10.        Warner Robins, GA  31088
  11.  
  12.        -------------------------------------------------------------
  13.        This unit creates dBase files.
  14.  
  15.        GS_dB3_Create builds a dBase III file structure and creates the .DBF
  16.        and .DBT files as necessary.  Fields are built interactively from the
  17.        screen.
  18.  
  19.        GS_dB3_Build writes a dBase III file structure and creates the .DBF
  20.        and .DBT files as necessary.  Uses a previously created table of field
  21.        descriptors.  Called as follows:
  22.  
  23. -------------------------------------------------------------------------------}
  24. interface
  25. {$D-}
  26.  
  27. Procedure GS_dB3_Build(fName : string; FTabl : pointer; n : integer);
  28. Function GS_dB3_Create(fName : string) : boolean;
  29.  
  30. implementation
  31. uses
  32.    CRT,
  33.    DOS,
  34.    GS_FileH,
  35.    GS_KeyI,
  36.    GS_Winfc,
  37.    GS_Strng,
  38.    GS_dBase;
  39.  
  40. CONST
  41.    EofMark     : Byte = $1A;          {Byte to indicate end of file}
  42.    EohMark     : Byte = $0D;          {Byte stored at end of the header}
  43.    dB3File     : Byte = $03;
  44.    dB3WithMemo : Byte = $83;
  45.  
  46. type
  47.    FldRecPtr   = ^FldRecTyp;
  48.    FldRecTyp   = array[1..GS_dBase_MaxRecField] of GS_dBase_Field;
  49.  
  50. var
  51.    FileWin,
  52.    StatWin  : GS_Wind_Objt;
  53.    InputStr       : GS_KeyI_Objt;
  54.    FCnt,
  55.    LCnt,
  56.    PCnt,
  57.    BeginFPos      : integer;
  58.    EndFPos        : integer;
  59.    FldRec         : FldRecPtr;
  60.    dFile          : file;
  61.    HeadRec        : GS_dBase_Head;
  62.    FileName       : string;
  63.    rsl,
  64.    yy, mm, dd, wd : word;             {Variables to hold GetDate values}
  65.    rl, i          : integer;          {Working variables}
  66.  
  67. function Quit_Keys : boolean;
  68. begin
  69.    if (GS_KeyI_Esc) or (GS_KeyI_Chr = Kbd_CEnd) then Quit_Keys := true
  70.       else Quit_Keys := false;
  71. end;
  72.  
  73. procedure WriteXYString(x,y,l : integer; s : string);
  74. begin
  75.    GoToXY(x,y);
  76.    write(s,'':l-length(s));
  77. end;
  78.  
  79. procedure WriteXYInteger(x,y,l,v : integer);
  80. begin
  81.    GoToXY(x,y);
  82.    write(v:l);
  83. end;
  84.  
  85.  
  86. procedure ShowFields;
  87. var
  88.    i,j : integer;
  89.    y : integer;
  90.    s : string;
  91.    c : char;
  92.    v : byte;
  93. begin
  94.    if PCnt > FCnt then
  95.    begin
  96.       FillChar(FldRec^[PCnt],32,#0);
  97.       FldRec^[PCnt].FieldType := 'C';
  98.    end;
  99.    if FCnt = 0 then exit;
  100.    ClrScr;
  101.    if FCnt < EndFPos then j := FCnt else j := EndFPos;
  102.    j := pred(BeginFPos+j);
  103.    y := 0;
  104.    for i := BeginFPos to j do
  105.    begin
  106.       inc(y);
  107.       WriteXYInteger(2,y,3,i);
  108.       CnvAscToStr(FldRec^[i].FieldName,s,11);
  109.       WriteXYString(8,y,10,s);
  110.       move(FldRec^[i].FieldType,c,1);
  111.       case c of
  112.          'C' : s := 'Character';
  113.          'D' : s := 'Date';
  114.          'L' : s := 'Logical';
  115.          'N' : s := 'Numeric';
  116.          'M' : s := 'Memo';
  117.       end;
  118.       WriteXYString(20,y,12,s);
  119.       move(FldRec^[i].FieldLen,v,1);
  120.       WriteXYInteger(33,y,6,v);
  121.       if c = 'N' then
  122.       begin
  123.          move(FldRec^[i].FieldDec,v,1);
  124.          WriteXYInteger(43,y,8,v);
  125.       end;
  126.    end;
  127. end;
  128.  
  129.  
  130. function UpDateFields : boolean;
  131. var
  132.    i,
  133.    x,
  134.    y  : integer;
  135.    t  : string;
  136.    c  : char;
  137.    v  : byte;
  138.  
  139.    procedure Get_Name;
  140.    var
  141.       i : integer;
  142.       s : string;
  143.       b : boolean;
  144.    begin
  145.       GS_Wind_SetIvMode;
  146.       CnvAscToStr(FldRec^[PCnt].FieldName,t,11);
  147.       t := TrimR(t);
  148.       repeat
  149.          b := true;
  150.          t := InputStr.EditString(t,8,y,10);
  151.          if (Quit_Keys) then exit;
  152.          t := AllCaps(t);
  153.          s := TrimR(t);
  154.          if s = '' then b := false
  155.          else
  156.          begin
  157.             for i := 1 to FCnt do
  158.             begin
  159.                CnvAscToStr(FldRec^[i].FieldName,s,11);
  160.                if (s = t) and (PCnt <> i) then b := false;
  161.             end;
  162.          end;
  163.          if (GS_KeyI_Chr in [Kbd_UpAr,Kbd_DnAr]) and (t = '') then b := true;
  164.          if not b then SoundBell(BeepTime, BeepFreq);
  165.       until (b) or ((PCnt = FCnt) and (GS_KeyI_Chr = Kbd_UpAr));
  166.       GS_Wind_SetNmMode;
  167.       WriteXYString(8,y,10,t);
  168.       CnvStrToAsc(t,FldRec^[PCnt].FieldName,11);
  169.    end;
  170.  
  171.    procedure Get_Type;
  172.    begin
  173.       WriteXYString(20,y,11,'C,D,L,M,N:');
  174.       GS_Wind_SetIvMode;
  175.       c := '?';
  176.       repeat
  177.          if c <> '?' then SoundBell(BeepTime, BeepFreq);
  178.          if PCnt <= FCnt then
  179.             move(FldRec^[PCnt].FieldType,c,1)
  180.          else c := 'C';
  181.          t := c;
  182.          t := InputStr.EditString(t,31,y,1);
  183.          if Quit_Keys then exit;
  184.          if length(t) > 0 then c := t[1] else c := ' ';
  185.          c := upcase(c);
  186.       until c in ['C','D','L','M','N'];
  187.       GS_Wind_SetNmMode;
  188.       case c of
  189.          'C' : t := 'Character';
  190.          'D' : t := 'Date';
  191.          'L' : t := 'Logical';
  192.          'N' : t := 'Numeric';
  193.          'M' : t := 'Memo';
  194.       end;
  195.       WriteXYString(20,y,12,t);
  196.       if c <> 'N' then ClrEol;
  197.       move(c,FldRec^[PCnt].FieldType,1);
  198.    end;
  199.  
  200.    procedure Get_Length;
  201.    begin
  202.       if c in ['D','L','M'] then
  203.       begin
  204.          if c = 'D' then v := 8
  205.             else if c = 'L' then v := 1
  206.                else v := 10;
  207.       end
  208.       else
  209.       begin
  210.          GS_Wind_SetIvMode;
  211.          x := 0;
  212.          v := 0;
  213.          repeat
  214.             if x <> 0 then SoundBell(BeepTime, BeepFreq);
  215.             move(FldRec^[PCnt].FieldLen,v,1);
  216.             str(v:6,t);
  217.             t := InputStr.EditString(t,33,y,6);
  218.             if Quit_Keys then exit;
  219.             val(t,v,x);
  220.             if v <= 0 then x := 1;
  221.             if v > 255 then x := 1;
  222.          until x = 0;
  223.          GS_Wind_SetNmMode;
  224.       end;
  225.       WriteXYInteger(33,y,6,v);
  226.       move(v,FldRec^[PCnt].FieldLen,1);
  227.    end;
  228.  
  229.    procedure Get_Decimal;
  230.    begin
  231.       v := 0;
  232.       GS_KeyI_Chr := Kbd_Ret;
  233.       if c = 'N' then
  234.       begin
  235.          GS_Wind_SetIvMode;
  236.          x := 0;
  237.          repeat
  238.             if x <> 0 then SoundBell(BeepTime, BeepFreq);
  239.             move(FldRec^[PCnt].FieldDec,v,1);
  240.             str(v:8,t);
  241.             t := InputStr.EditString(t,43,y,8);
  242.             if Quit_Keys then exit;
  243.             val(t,v,x);
  244.             if v < 0 then x := 1;
  245.             if v > pred(FldRec^[PCnt].FieldLen) then x := 1;
  246.          until x = 0;
  247.          GS_Wind_SetNmMode;
  248.          WriteXYInteger(43,y,8,v);
  249.       end;
  250.       move(v,FldRec^[PCnt].FieldDec,1);
  251.    end;
  252.  
  253. begin
  254.    PCnt :=succ(FCnt);
  255.    ShowFields;
  256.    repeat
  257.       LCnt := 0;
  258.       repeat
  259.          y := succ(PCnt-BeginFPos);
  260.          case LCnt of
  261.            0 : begin
  262.                   gotoxy(2,y);
  263.                   write(PCnt:3);
  264.                   GS_KeyI_Chr := ' ';
  265.                   if PCnt > FCnt then
  266.                   begin
  267.                      FillChar(FldRec^[PCnt],32,#0);
  268.                      FldRec^[PCnt].FieldType := 'C';
  269.                   end;
  270.                end;
  271.            1 : Get_Name;
  272.            2 : Get_Type;
  273.            3 : Get_Length;
  274.            4 : Get_Decimal;
  275.          end;
  276.          inc(LCnt);
  277.          case GS_KeyI_Chr of
  278.             Kbd_RTb   : begin
  279.                            dec(LCnt,2);
  280.                            if LCnt < 1 then LCnt := 1;
  281.                         end;
  282.             Kbd_UpAr  : LCnt := 5;
  283.             Kbd_DnAr  : LCnt := 5;
  284.          end;
  285.       until (LCnt > 4) or (Quit_Keys);
  286.       case GS_KeyI_Chr of
  287.          Kbd_Tab,
  288.          Kbd_Ret   : begin
  289.                         inc(PCnt);
  290.                         if PCnt > succ(FCnt) then inc(FCnt);
  291.                      end;
  292.          Kbd_UpAr  : dec(PCnt);
  293.          Kbd_DnAr  : inc(PCnt);
  294.       end;
  295.       if PCnt < 1 then PCnt := 1;
  296.       if PCnt > succ(FCnt) then PCnt := succ(FCnt);
  297.       if PCnt < BeginFPos then
  298.       begin
  299.          BeginFPos := PCnt;
  300.          ShowFields;
  301.       end;
  302.       if PCnt >= BeginFPos+EndFPos then
  303.       begin
  304.          inc(BeginFPos);
  305.          ShowFields;
  306.       end;
  307.    until Quit_Keys;
  308.    if (GS_KeyI_Chr = Kbd_Esc) or (FCnt = 0) then UpdateFields := false
  309.       else UpdateFields := true;
  310. end;
  311.  
  312.  
  313. procedure BuildFile(FName : string);
  314.  
  315. {
  316.             ┌─────────────────────────────────────────────────────┐
  317.             │  The MakeHeader routine formats a dBase III header, │
  318.             │  writes it to the new file, writes the field array  │
  319.             │  to the file, and then writes an End of Header and  │
  320.             │  End of File byte.                                  │
  321.             └─────────────────────────────────────────────────────┘
  322. }
  323.    procedure MakeHeader;
  324.    var
  325.       i, j : integer;                    {Local working variables}
  326.    BEGIN
  327.       HeadRec.DBType := DB3File;   {Set file type to dBase III w/o Memo}
  328. {
  329.              ┌──────────────────────────────────────────────────┐
  330.              │  Using the Turbo Pascal GetDate routine, set     │
  331.              │  the header year, month, and date header bytes.  │
  332.              │  Since the year is given in 19xx format, 1900    │
  333.              │  must be subtracted to give just the last two    │
  334.              │  digits of the year.                             │
  335.              └──────────────────────────────────────────────────┘
  336. }
  337.       GetDate (yy,mm,dd,wd);
  338.       HeadRec.year := yy-1900; {Year}
  339.       HeadRec.month := mm; {Month}
  340.       HeadRec.day := dd; {Day}
  341.       HeadRec.RecCount := 0;       {Set record count in file to zero }
  342.       HeadRec.Location := (FCnt*32) + 33;
  343.                                       {Compute total header size as length of}
  344.                                       {header file information (32 bytes),}
  345.                                       {End of Header mark (1 byte), and the}
  346.                                       {field descriptors (32 bytes each)}
  347.       rl := 1;
  348.       for i := 1 to FCnt do
  349.       begin
  350.          rl := rl + FldRec^[i].FieldLen;
  351.                                       {Compute total record size as delete/}
  352.                                       {undeleted flag (1 byte) plus total of}
  353.                                       {all field lengths. }
  354.          for j := 0 to 10 do
  355.             FldRec^[i].FieldName[j] := UpCase(FldRec^[i].FieldName[j]);
  356.          FldRec^[i].FieldType := UpCase(FldRec^[i].FieldType);
  357.          if FldRec^[i].FieldType = 'M' then
  358.             HeadRec.DBType := DB3WithMemo;
  359.                                       {Set file type to dBase III with Memo}
  360.       end;
  361.       HeadRec.RecordLen := rl;     {Store record length in header}
  362.       FillChar(HeadRec.Reserved,20,#0);
  363.                                       {Store all zeros in reserved portion }
  364.       GS_FileWrite(dFile, 0, HeadRec, 32, rsl);
  365.       GS_FileWrite(dFile, -1, FldRec^, FCnt*32, rsl);
  366.       GS_FileWrite(dFile, -1, EohMark, 1, rsl); {Put EOH marker }
  367.       GS_FileWrite(dFile, -1, EofMark, 1, rsl); {Put EOF marker }
  368.    END;
  369.  
  370. {
  371.             ┌────────────────────────────────────────────────────┐
  372.             │  Beginning of CREATE Procedure.                    │
  373.             │      1.  Assign file with .DBF extension           │
  374.             │      2.  Create and write the dBase III header     │
  375.             │      3.  Store information in objectname object    │
  376.             │      4.  Close the file                            │
  377.             │      5.  Initialize the dBase file.                │
  378.             └────────────────────────────────────────────────────┘
  379. }
  380.  
  381.     procedure MakeMemo;
  382.     begin
  383.        HeadRec.DBType := 1;        {Make a longint value of 1}
  384.        HeadRec.Year := 0;
  385.        HeadRec.Month := 0;
  386.        HeadRec.Day := 0;
  387.        Filename := FName+'.DBT';      {Assign .DBT file extension}
  388.        GS_FileAssign(dFile, FileName);
  389.        GS_FileRewrite(dFile, 1);      {Create file}
  390.        GS_FileWrite(dFile, 0, HeadRec, 512, rsl);
  391.        GS_FileWrite(dFile, -1, EofMark, 1, rsl);  {Put EOF marker }
  392.        GS_FileClose(dFile);            {Close the file}
  393.     end;
  394.  
  395. begin
  396.    Filename := FName+'.DBF';          {Assign .DBF file extension}
  397.    GS_FileAssign(dFile, FileName);
  398.    GS_FileRewrite(dFile, 1);          {Create file}
  399.    MakeHeader;
  400.    GS_FileClose(dFile);              {Close the file}
  401.    if HeadRec.DBType = DB3WithMemo then MakeMemo;
  402. end;
  403.  
  404. Procedure GS_dB3_Build(fName : string; FTabl : pointer; n : integer);
  405. begin
  406.    FldRec := FTabl;
  407.    FCnt := n;
  408.    BuildFile(fName);
  409. end;
  410.  
  411. Function GS_dB3_Create(FName : string) : boolean;
  412. begin
  413.    New(FldRec);
  414.    BeginFPos := 1;
  415.    FCnt := 0;
  416.    StatWin.NamWin('[ CREATE FILE ]');
  417.    StatWin.SetWin;
  418.    gotoxy(56,1);
  419.    write('Ctrl-End to Save');
  420.    gotoxy(56,2);
  421.    write('ESC to Abort');
  422.    gotoxy(2,1);
  423.    write('FLD   NAME        TYPE         LENGTH    DECIMALS');
  424.    gotoxy(2,2);
  425.    write('───   ────        ────         ──────    ────────');
  426.    FileWin.SetWin;
  427.    EndFPos := succ(hi(WindMax)-hi(WindMin));
  428.    if UpdateFields then
  429.    begin
  430.       BuildFile(FName);
  431.       GS_dB3_Create := true;
  432.    end
  433.       else GS_dB3_Create := false;
  434.    FileWin.RelWin;
  435.    StatWin.RelWin;
  436.    Dispose(FldRec);
  437. END;                        { GS_dB3Wk_Create }
  438.  
  439. begin
  440.    FileWin.InitWin(2,4,55,24,Yellow,Blue,Yellow,Blue,Yellow,false,'',false);
  441.    StatWin.InitWin(1,1,80,25,LightGray,Blue,Yellow,Blue,Yellow,true,'',true);
  442.    InputStr.Init;
  443.    InputStr.Wait_CR := false;
  444. end.
  445.  
  446.  
  447.  
  448.  
  449.