home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
PASCAL
/
PULL70.ZIP
/
PULLDATA.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-06-21
|
20KB
|
653 lines
{ ========================================================================== }
{ PullData.pas - User Statistics for data-entry windows. ver 7.0, 06-21-93 }
{ }
{ This file contains all the data to configure the data-entry fields in }
{ data windows or work windows. }
{ Copyright (c) 1988,1993 James H. LeMay, All rights reserved. }
{ ========================================================================== }
{$i pulldefs.inc }
UNIT PullData;
INTERFACE
uses
Crt,Qwik,Wndw,Pull,PullDir,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 = 129;
aWord: word = 50000;
aShortInt: shortint = -10;
aInteger: integer = -31456;
aLongInt: longint = -123456789;
aReal: real = -24.34565E06;
aHex: string[4] = 'FF03';
aChar: char = 'Q';
aString: CrtStrType = 'This is a string';
aByte2: byte = 219;
aWord2: word = 45600;
aShortInt2: shortint = -34;
aInteger2: integer = -1100;
aLongInt2: longint = -98765432;
aReal2: real = -19.07070E12;
aHex2: string[4] = 'FFFF';
aChar2: char = 'W';
aString2: CrtStrType = 'This is another string';
Seats: byte = 4;
Years: byte = 30;
Month: byte = 1;
Day: byte = 12;
Year: integer = 1989;
PriceLimit: integer = 2000;
type
DataEntryNames = (
NoDE,aByte2DE,aWord2DE,aShortInt2DE,aInteger2DE,aLongInt2DE,aReal2DE,
aHex2DE,aChar2DE,aString2DE,FileNameDE);
var
PathName: string[67]; { for the pull-down directory }
DataEntryOattr, { Output attribute }
DataEntryIattr, { Input attribute }
DataWndwIattr, { Input attribute }
DataWndwOattr, { Output attribute }
DataWndwBattr: byte; { Border attribute }
DataWndwBrdr: Borders;
IMPLEMENTATION
uses
{$ifdef UseStrg }
Strg;
{$else }
Strs;
{$endif }
{ ================ 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,PathEM,RealEM,CharEM,StrEM);
{$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(PathEM)] :=' Invalid path. Use [d:][path]. Press ESC.';
ErrMsgLine[ord(RealEM)] :=' Range: <=4.0e12 ESC-acknowledge';
ErrMsgLine[ord(CharEM)] :=' "?" not allowed ESC-acknowledge';
ErrMsgLine[ord(StrEM)] :=' At least 3 chars required. 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. }
{ -------------------------------------------------------------------------- }
procedure VerifyPath; far;
begin
with DataPad do
begin
{$I-} ChDir (Sdata); {$I+} { Check for valid directory }
if IOresult<>0 then
ErrMsg := ord(PathEM)
else GetDir (0,PathName); { Have DOS parrot the path name }
end;
end;
procedure VerifyFileMask; far;
begin
with DataPad do
if Sdata='' then
Sdata:='*.*';
end;
procedure VerifyPriceLimit; far;
begin
with DataPad do
if ((Idata>25000) or (Idata<=0)) then
MakeErrMsg (1,25000);
end;
procedure VerifyMonth; far;
begin
with DataPad do
if ((Bdata=0) or (Bdata>12)) then
MakeErrMsg (1,12);
end;
procedure VerifyDay; far;
begin
with DataPad do
if ((Bdata=0) or (Bdata>31)) then
MakeErrMsg (1,31);
end;
procedure VerifyYear; far;
begin
with DataPad do
if ((Idata<1960) or (Idata>2010)) then
MakeErrMsg (1960,2010);
end;
procedure VerifyYears; far;
begin
with DataPad do
if ((Idata<4) or (Idata>30)) then
MakeErrMsg (4,30);
end;
{ -------------------- Work Window Data Entry Checking --------------------- }
procedure TranslateCase; far;
begin
if not ExtKey then
Key := upcase(Key); { Simple upper case translation }
end;
procedure VerifyByte2; far;
begin
with DataPad do
if ((Bdata>200) or (Bdata=0)) then
MakeErrMsg (1,200);
end;
procedure VerifyWord2; far;
begin
with DataPad do
if ((Wdata>45000) or (Wdata=0)) then
MakeErrMsg (1,45000);
end;
procedure VerifyShortInt2; far;
begin
with DataPad do
if ((SIdata>101) or (SIdata<-50)) then
MakeErrMsg (-50,101);
end;
procedure VerifyInteger2; far;
begin
with DataPad do
if ((Idata>20000) or (Idata<-10000)) then
MakeErrMsg (-10000,20000);
end;
procedure VerifyLongInt2; far;
begin
with DataPad do
if ((Ldata>850000) or (Ldata<-1000000)) then
MakeErrMsg (-1000000,850000);
end;
procedure VerifyReal2; far;
begin
with DataPad do
if (Rdata>4.0e12) then
ErrMsg := ord(RealEM);
end;
procedure VerifyChar2; far;
begin
with DataPad do
if (Cdata='?') then
ErrMsg := ord(CharEM);
end;
procedure VerifyString2; far;
begin
with DataPad do
if ord(Sdata[0])<3 then
ErrMsg := ord(StrEM);
end;
{ ======================== 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(BytesDW)); { 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(NumericHW);
SaveDataWndw; { Saves it in the heap }
GetDataWndw (ord(WordsDW));
VarAddr := @aWord;
TypeOfData := Words;
Field := 5;
{ JustifyOutput := Right; } { This is the default for numbers }
HelpWndwNum := ord(NumericHW);
SaveDataWndw;
GetDataWndw (ord(IntegersDW));
VarAddr := @aInteger;
TypeOfData := Integers;
Field := 6;
HelpWndwNum := ord(NumericHW);
SaveDataWndw;
GetDataWndw (ord(LongIntsDW));
VarAddr := @aLongInt;
TypeOfData := LongInts;
Field := 11;
HelpWndwNum := ord(NumericHW);
SaveDataWndw;
GetDataWndw (ord(RealsDW));
VarAddr := @aReal;
TypeOfData := Reals;
Field := 17;
Decimals := 8; { Neg value uses R:F. Pos value - R:F:D. }
HelpWndwNum := ord(NumericHW);
SaveDataWndw;
GetDataWndw (ord(CharsDW));
VarAddr := @aChar;
TypeOfData := Chars;
Field := 1;
HelpWndwNum := ord(TextHW);
SaveDataWndw;
GetDataWndw (ord(HexDW));
VarAddr := @aHex;
TypeOfData := UserNums;
Field := 4;
SetName := HexSet; { Specify set name for custom sets }
TranslateProc := TranslateCase;
HelpWndwNum := ord(NumericHW);
SaveDataWndw;
GetDataWndw (ord(StringsDW));
Title := 'Enter string';
VarAddr := @aString;
TypeOfData := Strings;
Field := 25;
MaxField := pred(SizeOf(aString));
{ JustifyOutput := Left; } { This is the default for strings }
HelpWndwNum := ord(TextHW);
SaveDataWndw;
GetDataWndw (ord(PathDW));
Title := 'Enter path';
VarAddr := @PathName;
TypeOfData := Strings;
Field := 40;
MaxField := pred(SizeOf(PathName));
SetName := PathSet;
CheckRangeProc := VerifyPath;
HelpWndwNum := ord(TextHW);
SaveDataWndw;
GetDataWndw (ord(FileMaskDW));
Title := 'Enter Mask';
VarAddr := @FileMask;
TypeOfData := Strings;
Field := 12;
MaxField := pred(SizeOf(FileMask));
SetName := MaskSet;
CheckRangeProc := VerifyFileMask;
HelpWndwNum := ord(TextHW);
SaveDataWndw;
GetDataWndw (ord(SeatsDW));
VarAddr := @Seats;
{ TypeOfData := Bytes; } { This is the default. }
Field := 2;
HelpWndwNum := ord(NumericHW);
SaveDataWndw;
GetDataWndw (ord(PriceDW));
VarAddr := @PriceLimit;
TypeOfData := Words;
Field := 6;
HelpWndwNum := ord(NumericHW);
SaveDataWndw;
GetDataWndw (ord(MonthDW));
VarAddr := @Month;
Field := 2;
CheckRangeProc := VerifyMonth;
HelpWndwNum := ord(NumericHW);
SaveDataWndw;
GetDataWndw (ord(DayDW));
VarAddr := @Day;
{ TypeOfData := Bytes; } { This is the default. }
Field := 2;
CheckRangeProc := VerifyDay;
HelpWndwNum := ord(NumericHW);
SaveDataWndw;
GetDataWndw (ord(YearDW));
VarAddr := @Year;
TypeOfData := Integers;
Field := 4;
CheckRangeProc := VerifyYear;
HelpWndwNum := ord(NumericHW);
SaveDataWndw;
GetDataWndw (ord(YearsDW));
VarAddr := @Years;
TypeOfData := Integers;
Field := 2;
CheckRangeProc := VerifyYears;
HelpWndwNum := ord(NumericHW);
SaveDataWndw;
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(aByte2DE));
VarAddr := @aByte2;
TypeOfData := Bytes;
Row := 14;
Col := 20;
Field := 4;
MaxField := 3;
CheckRangeProc := VerifyByte2;
{ MsgLineNum := ord(DE_ML); } { This is the default }
HelpWndwNum := ord(NumericHW);
SaveDataEntry;
GetDataEntry (ord(aWord2DE));
VarAddr := @aWord2;
TypeOfData := Words;
Row := 15;
Col := 20;
Field := 6;
CheckRangeProc := VerifyWord2;
HelpWndwNum := ord(NumericHW);
SaveDataEntry;
GetDataEntry (ord(aShortInt2DE));
VarAddr := @aShortInt2;
TypeOfData := ShortInts;
Row := 16;
Col := 20;
Field := 4;
CheckRangeProc := VerifyShortInt2;
HelpWndwNum := ord(NumericHW);
SaveDataEntry;
GetDataEntry (ord(aInteger2DE));
VarAddr := @aInteger2;
TypeOfData := Integers;
Row := 17;
Col := 20;
Field := 6;
CheckRangeProc := VerifyInteger2;
HelpWndwNum := ord(NumericHW);
SaveDataEntry;
GetDataEntry (ord(aLongInt2DE));
VarAddr := @aLongInt2;
TypeOfData := LongInts;
Row := 18;
Col := 20;
Field := 12;
CheckRangeProc := VerifyLongInt2;
HelpWndwNum := ord(NumericHW);
SaveDataEntry;
GetDataEntry (ord(aReal2DE));
VarAddr := @aReal2;
TypeOfData := Reals;
Row := 19;
Col := 20;
Field := 17;
CheckRangeProc := VerifyReal2;
HelpWndwNum := ord(NumericHW);
SaveDataEntry;
GetDataEntry (ord(aHex2DE));
VarAddr := @aHex2;
TypeOfData := UserNums;
Row := 14;
Col := 50;
Field := 4;
SetName := HexSet;
TranslateProc := TranslateCase;
HelpWndwNum := ord(NumericHW);
SaveDataEntry;
GetDataEntry (ord(aChar2DE));
VarAddr := @aChar2;
TypeOfData := Chars;
Row := 15;
Col := 50;
Field := 1;
CheckRangeProc := VerifyChar2;
HelpWndwNum := ord(TextHW);
SaveDataEntry;
GetDataEntry (ord(aString2DE));
VarAddr := @aString2;
TypeOfData := Strings;
Row := 16;
Col := 50;
Field := 20;
MaxField := pred(sizeof(aString2));
CheckRangeProc := VerifyString2;
HelpWndwNum := ord(TextHW);
SaveDataEntry;
GetDataEntry (ord(FileNameDE));
VarAddr := @FileName;
TypeOfData := Strings;
Row := 17;
Col := 50;
Field := 12;
MaxField := pred(sizeof(FileName));
SetName := FileNameSet;
HelpWndwNum := ord(TextHW);
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);
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);
SaveDataEntry;
end;
end;
BEGIN
AllocateHeap;
SetDefaultColors;
InitDataColors;
{$ifdef UseMsgLineCode }
GetErrMsgs;
{$endif }
GetDataEntryStats;
InitDataDefaults;
END.