Category : Miscellaneous Language Source Code
Archive   : DLGDS411.ZIP
Filename : INPLONG.PAS

 
Output of file : INPLONG.PAS contained in archive : DLGDS411.ZIP
{$B-,X+}

Unit InpLong;

(*--
TInputLong is a derivitave of TInputline designed to accept LongInt
numeric input. Since both the upper and lower limit of acceptable numeric
input can be set, TInputLong may be used for Integer, Word, or Byte input
as well. Option flag bits allow optional hex input and display. A blank
field may optionally be rejected or interpreted as zero.

Methods

constructor Init(var R : TRect; AMaxLen : Integer;
LowerLim, UpperLim : LongInt; Flgs : Word);

Calls TInputline.Init and saves the desired limits and Flags. Flags may
be a combination of:

ilHex will accept hex input (preceded by '$') as well as decimal.
ilBlankEqZero if set, will interpret a blank field as '0'.
ilDisplayHex if set, will display numeric as hex when possible.


constructor Load(var S : TStream);
procedure Store(var S : TStream);

The usual Load and Store routines. Be sure to call RegisterType(RInputLong)
to register the type.


FUNCTION DataSize : Word; virtual;
PROCEDURE GetData(var Rec); virtual;
PROCEDURE SetData(var Rec); virtual;

The transfer methods. DataSize is Sizeof(LongInt) and Rec should be
the address of a LongInt.


FUNCTION RangeCheck : Boolean; virtual;

Returns True if the entered string evaluates to a number >= LowerLim and
<= UpperLim.


PROCEDURE Error; virtual;

Error is called when RangeCheck fails. It displays a messagebox indicating
the label (if any) of the faulting view, as well as the allowable range.


PROCEDURE HandleEvent(var Event : TEvent); virtual;

HandleEvent filters out characters which are not appropriate to numeric
input. Tab and Shift Tab cause a call to RangeCheck and a call to Error
if RangeCheck returns false. The input must be valid to Tab from the view.
There's no attempt made to stop moving to another view with the mouse.


FUNCTION Valid(Cmd : Word) : Boolean; virtual;

if TInputline.Valid is true and Cmd is neither cmValid or cmCancel, Valid
then calls RangeCheck. If RangeCheck is false, then Error is called and
Valid returns False.

----*)

Interface
uses Objects, Drivers, Views, Dialogs, MsgBox;

{flags for TInputLong constructor}
const
ilHex = 1; {will enable hex input with leading '$'}
ilBlankEqZero = 2; {No input (blank) will be interpreted as '0'}
ilDisplayHex = 4; {Number displayed as hex when possible}
Type
TInputLong = Object(TInputLine)
ILOptions : Word;
LLim, ULim : LongInt;
constructor Init(var R : TRect; AMaxLen : Integer;
LowerLim, UpperLim : LongInt; Flgs : Word);
constructor Load(var S : TStream);
procedure Store(var S : TStream);
FUNCTION DataSize : Word; virtual;
PROCEDURE GetData(var Rec); virtual;
PROCEDURE SetData(var Rec); virtual;
FUNCTION RangeCheck : Boolean; virtual;
PROCEDURE Error; virtual;
PROCEDURE HandleEvent(var Event : TEvent); virtual;
FUNCTION Valid(Cmd : Word) : Boolean; virtual;
end;
PInputLong = ^TInputLong;

const
RInputLong : TStreamRec = (
ObjType: 711;
VmtLink: Ofs(Typeof(TInputLong)^);
Load : @TInputLong.Load;
Store : @TInputLong.Store);

Implementation

{-----------------TInputLong.Init}
constructor TInputLong.Init(var R : TRect; AMaxLen : Integer;
LowerLim, UpperLim : LongInt; Flgs : Word);
begin
if not TInputLine.Init(R, AMaxLen) then fail;
ULim := UpperLim;
LLim := LowerLim;
if Flgs and ilDisplayHex <> 0 then Flgs := Flgs or ilHex;
ILOptions := Flgs;
if ILOptions and ilBlankEqZero <> 0 then Data^ := '0';
end;

{-------------------TInputLong.Load}
constructor TInputLong.Load(var S : TStream);
begin
TInputLine.Load(S);
S.Read(ILOptions, Sizeof(ILOptions)+Sizeof(LLim)+Sizeof(ULim));
end;

{-------------------TInputLong.Store}
procedure TInputLong.Store(var S : TStream);
begin
TInputLine.Store(S);
S.Write(ILOptions, Sizeof(ILOptions)+Sizeof(LLim)+Sizeof(ULim));
end;

{-------------------TInputLong.DataSize}
FUNCTION TInputLong.DataSize: Word;
begin
DataSize := Sizeof(LongInt);
end;

