old/PAS/MYTPU.PAS

Unit MyTPU;

                INTERFACE
{----------------------------------------}
Procedure InitVGA;
Procedure CloseVGA;
Procedure Mouse;
Function GetValue(text:string;x1,y1,MinValue,MaxValue,Dl1:integer):integer;

{----------------------------------------------}
              IMPLEMENTATION
{----------------------------------------------}
Uses CRT,Graph,F_Mouse;

{--------------------------------------}
Procedure VGADRV;external;
{$L vgadrv.obj}

Procedure SansFont;external;
{$L Sans.obj}
{---------------------------------------}
Procedure InitVGA;
Var
  Gd,Gm:Integer;
Begin
  if RegisterBGIDriver(@VGADRV) < 1 then Halt(1);
  if RegisterBGIFont(@SansFont) < 1 then Halt(1);
  Gd := VGA;Gm:=VGAhi;
  InitGraph(Gd, Gm,'');
  if GraphResult <> grOk then begin
    Write(GraphErrorMsg(GraphResult));
    Halt(1);
  end;
end{InitVGA};
{--------------------------------------}
Procedure CloseVGA;
begin
 CloseGraph
end;{CloseVGA}
{--------------------------------------------}
Procedure MOUSE;
begin
 if not InitMouse then begin
   WriteLn('Unable to Init mouse');
   Halt(1);
 end
 else
   ShowMouse;
end;{MOUSE}
{------------------------------------------}
Function GetValue(text:string;x1,y1,MinValue,MaxValue,dl1:integer):integer;
Var
 p1                   : pointer;
 s1                   : word;
 x,y,StartX,StartY,xk : integer;
 k                    : real;
 length               : integer;
 ch,tmpch             : char;
 st                   : string;
 value                : byte;
 code                 : integer;
 LastColor,LastBk     : integer;

{--------------------------------------}
Procedure EnterVal;
Var
  FillInfo :FillSettingsType;
Begin
  GetFillSettings(FillInfo);
  SetFillStyle(CloseDotFill,LightBlue);
  Bar(Startx,starty,Startx+length,Starty+60);
  SetColor(White);
  Rectangle(Startx,starty,Startx+length,Starty+60);
  SetColor(LightGray);
  SetTextJustify(CenterText,TopText);
  OutTextXY(startx + length div 2, Starty+15,Text);
  SetColor(Yellow);
  SetTextJustify(LeftText,TopText);
  x := Startx+20;
  y := Starty+35;
  st := '';
  Repeat
    ch := readkey;
    if ch <> #13 then
    begin
      if ch = #8 then
        if ord(st[0]) <> 0 then
          begin
            delete(st,ord(st[0]),1);
            SetFillStyle(black,CloseDotFill);
            Bar(x-TextWidth(tmpch),y,x,y+TextHeight(tmpch));
            x := x - TextWidth(tmpch);
            SetFillStyle(FillInfo.color,FillInfo.pattern);
          End
        else
      else
        begin
          st := st + ch;
          OutTextXY(x,y,ch);
          x := x + TextWidth(ch);
          if x > startx+length-40 then x := x - TextWidth(ch);
          tmpch := ch;
        end;
    end;
  Until ch = #13;
End;{EnterVal}
{-----------------------------------}
Procedure WriteBox(x,y:Integer);
Begin
  SetColor(White);
  SetFillStyle(CloseDotFill,LightBlue);
  Bar(StartX+length div 2 - x,StartY+30-y,StartX+length div 2+x,StartY+30+y);
  Rectangle(StartX+length div 2 - x,StartY+30-y,StartX+length div 2+x,StartY+30+y);
  Delay(Dl1);
End;{WriteBox}
{-------------------------------------}
Begin
  LastColor := GetColor;
  LastBK := GetBkColor;
  If MinValue > MaxValue then begin
    GetValue := 0;
    Exit;
  end;
  length := TextWidth(text) + 50;
  StartX := x1 - length div 2;
  StartY := y1 - 30;
  if length div 2 > x1 then startX := 2;
  if y1 - 30 < 2 then Starty := 1;
  if length div + x1 > 639 then Startx := 639 - length;
  if y1 + 30 > 479 then StartY := 419;
  s1 := ImageSize(Startx,Starty,startx+length,Starty+60);
  GetMem(p1,s1);
  GetImage(Startx,Starty,startx+length,Starty+60,p1^);
  value :=0 ;
  xk := 1;
  k :=60/length;
  for xk := 1 to length div 2 do WriteBox(xk,round(xk*k));
  Repeat
    EnterVal;
    val(st,value,code);
  Until (code = 0) and (value in [MinValue..MaxValue]);
  PutImage(Startx,Starty,p1^,NormalPut);
  GetValue := Value;
  SetColor(LastColor);
  SetBkColor(LastBk);
End;{GetValue}
{----------------------------------------------}

end.