Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PULL55.ZIP/PULLSHEL.ZIP/PULLDATA.PAS

Pascal/Delphi Source File | 1989-08-24 | 10.3 KB | 318 lines

{ =========================================================================== }
{ PullData.pas - User Statistics for data-entry windows.    ver 5.5, 08-24-89 }
{                                                                             }
{ This file contains all the data to configure the data-entry fields in       }
{ data windows or work windows.                                               }
{   Copyright (c) 1987-1989 James H. LeMay, All rights reserved.              }
{ =========================================================================== }

{ R-,S-,I-,D-,T-,F-,V-,B-,N-,L+ }         { TP4 directives }
{$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}    { TP5 directives }

{$define UseMsgLineCode }

UNIT PullData;

INTERFACE

uses
  Crt,Qwik,Strs,Wndw,Pull,PullStat;

{ ================ Set up variables for data windows here: ================== }
{ Place your variables names here to interface with the menus.                }
{ Careful! -- there's NO type checking for parameters in Transfer.  You MUST  }
{ be certain case statement, DataWndw, and TypeOfData all match.  Be          }
{ especially careful of string lengths that are too long.  They can be no     }
{ longer than DataStrSize.                                                    }
{ --------------------------------------------------------------------------- }

const
  aByte:    byte    = 100;
  aInteger: integer = 200;

type
  { Work window data entry names. }
  DataEntryNames = (NoDE,aIntegerDE);

var
  DataEntryOattr,          { Output attribute }
  DataEntryIattr,          { Input  attribute }
  DataWndwIattr,           { Input  attribute }
  DataWndwOattr,           { Output attribute }
  DataWndwBattr:  byte;    { Border attribute }
  DataWndwBrdr:   Borders;


IMPLEMENTATION

{ ================ Set up your Error Message Lines here: ================== }
{ Error Messages are used for indicating that data entry was invalid or out }
{ of range.  ErrMsgLine[1] is reserved for custom error messages that you   }
{ can create at runtime.  Messages up to InvalidEM are reserved and must    }
{ match those in PULL.PAS.                                                  }
{ ------------------------------------------------------------------------- }
type
  ErrMsgNames = (NoEM,UserEM,InvalidEM,MyEM);

{$ifdef UseMsgLineCode }
procedure GetErrMsgs;
begin
  AutoNumLock := false;   { If true, turns on NumLock on with data entry }
  CapsLockCol := 41;      { First column for ' CAPS NUM SCROLL ' on MsgLine. }

  ErrMsgLine[ord(InvalidEM)]:=' Invalid entry.             ESC-acknowledge';
  ErrMsgLine[ord(MyEM)]     :=' This indicates an error.   ESC-acknowledge';
end;

{$endif UseMsgLineCode }

procedure MakeErrMsg (Low,High: longint);
begin
  {$ifdef UseMsgLineCode }
  DataPad.ErrMsg := ord(UserEM);
  ErrMsgLine[ord(UserEM)] :=
    'Range: '+StrL(Low)+' to '+StrL(High)+'.  Press ESC';
  {$endif }
end;

{ ====================== Data Entry Range Checking ========================== }
{ These procedures are completely defined by the user.  They may not even be  }
{ necessary if the string entered is satisfactory as a valid number.  The     }
{ calls must be forced to FAR because they are called indirectly.             }
{ "Translate" can alter each key from the keyboard before it gets evaluated.  }
{ "Verify" will check the range or even completely alter the entire string.   }
{ --------------------------------------------------------------------------- }

{ -------------------- Data Window Data Entry Checking ---------------------- }
{$F+}
procedure CheckAbyte;
begin
  with DataPad do
    if ((Bdata<20) or (Bdata>50)) then
      MakeErrMsg (20,50);
end;

{ -------------------- Work Window Data Entry Checking ---------------------- }

procedure TranslateCase;
begin
  if not ExtKey then
    Key := upcase(Key);        { Simple upper case translation }
end;

procedure VerifyAinteger;
begin
  with DataPad do
    if ((Idata=0) or (Idata>200)) then
      MakeErrMsg (1,200);
end;

{$F-}

{ ======================== GetUserDataEntry ================================= }
{ The major configurations for all menus go here.  The program first clears   }
{ all RECORD values to $00.  The values below will set new values. Therefore, }
{ setting RECORD values to "false", nil, or the like is not necessary.        }
{ --------------------------------------------------------------------------- }

{ Code saving utilities: }
procedure GetDataWndw (Index: word);
begin
  DWI := Index;
  TopDataWndw := DataWndw^[DWI];
end;

procedure SaveDataWndw;
begin
  DataWndw^[DWI] := TopDataWndw;
end;

procedure GetDataEntry (Index: word);
begin
  DEI := Index;
  TopEntry := DataEntry^[DEI];
end;

procedure SaveDataEntry;
begin
  DataEntry^[DEI] := TopEntry;
end;

procedure GetDataEntryStats;
begin

  { ------------- Set up your PULL-DOWN Data Windows here: ------------------ }
  { Justification will default with numbers right justified and string to  }
  { the left if none is specified.                                         }

  with TopDataWndw,TopDataWndw.Entry do
    begin

      GetDataWndw (ord(aByteDW));         { Just gets cleared TopDataWndw }
      VarAddr       := @aByte;
    { TypeOfData    := Bytes; }           { This is the default }
      Field         := 3;
    { JustifyOutput := Right; }           { This is the default }
    { MsgLineNum    := ord(DE_ML); }      { This is the default }
    { HelpWndwNum   := ord(DataWndwHW); } { This is the default }
      SaveDataWndw;                       { Saves it in the heap }

  end;  { with }

  { ------------------------ Work Window Data Entry ------------------------- }
  AutoTab := true;    { After entry, tabs to next one in sequence }
  with DataPad do
    if QvideoMode=Mono then
         Hattr := LightGrayBG
    else Hattr := White+CyanBG; { Optional Attribute of Data Entry hilite }
                                { Use SameAttr if not desired }
  with TopEntry do
    begin

      GetDataEntry (ord(aIntegerDE));
      VarAddr     := @aInteger;
      TypeOfData  := Integers;
      Row         := 2;
      Col         := 11;
      Field       := 4;
      MaxField    := 3;
      CheckRangeProc := @VerifyAinteger;
    { MsgLineNum  := ord(DE_ML); }      { This is the default }
    { HelpWndwNum := ord(DataWndwHW); } { This is the default }
      SaveDataEntry;

    end;

end;  { procedure GetDataEntryStats }

{ =================== Data Entry Initialization Code ======================== }
{ The following code initializes all of the stats for the data entry windows  }
{ and the work window data entry fields.  There is no need to edit this       }
{ Except for the default colors in SetDefaultColors.                          }
{ --------------------------------------------------------------------------- }

procedure AllocateHeap;
begin
  if HeapOK (sizeof(DataWndws)) then
    GetMem (DataWndw,SizeOf(DataWndws));
  fillchar (DataWndw^,SizeOf(DataWndws),0);
  if HeapOK (sizeof(DataEntries)) then
    GetMem (DataEntry,SizeOf(DataEntries));
  fillchar (DataEntry^,SizeOf(DataEntries),0);
end;

procedure SetDefaultColors;
begin
  { ------------------ Set up your colors and borders here: ---------------- }
  if QvideoMode=Mono then
    begin
      DataEntryIattr := LightGray;         { Input  attribute }
      DataEntryOattr := White;             { Output attribute }
      DataWndwIattr  := White;             { Input  attribute }
      DataWndwOattr  := LightGrayBG;       { Output attribute }
    end
  else
    begin
      DataEntryIattr := Yellow+MagentaBG;  { Input  attribute }
      DataEntryOattr := Black+LightGrayBG; { Output attribute }
      DataWndwIattr  := Black+BrownBG;     { Input  attribute }
      DataWndwOattr  := Yellow+BlackBG;    { Output attribute }
    end;
  DataWndwBattr  := Black+BrownBG;     { Border attribute }
  DataWndwBrdr   := HdoubleBrdr;
end;

procedure InitDataColors;
var  i: word;
begin
  for i:=1 to NumOfDataWndws do
    with TopDataWndw,TopDataWndw.Entry do
      begin
        GetDataWndw (i);
        Iattr := DataWndwIattr;   { Input  attribute }
        Oattr := DataWndwOattr;   { Output attribute }
        Battr := DataWndwBattr;   { Border attribute }
        SaveDataWndw;
      end;
  for i:=1 to NumOfDataEntries do
    with TopEntry do
      begin
        GetDataEntry (i);
        Iattr := DataEntryIattr;  { Input  attribute }
        Oattr := DataEntryOattr;  { Output attribute }
        SaveDataEntry;
      end;
end;

function GetJustify (Justify: DirType; TOD: TypeOfDataType): DirType;
begin
  if Justify=NoDir then
    begin
      if TOD<=UserNums then
           GetJustify := Right   { for nums }
      else GetJustify := Left;   { for chars and strings }
    end
  else GetJustify:=Justify;
end;

function GetSetName (SN: SetNames; TOD: TypeOfDataType): SetNames;
begin
  if SN=NoSet then
    case TOD of
      Bytes,Words:         GetSetName := UnsignedSet;
      ShortInts..LongInts: GetSetName := SignedSet;
      Reals:               GetSetName := RealSet;
    else
      GetSetName := CharSet;
    end
  else GetSetName:=SN;
end;

procedure InitDataDefaults;
var i: word;
begin
  for i:=1 to NumOfDataWndws do
    with TopDataWndw,TopDataWndw.Entry do
      begin
        GetDataWndw (i);
        Border  := DataWndwBrdr;
        SetName := GetSetName (SetName,TypeOfData);
        Row := 1;
        Col := 2;
        if MaxField=0 then
          MaxField := Field;
        JustifyOutput := GetJustify (JustifyOutput,TypeOfData);
        if MsgLineNum=0 then
          MsgLineNum := ord(DW_ML);
        if HelpWndwNum=0 then
          HelpWndwNum := ord(DataWndwHW);
        SaveDataWndw;
      end;
  for i:=1 to NumOfDataEntries do
    with TopEntry do
      begin
        GetDataEntry (i);
        SetName := GetSetName (SetName,TypeOfData);
        if MaxField=0 then
          MaxField := Field;
        JustifyOutput := GetJustify (JustifyOutput,TypeOfData);
        if MsgLineNum=0 then
          MsgLineNum := ord(DE_ML);
        if HelpWndwNum=0 then
          HelpWndwNum := ord(DataWndwHW);
        SaveDataEntry;
      end;
end;

BEGIN
  AllocateHeap;
  SetDefaultColors;
  InitDataColors;
  {$ifdef UseMsgLineCode }
  GetErrMsgs;
  {$endif }
  GetDataEntryStats;
  InitDataDefaults;
END.