Category : Pascal Source Code
Archive   : TPWTIPS.ZIP
Filename : FORMLINE.PAS

{************************************************}
{ }
{ Turbo Pascal for Windows }
{ Formatted Input Edit Control Unit }
{ Copyright (c) 1991 by Borland International }
{ }
{ by Jason Sprenger and John Wong }
{************************************************}

unit Formline;

interface

uses
WinTypes, WinProcs,
WObjects, Strings;

const
flPicOverflow = -2;
flError = -1;
flCharOk = 0;
flFormatOk = 1;
FormatSet = ['#', '?', '&', '@', '!', ';', '{', '}', '[', ']', '*'];

type
PFormEdit = ^TFormEdit;
TFormEdit = object(TEdit)
Picture: PChar;
constructor Init(AParent: PWindowsObject; AnId: Integer;
ATitle: PChar; X, Y, W, H, ATextLen: Integer; APicture: PChar);
constructor InitResource(AParent: PWindowsObject;
ResourceID, ATextLen: Word; APicture: PChar);
destructor Done; virtual;
procedure ChangePicture(APicture: PChar);
procedure WMSetFocus(var Message: TMessage);
virtual wm_First + wm_SetFocus;
procedure Store(var S: TStream); virtual;
procedure Load(var S: TStream); virtual;
function CanClose: Boolean; virtual;
procedure WMChar(var Message: TMessage);
virtual wm_First + wm_Char;
function CheckPicture(var Info: PChar; Pic: PChar;
var CPos, Resolved: Integer): Integer;
end;

implementation

constructor TFormEdit.Init;
begin
TEdit.Init(AParent, AnID, ATitle, X, Y, W, H, ATextLen, false);
GetMem(Picture, 255);
StrCopy(Picture, APicture);
end;

constructor TFormEdit.InitResource(AParent: PWindowsObject;
ResourceID, ATextLen: Word; APicture: PChar);
begin
TEdit.InitResource(AParent, ResourceID, ATextLen);
Picture := StrNew(APicture);
end;

destructor TFormEdit.Done;
begin
StrDispose(Picture);
end;

procedure TFormEdit.ChangePicture(APicture: PChar);
begin
StrDispose(Picture);
Picture := StrNew(APicture);
end;

procedure TFormEdit.WMSetFocus(var Message: TMessage);
var
Text: PChar;
CPos, Resolved: Integer;
begin
DefWndProc(Message);
GetMem(Text, 255);
GetText(Text, 255);
if StrLen(Text) = 0 then
begin
CPos := 0;
Resolved := 0;
CheckPicture(Text, Picture, CPos, Resolved);
if StrLen(Text) > 0 then
begin
SetText(Text);
CPos := StrLen(Text);
SetSelection(CPos + 1, CPos + 1);
end;
end;
end;

procedure TFormEdit.Store(var S: TStream);
begin
TEdit.Store(S);
S.StrWrite(Picture);
end;

procedure TFormEdit.Load(var S: TStream);
begin
TEdit.Load(S);
Picture := S.StrRead;
end;

