DP Tool Club 8/CDASC08.ISO/NEWS/552/GSDMOTV2.PAS

Pascal/Delphi Source File | 1993-10-07 | 12KB | 433 lines

program GSDMOTV2;
{------------------------------------------------------------------------------
                              DBase File Display
                             TurboVision Sample 2

       Copyright (c)  Richard F. Griffin

       28 January 1993

       102 Molded Stone Pl
       Warner Robins, GA  31088

       -------------------------------------------------------------
       This program demonstrates that the basic Griffin Solutions
       routines will work in a TurboVision environment.

       This demo provides a file viewer using TurboVision methods.
       One unit, GSV_FLDS.PAS is also used for improved inputline
       support.

       Memory is at a premium in the IDE using TurboVision.  If you
       get heap overflow errors or 'strange' things happen, if probably
       means there is not enough memory to run in the IDE.  To regain
       memory, you can compile to disk instead of memory.  Use the
       MemAvail value in the Watch window to see how much memory is
       available.

-------------------------------------------------------------------------------}

uses DOS,
     Objects, Drivers, Views, Menus, Dialogs, StdDlg, App, Memory,
     GSOBShel, GSV_Flds;

const
  cmFileOpen        = 100;
  cmVideoMode       = 101;
  cmNextRec         = 102;
  cmPrevRec         = 103;
  cmPageUp          = 104;
  cmPageDn          = 105;
  hcFileOpen        = 2;
  hcDataField       = 901;

type

  PdBDialog = ^TdBDialog;
  TdBDialog = object(TDialog)
    FldColl   : PCollection;
    FldsInFile: integer;
    FldsOnScrn: integer;
    FirstField: integer;
    FirstItem : PView;
    dbCheck   : PCheckBoxes;
    CBox      : word;
    dbStatic  : PStaticText;
    dbCancel  : PButton;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure ShowDialog(ClrInp : boolean);
    procedure SaveDialog(C : Word; ClrInp : boolean);
  end;

  TMyApp = object(TApplication)
    Dialog    : PdBDialog;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure InitMenuBar; virtual;
    procedure InitStatusLine; virtual;
    procedure FileOpen;
    procedure NewDialog;
  end;

var
  NewMode : word;
  MyApp: TMyApp;


procedure TdBDialog.HandleEvent(var Event: TEvent);
var
   Chg   : boolean;
   Rfrsh : boolean;
   MLine : TPoint;
   Q,
   R     : TRect;
   L     : integer;
   W     : word;
   P     : Pointer;
begin
  if Event.What = evKeyDown then
  begin
     case Event.KeyCode of
        kbPgUp,
        kbPgDn     : begin
                        if Event.KeyCode = kbPgUp then W := cmPageUp
                           else W := cmPageDn;
                        ClearEvent(Event);
                        P := Message(Owner,evCommand,W,@Self);
                        exit;
                     end;
        kbAltE     : begin end;
        kbEnter    : if Current^.HelpCtx = hcDataField then
                        Event.KeyCode := kbTab;
        kbDown     : Event.KeyCode := kbTab;
        kbUp       : Event.KeyCode := kbShiftTab;
        else         begin
                        TDialog.HandleEvent(Event);
                        exit;
                     end;
     end;
     if Current^.Valid(1) then TDialog.HandleEvent(Event)
     else
        ClearEvent(Event);
     exit;
  end;
  if Event.What = evMouseDown then
  begin
     dbCancel^.GetBounds(Q);
     Current^.GetBounds(R);
     MakeLocal(Event.Where,MLine);
     Chg := R.Contains(MLine);
     if not Chg then Chg := Q.Contains(MLine);
     if not Chg then Chg := (MLine.X = 3) and (Mline.Y = 0);
     if Chg then TDialog.HandleEvent(Event)
     else
        if Current^.Valid(1) then TDialog.HandleEvent(Event)
        else
           ClearEvent(Event);
     exit;
  end;
  if Event.What = evCommand then
  begin
    case Event.Command of
      cmPageUp,
      cmPageDn  : begin
                       Chg := true;
                       if (Current^.HelpCtx = hcDataField) then
                          Chg := Current^.Valid(1);
                       if Chg then
                       begin
                          L := FirstField;
                          if Event.Command = cmPageUp then
                             FirstField := FirstField-(FldsOnScrn-1)
                          else
                             FirstField := FirstField+(FldsOnScrn-1);
                          if FirstField < 1 then FirstField := 1
                             else
                                if FirstField > FldsInFile-(FldsOnScrn-1) then
                                   FirstField := FldsInFile-(FldsOnScrn-1);
                          if FirstField <> L then
                          begin
                             SaveDialog(0,true);
                             ShowDialog(true);
                          end;
                          FirstItem^.Select;
                       end;
                       ClearEvent(Event);
                       exit;
                    end;

      cmNextRec,
      cmPrevRec   : begin
                       Chg := true;
                       if (Current^.HelpCtx = hcDataField) then
                          Chg := Current^.Valid(1);
                       if Chg then
                       begin
                          Rfrsh := FirstField <> 1;
                          FirstField := 1;
                          SaveDialog(1,Rfrsh);
                          if Event.Command = cmNextRec then
                             Skip(1)
                          else Skip(-1);
                          ShowDialog(Rfrsh);
                          FirstItem^.Select;
                       end;
                       ClearEvent(Event);
                       exit;
                    end;
    end;
  end;
  TDialog.HandleEvent(Event)