{-------------------TInputLong.GetData}
PROCEDURE TInputLong.GetData(var Rec);
var code : Integer;
begin
Val(Data^, LongInt(Rec), code);
end;

FUNCTION Hex2(B : Byte) : String;
Const
HexArray : array[0..15] of char = '0123456789ABCDEF';
begin
Hex2[0] := #2;
Hex2[1] := HexArray[B shr 4];
Hex2[2] := HexArray[B and $F];
end;

FUNCTION Hex4(W : Word) : String;
begin Hex4 := Hex2(Hi(W))+Hex2(Lo(W)); end;

FUNCTION Hex8(L : LongInt) : String;
begin Hex8 := Hex4(LongRec(L).Hi)+Hex4(LongRec(L).Lo); end;

function FormHexStr(L : LongInt) : String;
var
Minus : boolean;
S : string[20];
begin
Minus := L < 0;
if Minus then L := -L;
S := Hex8(L);
while (Length(S) > 1) and (S[1] = '0') do Delete(S, 1, 1);
S := '$' + S;
if Minus then System.Insert('-', S, 2);
FormHexStr := S;
end;

{-------------------TInputLong.SetData}
PROCEDURE TInputLong.SetData(var Rec);
var
L : LongInt;
S : string;
begin
L := LongInt(Rec);
if L > ULim then L := ULim
else if L < LLim then L := LLim;
if ILOptions and ilDisplayHex <> 0 then
S := FormHexStr(L)
else
Str(L : -1, S);
if Length(S) > MaxLen then S[0] := chr(MaxLen);
Data^ := S;
end;

{-------------------TInputLong.RangeCheck}
FUNCTION TInputLong.RangeCheck : Boolean;
var
L : LongInt;
code : Integer;
begin
if (Data^ = '') and (ILOptions and ilBlankEqZero <> 0) then
Data^ := '0';
Val(Data^, L, code);
RangeCheck := (Code = 0) and (L >= LLim) and (L <= ULim);
end;

{-------------------TInputLong.Error}
PROCEDURE TInputLong.Error;
var
SU, SL : string[40];
PMyLabel : PLabel;
Labl : string;
I : Integer;

function FindIt(P : PView) : boolean; far;
begin
FindIt := (Typeof(P^) = Typeof(TLabel)) and (PLabel(P)^.Link = @Self);
end;

begin
Str(LLim : -1, SL);
Str(ULim : -1, SU);
if ILOptions and ilHex <> 0 then
begin
SL := SL+'('+FormHexStr(LLim)+')';
SU := SU+'('+FormHexStr(ULim)+')';
end;
if Owner <> Nil then
PMyLabel := PLabel(Owner^.FirstThat(@FindIt))
else PMyLabel := Nil;
if PMyLabel <> Nil then PMyLabel^.GetText(Labl)
else Labl := '';
if Labl <> '' then
begin
I := Pos('~', Labl);
while I > 0 do
begin
System.Delete(Labl, I, 1);
I := Pos('~', Labl);
end;
Labl := '"'+Labl+'"';
end;
MessageBox(Labl + ^M^J'Value not within range '+SL+' to '+SU, Nil,
mfError+mfOKButton);
end;

{-------------------TInputLong.HandleEvent}
PROCEDURE TInputLong.HandleEvent(var Event : TEvent);
var
SU, SL : string[50];
Code : Integer;
L : LongInt;
begin
if (Event.What = evKeyDown) then
begin
case Event.KeyCode of
kbTab, kbShiftTab
: if not RangeCheck then
begin
Error;
SelectAll(True);
ClearEvent(Event);
end;
end;
if Event.CharCode <> #0 then {a character key}
begin
Event.Charcode := Upcase(Event.Charcode);
case Event.Charcode of
'0'..'9', #1..#$1B : ; {acceptable}

'-' : if (LLim >= 0) or (CurPos <> 0) then
ClearEvent(Event);
'$' : if ILOptions and ilHex = 0 then ClearEvent(Event);
'A'..'F' : if Pos('$', Data^) = 0 then ClearEvent(Event);

else ClearEvent(Event);
end;
end;
end;
TInputLine.HandleEvent(Event);
end;

{-------------------TInputLong.Valid}
FUNCTION TInputLong.Valid(Cmd : Word) : Boolean;
var
Rslt : boolean;
begin
Rslt := TInputLine.Valid(Cmd);
if Rslt and (Cmd <> 0) and (Cmd <> cmCancel) then
begin
Rslt := RangeCheck;
if not Rslt then
begin
Error;
Select;
SelectAll(True);
end;
end;
Valid := Rslt;
end;

end.


  3 Responses to “Category : Miscellaneous Language Source Code
Archive   : DLGDS411.ZIP
Filename : INPLONG.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/