function TFormEdit.CanClose: Boolean;
var
FirstText, NextText: PChar;
CPos, Dummy: Integer;
Result: Integer;
Resolved: Integer;
begin
GetMem(FirstText, 255);
GetText(FirstText, 255);
if StrLen(FirstText) > 0 then { don't perform validation if field is empty }
begin
GetMem(NextText, 255);
StrCopy(NextText, FirstText);
GetSelection(CPos, Dummy);
Result := CheckPicture(NextText, Picture, CPos, Resolved);
if Result = flFormatOk then
begin
CanClose := True;
if StrComp(FirstText, NextText) <> 0 then
begin
SetText(NextText);
SetSelection(CPos + 1, CPos + 1);
end
end
else
begin
CanClose := False;
SetText(FirstText);
SetSelection(CPos, CPos);
MessageBeep(0);
SetFocus(HWindow);
end;
FreeMem(NextText, 255);
end;
FreeMem(FirstText, 255);
end;

function TFormEdit.Checkpicture(var Info: PChar; Pic: PChar;
var CPos, Resolved: Integer): Integer;
var
InfoIndex, PicIndex: Integer;
Committed, MayCommit: Boolean;
Result: Boolean;

function VariableResolution: Boolean;
var
Result: Boolean;
begin
Result := true;
if (PicIndex < StrLen(Pic)) and (InfoIndex < StrLen(Info)) then
begin
case Pic[PicIndex] of
'#':
begin
Result := Info[InfoIndex] in ['0'..'9'];
if Result then
begin
inc(PicIndex);
inc(InfoIndex);
inc(Resolved);
end;
end;

'?':
begin
Result := Info[InfoIndex] in ['a'..'z','A'..'Z'];
if Result then
begin
inc(PicIndex);
inc(InfoIndex);
inc(Resolved);
end;
end;

'&':
begin
Result := Info[InfoIndex] in ['a'..'z','A'..'Z'];
if Result then
begin
Info[InfoIndex]:=UpCase(Info[InfoIndex]);
inc(PicIndex);
inc(InfoIndex);
inc(Resolved);
end;
end;

'@':
begin
Result := true;
inc(PicIndex);
inc(InfoIndex);
inc(Resolved);
end;

'!':
begin
Result := true;
Info[InfoIndex] := UpCase(Info[InfoIndex]);
inc(PicIndex);
inc(InfoIndex);
inc(Resolved);
end;

';':
begin
inc(PicIndex);
Result := Info[InfoIndex] = Pic[PicIndex];
if Result then
begin
inc(PicIndex);
inc(InfoIndex);
inc(Resolved);
end;
end

else
begin
Result := Info[InfoIndex] = Pic[PicIndex];
if Result then
begin
inc(PicIndex);
inc(InfoIndex);
inc(Resolved);
end;
end;
end;{ of case}
end;{ of if }
VariableResolution := Result;
end;{ of function VariableResolution }

function DefaultResolution: Boolean;
var
Result: Boolean;
begin
Result := true;
if (PicIndex < StrLen(Pic)) and (InfoIndex < StrLen(Info)) then
begin
if (Info[InfoIndex] = ' ') and
not(Pic[PicIndex] in (FormatSet - [';'] )) then
begin
if Pic[PicIndex] = ';' then
inc(PicIndex);
Info[InfoIndex] := Pic[PicIndex];
inc(InfoIndex);
inc(PicIndex);
inc(Resolved);
end;
end;
DefaultResolution := Result;
end;

function ConstantResolution: Boolean;
var
Result: Boolean;
begin
Result := true;
if (InfoIndex = StrLen(Info)) then
begin
while (PicIndex < StrLen(Pic)) and
not(Pic[PicIndex] in (FormatSet - [';'] + [','])) do
begin
if Pic[PicIndex] = ';' then
inc(PicIndex);
Info[StrLen(Info) + 1] := #0;
Info[StrLen(Info)] := Pic[PicIndex];
inc(InfoIndex);
inc(Resolved);
inc(PicIndex);
CPos := InfoIndex - 1;
end;
end;
ConstantResolution := Result;
end;

function NextItem(Pic: PChar; PicIndex: Integer;
Terminator: Char): Integer;
var
GCount, OCount: Word;
NewIndex: Integer;
begin
GCount := 0;
OCount := 0;
NewIndex := PicIndex;

if Pic[NewIndex] <> Terminator then
repeat
case Pic[NewIndex] of
'{': inc(GCount);
'[': inc(OCount);
';': inc(NewIndex);
'}': if GCount>0 then dec(GCount);
']': if OCount>0 then dec(OCount);
end;
inc(NewIndex);
until ((GCount = 0) and (OCount = 0) and
(Pic[NewIndex] = Terminator)) or (NewIndex = StrLen(Pic));
NextItem := NewIndex;
end;

function DetermineCommitment: Boolean;
var
TempIndex: Integer;
begin
if Result and MayCommit then
begin
MayCommit := false;
Committed := true;
TempIndex := NextItem(Pic, PicIndex, ',');
if (TempIndex < StrLen(Pic)) then
Pic[TempIndex-1] := #0;
end;
if not Result and not Committed then
begin
TempIndex := NextItem(Pic, PicIndex, ',');
if TempIndex < StrLen(Pic) then
begin
PicIndex := TempIndex + 1;
InfoIndex := 0;
Resolved := 0;
Result := true;
end;
end;
DetermineCommitment := Result;
end;

function CanBeBlank(Pic: PChar; PicIndex: Integer): Boolean;
var
NewIndex: Integer;
TempPic: PChar;
Result: Boolean;
begin
GetMem(TempPic, StrLen(Pic) + 1);
Result := true;
while (PicIndex < StrLen(Pic)) and (Pic[PicIndex] <>',') and
Result do
begin
case Pic[PicIndex] of
'{':
begin
NewIndex := NextItem(Pic, PicIndex, '}');
StrCopy(TempPic, Pic);
TempPic[NewIndex] := #0;
TempPic := @TempPic[PicIndex + 1];
Result := CanBeBlank(TempPic, 1);
PicIndex := NewIndex + 1;
end;

'[':
begin
NewIndex := NextItem(Pic, PicIndex, ']');
Result := true;
PicIndex := NewIndex + 1;
end;

'*':
begin
if Pic[PicIndex + 1] in ['0'..'9'] then
begin
Result := true;
inc(PicIndex);
if Pic[PicIndex]='{' then
begin
PicIndex := NextItem(Pic, PicIndex, '}');
inc(PicIndex);
end
else inc(PicIndex);
end
else Result := false;
end
else Result := false;
end;
end;
CanBeBlank := Result;
FreeMem(TempPic, StrLen(Pic) + 1);
end;

function CouldBeDone(Pic: PChar; PicIndex: Integer): Boolean;
var
TopPic, TempPic: PChar;
begin
GetMem(TempPic, StrLen(Pic) + 1);
TopPic := TempPic;
TempPic := @Pic[PicIndex];
CouldBeDone := CanBeBlank(TempPic, 1);
FreeMem(TopPic, StrLen(Pic) + 1);
end;

function DetermineResult(CalcResult: Boolean): Integer;
var
Result: Integer;
begin
if CalcResult then
if CouldBeDone(Pic, PicIndex) then
if (InfoIndex = StrLen(Info)) then Result := flFormatOk
else Result := flPicOverflow
else Result := flCharOk
else Result := flError;
if (Result = flError) or (Result = flPicOverflow) then
CPos := InfoIndex;
DetermineResult := Result;
end;

begin
PicIndex := 0;
InfoIndex := 0;
MayCommit := true;
Committed := false;
repeat
DefaultResolution; {Phase 2 Constant Resolution}
Result := VariableResolution;
if Result then
Result := ConstantResolution; {Phase 1 Constant Resolution}
Result := DetermineCommitment;
until not Result or (InfoIndex >= StrLen(Info)) or
(PicIndex >= StrLen(Pic));
CheckPicture := DetermineResult(Result);
end;

procedure TFormEdit.WMChar(var Message: TMessage);
var
FirstText, SecondText, TopText, NextText: PChar;
Result, CPos, Resolved, Dummy: Integer;
begin
if (Message.WParam >31) and (Message.WParam < 127) then
begin
GetMem(FirstText, 255);
GetMem(TopText, 255);
GetMem(SecondText, 255);
NextText := TopText;
GetText(FirstText, 255);
DefWndProc(Message);
GetText(NextText, 255);
StrCopy(SecondText, NextText);
GetSelection(CPos, Dummy);
Resolved:=0;
Result := CheckPicture(NextText, Picture, CPos, Resolved);
if (Result = flError) or (Result = flPicOverflow) then
begin
SetText(FirstText);
SetSelection(CPos, CPos);
MessageBeep(0);
end
else
begin
if StrComp(SecondText, NextText) <> 0 then
begin
SetText(NextText);
SetSelection(CPos + 1, CPos + 1);
end;
end;
FreeMem(FirstText, 255);
FreeMem(TopText, 255);
FreeMem(SecondText, 255);
end
else DefWndProc(Message);
end;

end.