end;


{ TMyApp }

procedure TMyApp.HandleEvent(var Event: TEvent);
begin
  TApplication.HandleEvent(Event);
  if Event.What = evCommand then
  begin
    case Event.Command of
      cmFileOpen : FileOpen;
      cmVideoMode:
        begin
          NewMode := ScreenMode xor smFont8x8;
          if NewMode and smFont8x8 <> 0 then
            ShadowSize.X := 1
          else ShadowSize.X := 2;
          SetScreenMode(NewMode);
        end;
    else
      Exit;
    end;
    ClearEvent(Event);
  end;
end;

procedure TMyApp.InitMenuBar;
var R: TRect;
begin
  GetExtent(R);
  R.B.Y := R.A.Y + 1;
  MenuBar := New(PMenuBar, Init(R, NewMenu(
    NewSubMenu('~F~ile', hcNoContext, NewMenu(
      NewItem('~O~pen', 'F3', kbF3, cmFileOpen, hcNoContext,
      NewLine(
      NewItem('~V~ideo mode','', kbNoKey, cmVideoMode, hcNoContext,
      NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoContext,
      nil))))),
    nil)
  )));
end;

procedure TMyApp.InitStatusLine;
var R: TRect;
begin
  GetExtent(R);
  R.A.Y := R.B.Y - 1;
  StatusLine := New(PStatusLine, Init(R,
    NewStatusDef(0, $FFFF,
      NewStatusKey('', kbF10, cmMenu,
      NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
      nil)),
    nil)
  ));
end;

procedure TMyApp.FileOpen;
var
  Dg: PFileDialog;
  FileName: PathStr;
  D: DirStr;
  N: NameStr;
  E: ExtStr;
begin
  Dg := New(PFileDialog, Init('*.DBF', 'Open a File',
    '~N~ame', fdOpenButton + fdHelpButton, 100));
  Dg^.HelpCtx := hcFileOpen;
  if ValidView(Dg) <> nil then
  begin
    if Desktop^.ExecView(Dg) <> cmCancel then
    begin
      Dg^.GetFileName(FileName);
      FSplit(FExpand(FileName), D, N, E);
      GSOBShel.Select(1);
      Use(D+N);
      NewDialog;
      CloseDataBAses;
    end;
    Dispose(Dg, Done);
  end;
end;

procedure TMyApp.NewDialog;
var
  dBInput: PdBInputLine;
  R: TRect;
  C: Word;
  Pgd: boolean;
begin
  GoTop;
  GetExtent(R);
  dec(R.B.Y,2);
  Dialog := New(PdBDialog, Init(R, Alias));
  with Dialog^ do
  begin
    FldColl := nil;
    FirstField := 1;
    FldsOnScrn := Size.Y-5;
    FldsInFile := FieldCount;
    Pgd := FldsOnScrn < FldsInFile;
    if FldsOnScrn > FldsInFile then
       FldsOnScrn := FldsInFile;
    R.Assign(3, Size.Y-2, 18, Size.Y-1);
    dBCheck := New(PCheckBoxes, Init(R,
      NewSItem('D~e~leted',
      nil)
    ));
    R.Assign(40, Size.Y-2, 65, Size.Y-1);
    dBStatic := New(PStaticText, Init(R,'Record'));
    Insert(dbStatic);
    ShowDialog(true);
    Insert(dbCheck);
    R.Assign(68, 2, 78, 4);
    Insert(New(PButton, Init(R, '~F~inish', cmOK, bfNormal)));
    R.Assign(68, 5, 78, 7);
    dbCancel := New(PButton, Init(R, 'Cancel', cmCancel, bfNormal));
    Insert(dbCancel);
    if Pgd then
    begin
       R.Assign(68, 8, 78, 10);
       Insert(New(PButton, Init(R, 'Pg~U~p', cmPageUp, bfNormal)));
       R.Assign(68, 11, 78, 13);
       Insert(New(PButton, Init(R, 'Pg~D~n', cmPageDn, bfNormal)));
    end;
    R.Assign(68, 14, 78, 16);
    Insert(New(PButton, Init(R, '~P~rev', cmPrevRec, bfNormal)));
    R.Assign(68, 17, 78, 19);
    Insert(New(PButton, Init(R, '~N~ext', cmNextRec, bfNormal)));
    dBInput := FldColl^.At(0);
    dBInput^.Select;
  end;
  C := DeskTop^.ExecView(Dialog);
  Dialog^.SaveDialog(C,true);
  Dispose(Dialog^.FldColl, Done);
  Dispose(Dialog, Done);
