Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/DBT.ZIP/DBMENU.ARC/DBMENU.PAS

Pascal/Delphi Source File | 1988-02-21 | 21.6 KB | 522 lines

Unit Dbmenu;

{This is offered for comments, criticism, etc. for all and sundry
 on a limited basis. It is _NOT_ as well commented as I would like,
 but it is a working copy! Three caveats:
 1 : No liability is assumed or implied. If you like it, donations [time or money]
     are accepted
 2 : The date field is in the form of YYYY/MM/DD.
 3 : Many thanks and appelations to Kim and Brian, without whose TPRO units
     that this depends on, it would have been much harder

James C Walker <Cap'n> 72255,1616 }


Interface
Uses
  TPCrt,
  TPMenu,
  TpEdit,
  GetFld,
  taccess,
  Mulkey4;

Procedure DisplayR(Var F : File_Type);
Procedure GetR(Var F : File_Type; Var R);
Procedure AddRec(Var F : File_Type; Var R);
Procedure EditR(Var F : File_Type; Var R);
Procedure DeleteR(Var F : File_Type; Var R);
Procedure FindR(Var F : File_Type; Var R; Var KeyNum : Integer);
Procedure FindMatch(Var F : File_Type; Var R; Var KeyNum : Integer);
Procedure NextR(Var F : File_Type; Var R; Var KeyNum : Integer);
Procedure PreviousR(Var F : File_Type; Var R; Var KeyNum : Integer);
Procedure ReportToFile(Var F : File_Type; Var R);

Procedure RunMenu(Var F : File_Type; Var R);

Implementation

Var
  CH : Char;
  main : Menu;
  Key : MenuKey;
  MStackP : MenuStackP;
  KeyNum, I : Integer;
  ScrBufPtr : Pointer;

  Procedure DisplayR(Var F : File_Type);
  Var
    I : Integer;
    Date : String[10];

  Begin
    With F Do
      Begin
        For I := 1 To NumOfFields Do
          Begin
            With Field[I] Do
              Begin
                Date := '';
                FastWriteWindow(ScreenPrompt, YCoord, XCoord, PromptAttribute);
                If (FieldType = Date_Field) or (FieldType = Valid_Date_Field)
                 Then
                    begin
                      Date := Copy(FieldData^, 6, 2)
                            + '/'
                            + Copy(FieldData^, 9, 2)
                            + '/'
                            + Copy(FieldData^, 1, 4) ;
                      FastWriteWindow(Date, YCoord, XCoord + Length(ScreenPrompt) + 2, DisplayAttribute);
                    end
                    else
                FastWriteWindow(FieldData^, YCoord, XCoord + Length(ScreenPrompt) + 2, DisplayAttribute);
              End;      {With Field[I]}
          End;               {For I :=}
      End;                     {With F}
  End;

  Procedure GetR(Var F : File_Type; Var R);
  Var
    I, KeyVal, Code : Integer;
    CH : Char;
    TestReal : Real;
    TestVal : LongInt;
    Month, Day, Year : Integer;
    TestDate : String[4];
    NewDate : String[10];
  Const
    Escape = 27;
    CtrlEnter = 10;
  Label
    Egress, NextField;
  Begin

    DisplayR(F);
    With F Do
      Begin
        I := 1;
        While I <= NumOfFields Do
          Begin
            With Field[I] Do
              Begin
                KeyVal := 0;
                GoToXY(1, 24); ClrEol;
                FastWriteWindow(HelpPrompt, 24, 1, HelpAttribute);
                Code := 1;
                Case FieldType Of
                  Date_Field : Begin
                                 LegalChars := '0123456789';
                                 TestDate := Copy(FieldData^, 6, 2);
                                 GetField(KeyVal, LegalChars, TestDate,
                                          GetAttribute, YCoord,
                                          XCoord + Length(ScreenPrompt) + 2,
                                          2, [1, 5, 7]);
                                 If KeyVal = Escape Then
                                   Begin
                                     TestDate := '';
                                     GoTo Egress;
                                   End;
                                 If KeyVal = CtrlEnter Then GoTo NextField;
                                 Val(TestDate, Month, Code);
                                 Str(Month:2, TestDate);
                                 TestDate := Copy(FieldData^, 9, 2);
                                 GetField(KeyVal, LegalChars, TestDate,
                                          GetAttribute, YCoord,
                                          XCoord + Length(ScreenPrompt) + 5,
                                          2, [1, 5, 7]);
                                 If KeyVal = CtrlEnter Then GoTo NextField;
                                 If KeyVal = Escape Then
                                   Begin
                                     TestDate := '';
                                     GoTo Egress;
                                   End;
                                 Val(TestDate, Day, Code);
                                 Str(Day:2, TestDate);
                                 TestDate := Copy(FieldData^, 1, 4);
                                 GetField(KeyVal, LegalChars, TestDate,
                                          GetAttribute, YCoord,
                                          XCoord + Length(ScreenPrompt) + 8,
                                          4, [1, 5, 7]);
                                 If KeyVal = CtrlEnter Then GoTo NextField;
                                 If KeyVal = Escape Then
                                   Begin
                                     TestDate := '';
                                     GoTo Egress;
                                   End;
                                 Val(TestDate, Year, Code);
                                 Str(Year:4, TestDate);
                                 FieldData^ := TestDate + '/';
                                 Str(Month:2, TestDate);
                                 FieldData^ := FieldData^ + TestDate + '/';
                                 Str(Day:2, TestDate);
                                 FieldData^ := FieldData^ + TestDate;
                               End;
                  Valid_Date_Field : Begin
                                       Month := 00; Day := 00; Year := 0000;
                                       LegalChars := '0123456789';
                                       TestDate := Copy(FieldData^, 6, 2);
                                       Repeat
                                         GetField(KeyVal, LegalChars, TestDate,
                                                  GetAttribute, YCoord,
                                                  XCoord + Length(ScreenPrompt) + 2,
                                                  2, [1, 5, 7]);
                                         If KeyVal = Escape Then
                                           Begin
                                             TestDate := '';
                                             GoTo Egress;
                                           End;
                                         If KeyVal = CtrlEnter Then GoTo NextField;
                                         Val(TestDate, Month, Code);
                                         Str(Month:2, TestDate);
                                         If (Month < 1) Or (Month > 12) Then
                                           Begin
                                             GoToXY(XCoord + Length(ScreenPrompt) + 2 + 15, YCoord);
                                             ClrEol;
                                             Write('Month must be between 1 and 12 ');
                                             ClrEol;
                                           End;
                                       Until ((Month > 0) And (Month < 13)) Or (Length(TestDate) = 0);
                                       TestDate := Copy(FieldData^, 9, 2);
                                       Repeat
                                         GetField(KeyVal, LegalChars, TestDate,
                                                  GetAttribute, YCoord,
                                                  XCoord + Length(ScreenPrompt) + 5,
                                                  2, [1, 5, 7]);
                                         If KeyVal = CtrlEnter Then GoTo NextField;
                                         If KeyVal = Escape Then
                                           Begin
                                             TestDate := '';
                                             GoTo Egress;
                                           End;
                                         Val(TestDate, Day, Code);
                                         Str(Day:2, TestDate);
                                         If (Day < 1) Or (Day > 31) Then
                                           Begin
                                             GoToXY(XCoord + Length(ScreenPrompt) + 2 + 15, YCoord);
                                             ClrEol;
                                             Write('Day must be between 1 and 31');
                                             ClrEol;
                                           End;
                                       Until ((Day > 0) And (Day < 32)) Or (Length(TestDate) = 0);
                                       TestDate := Copy(FieldData^, 1, 2);
                                       Repeat
                                         GetField(KeyVal, LegalChars, TestDate,
                                                  GetAttribute, YCoord,
                                                  XCoord + Length(ScreenPrompt) + 8,
                                                  4, [1, 5, 7]);
                                         If KeyVal = CtrlEnter Then GoTo NextField;
                                         If KeyVal = Escape Then
                                           Begin
                                             TestDate := '';
                                             GoTo Egress;
                                           End;
                                         Val(TestDate, Year, Code);
                                         Str(Year:4, TestDate);
                                         If (Year < 1000) Or (Year > 3100) Then
                                           Begin
                                             {GoToXY(XCoord + LENGTH(ScreenPrompt) + 2 + 15, YCoord);}
                                             GoToXY(1, 23);
                                             ClrEol;
                                             Write('Year must be between 1000 and 3100');
                                             ClrEol;
                                           End;
                                       Until ((Year > 999) And (Year < 3101)) Or (Length(TestDate) = 0);
                                       Val(TestDate, Year, Code);
                                 Str(Year:4, TestDate);
                                 FieldData^ := TestDate + '/';
                                 Str(Month:2, TestDate);
                                 FieldData^ := FieldData^ + TestDate + '/';
                                 Str(Day:2, TestDate);
                                 FieldData^ := FieldData^ + TestDate;
                                     End;
                  String_Field : Begin
                                   GetField(KeyVal, LegalChars, FieldData^,
                                            GetAttribute, YCoord,
                                            XCoord + Length(ScreenPrompt) + 2,
                                            FieldLength - 1, [1, 5, 7]);
                                   If KeyVal = CtrlEnter Then GoTo NextField;
                                   If KeyVal = Escape Then
                                     Begin
                                       FieldData^ := '';
                                       GoTo Egress;
                                     End;
                                 End;
                  Real_Field : Begin
                                 LegalChars := '0123456789.';
                                 Repeat
                                   GetField(KeyVal, LegalChars, FieldData^,
                                            GetAttribute, YCoord,
                                            XCoord + Length(ScreenPrompt) + 2,
                                            FieldLength - 4, [1, 5, 7]);
                                   If KeyVal = CtrlEnter Then GoTo NextField;
                                   If KeyVal = Escape Then
                                     Begin
                                       FieldData^ := '';
                                       GoTo Egress;
                                     End;
                                   Val(FieldData^, TestReal, Code);
                                   If Code <> 0 Then
                                     Begin
                                       Delete(FieldData^, Code, 1);
                                       {GoToXY(XCoord + LENGTH(ScreenPrompt) + 2 + FieldLength + 2, YCoord);}
                                       GoToXY(1, 23);
                                       Write('This must be a real number');
                                       ClrEol;
                                     End;
                                 Until (Code = 0) Or (Length(FieldData^) = 0);
                                 Str(TestReal:FieldLength - 4:2, FieldData^);
                               End;
                  Integer_Field : Begin
                                    LegalChars := '0123456789.';
                                    Repeat
                                      GetField(KeyVal, LegalChars, FieldData^,
                                               GetAttribute, YCoord,
                                               XCoord + Length(ScreenPrompt) + 2,
                                               5, [1, 5, 7]);
                                      If KeyVal = CtrlEnter Then GoTo NextField;
                                      If KeyVal = Escape Then
                                        Begin
                                          FieldData^ := '';
                                          GoTo Egress;
                                        End;
                                      Val(FieldData^, TestVal, Code);
                                      If (Code <> 0) or (TestVal > 32767) Then
                                        Begin
                                          Delete(FieldData^, Code, 1);
                                          {GoToXY(XCoord + LENGTH(ScreenPrompt) + 2 + FieldLength + 2, YCoord);}
                                          GoToXY(1, 23);
                                          Write('This must be an integer between 0 and 32767');
                                          ClrEol;
                                        End;
                                    Until ((Code = 0) Or (Length(FieldData^) = 0)) and (TestVal < 32768);
                                    Str(TestVal:5, FieldData^);
                                  End;
                  Non_Blank : Begin
                                Repeat
                                  GetField(KeyVal, LegalChars, FieldData^,
                                           GetAttribute, YCoord,
                                           XCoord + Length(ScreenPrompt) + 2,
                                           FieldLength - 1, [1, 5, 7]);
                                  If KeyVal = CtrlEnter Then GoTo NextField;
                                  If KeyVal = Escape Then
                                    Begin
                                      FieldData^ := '';
                                      GoTo Egress;
                                    End;
                                  If Length(FieldData^) = 0 Then
                                    Begin
                                      {GoToXY(XCoord + LENGTH(ScreenPrompt) + 2 + FieldLength + 2, YCoord);}
                                      GoToXY(1, 23);
                                      Write('This must be not be blank');
                                      ClrEol;
                                    End;
                                Until Length(FieldData^) <> 0;
                              End;
                Else
                  Begin
                    GetField(KeyVal, LegalChars, FieldData^, GetAttribute,
                             YCoord, XCoord + Length(ScreenPrompt) + 2,
                             FieldLength - 1, [1, 5, 7]);
                    If KeyVal = Escape Then
                      Begin
                        FieldData^ := '';
                        GoTo Egress;
                      End;
                  End;
                End;
NextField:
                If KeyVal = 328 Then
                  If I = 1 Then
                    I := 1
                  Else
                    I := I - 1
                Else
                  I := I + 1;
              End;      {With Field[I]}
          End;               {For I :=}
Egress:
        DisplayR(F);
      End;                     {With F}
  End;

  Procedure AddRec(Var F : File_Type; Var R);
  Begin
    DisplayR(F);
    GetR(F, R);
    If YesOrNo('Confirm addition ?', 25, 1, 5, 'Y') Then
      ADD_RECORD(F, R);
    DisplayR(F);
  End;

  Procedure EditR(Var F : File_Type; Var R);
  Begin
    DisplayR(F);
    GetR(F, R);
    If YesOrNo('Confirm edit ?', 25, 1, 5, 'N') Then
      UPDATE_RECORD(F, R);
    DisplayR(F);
  End;

  Procedure DeleteR(Var F : File_Type; Var R);
  Begin
    DisplayR(F);
    If YesOrNo('Confirm deletion ?', 25, 1, 5, 'N') Then
      DELETE_RECORD(F);
    NEXT_RECORD(F, 1, R);
    DisplayR(F);
  End;

  Procedure FindR(Var F : File_Type; Var R; Var KeyNum : Integer);
  Var
    I : Integer;
    DummyChar : Char;
    Dummy : Boolean;
    KeyStr : String[10];
    REC : Array[0..MaxDataRecSize] Of Char Absolute R;
  Begin
    FillChar(R, F.RecSize, 0);
    DisplayR(F);
    GetR(F, R);
    If YesOrNo('Confirm choice ?', 25, 1, 5, 'Y') Then
      Begin
        With F Do
          Begin
            I := F.NUMBER_OF_KEYS;
            KeyNum := 1;
            While I <> 0 Do
              Begin
                If REC[Key[I].Offset] <> #0 Then
                  Begin
                    KeyNum := I;
                    I := 0;
                  End
                Else
                  Begin
                    I := I - 1
                  End;
              End;            {While I}
          End;              {with F do}
        If KeyNum = 0 Then KeyNum := 1;
        READ_RECORD(F, KeyNum, R);
        Str(KeyNum, KeyStr);
        DisplayR(F);
      End                  {If YESORNO}
    Else
      Begin
        DisplayR(F);
      End;
  End;                          {FindR}

  Procedure FindMatch(Var F : File_Type; Var R; Var KeyNum : Integer);
  Var
    I : Integer;
    DummyChar : Char;
    Dummy : Boolean;
    REC : Array[0..MaxDataRecSize] Of Char Absolute R;
  Begin
    With F Do
      Begin
        I := F.NUMBER_OF_KEYS;
        KeyNum := 1;
        While I <> 0 Do
          Begin
            If REC[Key[I].Offset] <> #0 Then
              Begin
                KeyNum := I;
                I := 0;
              End
            Else
              Begin
                I := I - 1
              End;
          End;                {While I}
      End;                  {with F do}
    If KeyNum = 0 Then KeyNum := 1;
    READ_RECORD(F, KeyNum, R);
  End;                          {FindR}

  Procedure NextR(Var F : File_Type; Var R; Var KeyNum : Integer);
  Begin
    NEXT_RECORD(F, KeyNum, R);
    DisplayR(F);
  End;

  Procedure PreviousR(Var F : File_Type; Var R; Var KeyNum : Integer);
  Begin
    PREVIOUS_RECORD(F, KeyNum, R);
    DisplayR(F);
  End;

  Procedure ReportToFile(Var F : File_Type; Var R);
  Var
    I : Integer;
    FTxt : Text;
  Begin
    If YesOrNo('Proceed ?', 25, 1, 5, 'Y') Then
      Begin
        With F Do
          Begin
            Assign(FTxt, Name + '.PRN');
            Rewrite(FTxt);
            For I := 1 To NumOfFields Do
              Begin
                WriteLn(FTxt, '"', Field[I].FieldData^, '",');
              End;
          End;
        Close(FTxt);
      End;
  End;


  Procedure InitMenu1(Var M : Menu);
  Const
    Color1 : MenuColorArray = ($0F, $0F, $06, $03, $04, $02);
    Frame1 : FrameArray = '╔╚╗╝═║';

  Begin
    {Customize this call for special exit characters and custom item displays}
    M := NewMenu([], Nil);

    SubMenu(1, 2, 25, Horizontal, Frame1, Color1, '');
    MenuItem('ADD RECORDS', 2, 1, 100, 'Add NEW records');
    MenuItem('EDIT RECORDS', 20, 1, 200, 'Change the contents of a record');
    SubMenu(15, 4, 25, Horizontal, Frame1, Color1, '');
    MenuItem('Edit', 3, 1, 210, 'Change the current record');
    MenuItem('Delete', 8, 1, 220, 'Delete the current record');
    MenuItem('Find', 15, 1, 230, 'Find another record');
    MenuItem('Next', 20, 1, 232, 'Goto next record');
    MenuItem('Previous', 25, 1, 233, 'Goto previous record');
    PopSubLevel;
    MenuItem('REPORT TO FILE', 50, 1, 400, 'Create a comma delimited file');
    MenuItem('QUIT', 73, 1, 1000, 'Exit the program');
    PopSubLevel;

    ResetMenu(M);
  End;

  Procedure RunMenu(Var F : File_Type; Var R);
  Begin
    OPEN_FILE(F);
    KeyNum := 1;
    InitMenu1(main);
    Repeat
      Key := MenuChoice(main, CH);
      EraseMenuOntoStack(main, MStackP);
      ClrScr;

      Case Key Of
        100 : AddRec(F, R);
        210 : EditR(F, R);
        220 : DeleteR(F, R);
        230 : FindR(F, R, KeyNum);
        232 : NextR(F, R, KeyNum);
        233 : PreviousR(F, R, KeyNum);
        400 : ReportToFile(F, R);
      End;
      DrawMenuFromStack(main, MStackP);
    Until (CH = ^M) And (Key = 1000);
    CLOSE_FILE(F);
  End;

End.