program ControlClassesDemo;

{ pre-release, no support, no warranty

  Copr. 1994 Matthias Kppe
}

uses Objects, Drivers, GvViews, GvWinDlg, WinRes, GvDialog, GvMenus, GvApp,
  Validate, GvValid, Profile, Prnt, GvMsgBox, Dos, GvStdDlg;

{$R contclas.res}

var
  Res: PStream;

{ Definition eigener Kontrollelement-Klassen. ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ
}

{ Metrischer Validator
}

type
  PMetricValidator = ^TMetricValidator;
  TMetricValidator = object(TGPXPictureValidator)
    constructor Init;
    procedure Error; virtual;
    function Transfer(var S: String; Buffer: Pointer;
      Flag: TVTransfer): Word; virtual;
  end;

constructor TMetricValidator.Init;
Begin
  inherited Init('#*#[{;,,.}#*#]', true);
  Options := Options or voTransfer
End;

procedure TMetricValidator.Error;
Begin
  MessageBox('Die Eingabe ist keine gltige reelle Zahl.', nil,
    mfError + mfOKButton)
End;

function TMetricValidator.Transfer;
var
  RealVal: Real;
  Code: Integer;
begin
  if Options and voTransfer <> 0 then
  begin
    Transfer := SizeOf(LongInt);
    case Flag of
     vtGetData:
       begin
	 Code := Pos(',', S);
	 If Code <> 0 then S[Code] := '.';
	 Val(S, RealVal, Code);
	 LongInt(Buffer^) := Round(RealVal * 100)
       end;
     vtSetData:
       begin
	 Str(LongInt(Buffer^) / 100:0:2, S);
	 Code := Pos('.', S);
	 If Code <> 0 then S[Code] := ','
       end;
    end
  end
  else
    Transfer := 0
end;

{ Objekterzeugungsprozeduren
}

procedure InitEditInt(Data: PControlData; Info: PDialogInfo); {$ifndef FPK}far;{$endif}
var
  v: PValidator;
Begin
  InitEdit(Data, Info);
  If TypeOf((PDialog(Info^.Dialog)^.First^)) = TypeOf(TInputLine)
  then Begin
    v := New(PGRangeValidator, Init(1, 99999));
    v^.Options := v^.Options or voTransfer;
    PInputLine(PDialog(Info^.Dialog)^.First)^.SetValidator(v)
  End
End;

procedure InitEditMetric(Data: PControlData; Info: PDialogInfo); {$ifndef FPK}far;{$endif}
var
  v: PValidator;
Begin
  InitEdit(Data, Info);
  If TypeOf((PDialog(Info^.Dialog)^.First^)) = TypeOf(TInputLine)
  then Begin
    v := New(PMetricValidator, Init);
    PInputLine(PDialog(Info^.Dialog)^.First)^.SetValidator(v)
  End
End;

{ Klassendefinitionen
}

const
  classEditInt: TClassRec = (
    ClassId: 'EDITINT';
    Init:  @InitEditInt
  );

  classEditMetric: TClassRec = (
    ClassId: 'EDITMETRIC';
    Init:  @InitEditMetric
  );

  classEditDM: TClassRec = (
    ClassId: 'EDITDM';
    Init:  @InitEditMetric
  );

type
  TFormApp = object(TApplication)
    constructor Init;
    procedure InitMenuBar; virtual;
    procedure InitDesktop; virtual;
    destructor Done; virtual;
  end;

constructor TFormApp.Init;
Begin
  Res := New(PBufStream, Init(ParamStr(0), stOpenRead, 2048));
  SkipStub(Res^);
  SkipToResTbl(Res^);
  If Res^.Status <> 0 then Halt(1);
  InitClasses;
  RegisterGvWinDlg;
  RegisterClass(classEditInt);
  RegisterClass(classEditMetric);
  RegisterClass(classEditDM);
  inherited Init;
  ExecuteDialog(LoadDialog(res^, 'test'), nil)
End;

procedure TFormApp.InitMenuBar;
Begin
  MenuBar := nil
End;

procedure TFormApp.InitDesktop;
var
  r: TRect;
Begin
  GetExtent(R);
  Dec(R.B.Y, 21);
  Desktop := New(PDesktop, Init(R))
End;

destructor TFormApp.Done;
Begin
  inherited Done;
  DoneClasses;
  Dispose(Res, Done);
End;

var
  FormApp: TFormApp;

Begin
  FormApp.Init;
  FormApp.Run;
  FormApp.Done
End.