end;

procedure TdBDialog.ShowDialog(ClrInp : boolean);
var
  dBInput: PdBInputLine;
  R: TRect;
  I,
  X,
  Y : Integer;
  S : string;
  S1,S2 : string[8];
  DFlg : word;
begin
   Y := 1;
   if FldColl = nil then
   begin
      ClrInp := true;
      New(FldColl, Init(FieldCount,4));
      for i := FirstField to FldsInFile do
      begin
         X := FieldLen(i);
         if X+27 > Size.X then X := Size.X-27;
         R.Assign(13, Y, 15+X,Y+1);
         case FieldType(i) of
            'F',
            'N'  : dBInput := New(PdBNumInputLine, Init(R, FieldLen(i)));
            else   dBInput := New(PdBInputLine, Init(R, FieldLen(i)));
         end;
         dbInput^.HelpCtx := hcDataField;
         FldColl^.Insert(dBInput);
         R.Assign(1,Y,12,Y+1);
         dbInput^.FldLabel := New(PLabel, Init(R, Field(i), dBInput));
         inc(y);
      end;
   end;
   Y := 1;
   for i := FirstField to FldsOnScrn+FirstField-1 do
   begin
      S := StringGetN(i);
      dBInput := FldColl^.At(i-1);
      if i = FirstField then FirstItem := dBInput;
      dBInput^.SetData(S);
      if ClrInp then
      begin
         dbInput^.GetBounds(R);
         R.Assign(R.A.X,Y,R.B.X,Y+1);
         dbInput^.SetBounds(R);
         Insert(dBInput);
         dbInput^.FldLabel^.GetBounds(R);
         R.Assign(R.A.X,Y,R.B.X,Y+1);
         dbInput^.FldLabel^.SetBounds(R);
         insert(dbInput^.FldLabel);
      end;
      dBInput^.IsActive := true;
      inc(Y);
   end;
   if Deleted then CBox := 1 else CBox := 0;
   dBCheck^.SetData(CBox);
   if dbStatic^.Text <> nil then DisposeStr(dbStatic^.Text);
   Str(RecNo,S1);
   Str(RecCount,S2);
   S := 'Record '+S1+' of '+S2;
   dbStatic^.Text := NewStr(S);
   if Current^.HelpCtx = hcDataField then
      PInputLine(Current)^.SelectAll(True);
   ReDraw;
end;

procedure TdBDialog.SaveDialog(C : Word; ClrInp : boolean);
var
  dBInput: PdBInputLine;
  I : integer;
  Chg : boolean;
  S : string;
  DFlg : word;
begin
  Chg := false;
  for i := 0 to FldColl^.Count-1 do
  begin
     dBInput := FldColl^.At(i);
     if C <> cmCancel then
     begin
        if dBInput^.Changed then
        begin
           Chg := true;
           dBInput^.GetData(S);
           StringPutN(i+1,S);
        end;
     end;
     if dBInput^.IsActive then
     begin
        if ClrInp then
        begin
           Delete(dBInput);
           delete(dbInput^.FldLabel);
        end;
        dBInput^.IsActive := false;
     end;
  end;
  if C <> cmCancel then
  begin
     dFLg := dBCheck^.Value;
     if DFlg <> CBox then
     begin
        if DFlg = 0 then RecallRec else DeleteRec;
        Chg := false;
     end;
  end;
  if Chg then Replace;
end;


begin
  MyApp.Init;
  MyApp.Run;
  MyApp.Done;
end.