home *** CD-ROM | disk | FTP | other *** search
/ DOS/V Power Report 1996 August / VPR9608A.BIN / del20try / install / data.z / SPIN.PAS < prev    next >
Pascal/Delphi Source File  |  1996-05-08  |  16KB  |  598 lines
  1. unit Spin;
  2.  
  3. interface
  4.  
  5. uses Windows, Classes, StdCtrls, ExtCtrls, Controls, Messages, SysUtils,
  6.   Forms, Graphics, Menus, Buttons;
  7.  
  8. const
  9.   InitRepeatPause = 400;  { pause before repeat timer (ms) }
  10.   RepeatPause     = 100;  { pause before hint window displays (ms)}
  11.  
  12. type
  13.  
  14.   TTimerSpeedButton = class;
  15.  
  16. { TSpinButton }
  17.  
  18.   TSpinButton = class (TWinControl)
  19.   private
  20.     FUpButton: TTimerSpeedButton;
  21.     FDownButton: TTimerSpeedButton;
  22.     FFocusedButton: TTimerSpeedButton;
  23.     FFocusControl: TWinControl;
  24.     FOnUpClick: TNotifyEvent;
  25.     FOnDownClick: TNotifyEvent;
  26.     function CreateButton: TTimerSpeedButton;
  27.     function GetUpGlyph: TBitmap;
  28.     function GetDownGlyph: TBitmap;
  29.     procedure SetUpGlyph(Value: TBitmap);
  30.     procedure SetDownGlyph(Value: TBitmap);
  31.     procedure BtnClick(Sender: TObject);
  32.     procedure BtnMouseDown (Sender: TObject; Button: TMouseButton;
  33.       Shift: TShiftState; X, Y: Integer);
  34.     procedure SetFocusBtn (Btn: TTimerSpeedButton);
  35.     procedure AdjustSize (var W: Integer; var H: Integer);
  36.     procedure WMSize(var Message: TWMSize);  message WM_SIZE;
  37.     procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
  38.     procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
  39.     procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
  40.   protected
  41.     procedure Loaded; override;
  42.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  43.   public
  44.     constructor Create(AOwner: TComponent); override;
  45.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  46.   published
  47.     property Align;
  48.     property Ctl3D;
  49.     property DownGlyph: TBitmap read GetDownGlyph write SetDownGlyph;
  50.     property DragCursor;
  51.     property DragMode;
  52.     property Enabled;
  53.     property FocusControl: TWinControl read FFocusControl write FFocusControl;
  54.     property ParentCtl3D;
  55.     property ParentShowHint;
  56.     property PopupMenu;
  57.     property ShowHint;
  58.     property TabOrder;
  59.     property TabStop;
  60.     property UpGlyph: TBitmap read GetUpGlyph write SetUpGlyph;
  61.     property Visible;
  62.     property OnDownClick: TNotifyEvent read FOnDownClick write FOnDownClick;
  63.     property OnDragDrop;
  64.     property OnDragOver;
  65.     property OnEndDrag;
  66.     property OnEnter;
  67.     property OnExit;
  68.     property OnUpClick: TNotifyEvent read FOnUpClick write FOnUpClick;
  69.   end;
  70.  
  71. { TSpinEdit }
  72.  
  73.   TSpinEdit = class(TCustomEdit)
  74.   private
  75.     FMinValue: LongInt;
  76.     FMaxValue: LongInt;
  77.     FCanvas: TCanvas;
  78.     FIncrement: LongInt;
  79.     FButton: TSpinButton;
  80.     FEditorEnabled: Boolean;
  81.     function GetMinHeight: Integer;
  82.     function GetValue: LongInt;
  83.     function CheckValue (NewValue: LongInt): LongInt;
  84.     procedure SetValue (NewValue: LongInt);
  85.     procedure SetEditRect;
  86.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  87.     procedure CMEnter(var Message: TCMGotFocus); message CM_ENTER;
  88.     procedure CMExit(var Message: TCMExit);   message CM_EXIT;
  89.     procedure WMPaste(var Message: TWMPaste);   message WM_PASTE;
  90.     procedure WMCut(var Message: TWMCut);   message WM_CUT;
  91.   protected
  92.     procedure GetChildren(Proc: TGetChildProc); override;
  93.     function IsValidChar(Key: Char): Boolean; virtual;
  94.     procedure UpClick (Sender: TObject); virtual;
  95.     procedure DownClick (Sender: TObject); virtual;
  96.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  97.     procedure KeyPress(var Key: Char); override;
  98.     procedure CreateParams(var Params: TCreateParams); override;
  99.     procedure CreateWnd; override;
  100.   public
  101.     constructor Create(AOwner: TComponent); override;
  102.     destructor Destroy; override;
  103.     property Button: TSpinButton read FButton;
  104.   published
  105.     property AutoSelect;
  106.     property AutoSize;
  107.     property Color;
  108.     property Ctl3D;
  109.     property DragCursor;
  110.     property DragMode;
  111.     property EditorEnabled: Boolean read FEditorEnabled write FEditorEnabled default True;
  112.     property Enabled;
  113.     property Font;
  114.     property Increment: LongInt read FIncrement write FIncrement default 1;
  115.     property MaxLength;
  116.     property MaxValue: LongInt read FMaxValue write FMaxValue;
  117.     property MinValue: LongInt read FMinValue write FMinValue;
  118.     property ParentColor;
  119.     property ParentCtl3D;
  120.     property ParentFont;
  121.     property ParentShowHint;
  122.     property PopupMenu;
  123.     property ReadOnly;
  124.     property ShowHint;
  125.     property TabOrder;
  126.     property TabStop;
  127.     property Value: LongInt read GetValue write SetValue;
  128.     property Visible;
  129.     property OnChange;
  130.     property OnClick;
  131.     property OnDblClick;
  132.     property OnDragDrop;
  133.     property OnDragOver;
  134.     property OnEndDrag;
  135.     property OnEnter;
  136.     property OnExit;
  137.     property OnKeyDown;
  138.     property OnKeyPress;
  139.     property OnKeyUp;
  140.     property OnMouseDown;
  141.     property OnMouseMove;
  142.     property OnMouseUp;
  143.   end;
  144.  
  145. { TTimerSpeedButton }
  146.  
  147.   TTimeBtnState = set of (tbFocusRect, tbAllowTimer);
  148.  
  149.   TTimerSpeedButton = class(TSpeedButton)
  150.   private
  151.     FRepeatTimer: TTimer;
  152.     FTimeBtnState: TTimeBtnState;
  153.     procedure TimerExpired(Sender: TObject);
  154.   protected
  155.     procedure Paint; override;
  156.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  157.       X, Y: Integer); override;
  158.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  159.       X, Y: Integer); override;
  160.   public
  161.     destructor Destroy; override;
  162.     property TimeBtnState: TTimeBtnState read FTimeBtnState write FTimeBtnState;
  163.   end;
  164.  
  165. implementation
  166.  
  167. {$R SPIN}
  168.  
  169. { TSpinButton }
  170.  
  171. constructor TSpinButton.Create(AOwner: TComponent);
  172. begin
  173.   inherited Create(AOwner);
  174.   ControlStyle := ControlStyle - [csAcceptsControls, csSetCaption] +
  175.     [csFramed, csOpaque];
  176.  
  177.   FUpButton := CreateButton;
  178.   FDownButton := CreateButton;
  179.   UpGlyph := nil;
  180.   DownGlyph := nil;
  181.  
  182.   Width := 20;
  183.   Height := 25;
  184.   FFocusedButton := FUpButton;
  185. end;
  186.  
  187. function TSpinButton.CreateButton: TTimerSpeedButton;
  188. begin
  189.   Result := TTimerSpeedButton.Create (Self);
  190.   Result.OnClick := BtnClick;
  191.   Result.OnMouseDown := BtnMouseDown;
  192.   Result.Visible := True;
  193.   Result.Enabled := True;
  194.   Result.TimeBtnState := [tbAllowTimer];
  195.   Result.NumGlyphs := 1;
  196.   Result.Parent := Self;
  197. end;
  198.  
  199. procedure TSpinButton.AdjustSize (var W: Integer; var H: Integer);
  200. begin
  201.   if (FUpButton = nil) or (csLoading in ComponentState) then Exit;
  202.   if W < 15 then W := 15;
  203.   FUpButton.SetBounds (0, 0, W, H div 2);
  204.   FDownButton.SetBounds (0, FUpButton.Height - 1, W, H - FUpButton.Height + 1);
  205. end;
  206.  
  207. procedure TSpinButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  208. var
  209.   W, H: Integer;
  210. begin
  211.   W := AWidth;
  212.   H := AHeight;
  213.   AdjustSize (W, H);
  214.   inherited SetBounds (ALeft, ATop, W, H);
  215. end;
  216.  
  217. procedure TSpinButton.WMSize(var Message: TWMSize);
  218. var
  219.   W, H: Integer;
  220. begin
  221.   inherited;
  222.  
  223.   { check for minimum size }
  224.   W := Width;
  225.   H := Height;
  226.   AdjustSize (W, H);
  227.   if (W <> Width) or (H <> Height) then
  228.     inherited SetBounds(Left, Top, W, H);
  229.   Message.Result := 0;
  230. end;
  231.  
  232. procedure TSpinButton.WMSetFocus(var Message: TWMSetFocus);
  233. begin
  234.   FFocusedButton.TimeBtnState := FFocusedButton.TimeBtnState + [tbFocusRect];
  235.   FFocusedButton.Invalidate;
  236. end;
  237.  
  238. procedure TSpinButton.WMKillFocus(var Message: TWMKillFocus);
  239. begin
  240.   FFocusedButton.TimeBtnState := FFocusedButton.TimeBtnState - [tbFocusRect];
  241.   FFocusedButton.Invalidate;
  242. end;
  243.  
  244. procedure TSpinButton.KeyDown(var Key: Word; Shift: TShiftState);
  245. begin
  246.   case Key of
  247.     VK_UP:
  248.       begin
  249.         SetFocusBtn (FUpButton);
  250.         FUpButton.Click;
  251.       end;
  252.     VK_DOWN:
  253.       begin
  254.         SetFocusBtn (FDownButton);
  255.         FDownButton.Click;
  256.       end;
  257.     VK_SPACE:
  258.       FFocusedButton.Click;
  259.   end;
  260. end;
  261.  
  262. procedure TSpinButton.BtnMouseDown (Sender: TObject; Button: TMouseButton;
  263.   Shift: TShiftState; X, Y: Integer);
  264. begin
  265.   if Button = mbLeft then
  266.   begin
  267.     SetFocusBtn (TTimerSpeedButton (Sender));
  268.     if (FFocusControl <> nil) and FFocusControl.TabStop and 
  269.         FFocusControl.CanFocus and (GetFocus <> FFocusControl.Handle) then
  270.       FFocusControl.SetFocus
  271.     else if TabStop and (GetFocus <> Handle) and CanFocus then
  272.       SetFocus;
  273.   end;
  274. end;
  275.  
  276. procedure TSpinButton.BtnClick(Sender: TObject);
  277. begin
  278.   if Sender = FUpButton then
  279.   begin
  280.     if Assigned(FOnUpClick) then FOnUpClick(Self);
  281.   end
  282.   else
  283.     if Assigned(FOnDownClick) then FOnDownClick(Self);
  284. end;
  285.  
  286. procedure TSpinButton.SetFocusBtn (Btn: TTimerSpeedButton);
  287. begin
  288.   if TabStop and CanFocus and  (Btn <> FFocusedButton) then
  289.   begin
  290.     FFocusedButton.TimeBtnState := FFocusedButton.TimeBtnState - [tbFocusRect];
  291.     FFocusedButton := Btn;
  292.     if (GetFocus = Handle) then 
  293.     begin
  294.        FFocusedButton.TimeBtnState := FFocusedButton.TimeBtnState + [tbFocusRect];
  295.        Invalidate;
  296.     end;
  297.   end;   
  298. end;
  299.  
  300. procedure TSpinButton.WMGetDlgCode(var Message: TWMGetDlgCode);
  301. begin
  302.   Message.Result := DLGC_WANTARROWS;
  303. end;
  304.  
  305. procedure TSpinButton.Loaded;
  306. var
  307.   W, H: Integer;
  308. begin
  309.   inherited Loaded;
  310.   W := Width;
  311.   H := Height;
  312.   AdjustSize (W, H);
  313.   if (W <> Width) or (H <> Height) then
  314.     inherited SetBounds (Left, Top, W, H);
  315. end;
  316.  
  317. function TSpinButton.GetUpGlyph: TBitmap;
  318. begin
  319.   Result := FUpButton.Glyph;
  320. end;
  321.  
  322. procedure TSpinButton.SetUpGlyph(Value: TBitmap);
  323. begin
  324.   if Value <> nil then
  325.     FUpButton.Glyph := Value
  326.   else
  327.   begin
  328.     FUpButton.Glyph.Handle := LoadBitmap(HInstance, 'SpinUp');
  329.     FUpButton.NumGlyphs := 1;
  330.     FUpButton.Invalidate;
  331.   end;
  332. end;
  333.  
  334. function TSpinButton.GetDownGlyph: TBitmap;
  335. begin
  336.   Result := FDownButton.Glyph;
  337. end;
  338.  
  339. procedure TSpinButton.SetDownGlyph(Value: TBitmap);
  340. begin
  341.   if Value <> nil then
  342.     FDownButton.Glyph := Value
  343.   else
  344.   begin
  345.     FDownButton.Glyph.Handle := LoadBitmap(HInstance, 'SpinDown');
  346.     FDownButton.NumGlyphs := 1;
  347.     FDownButton.Invalidate;
  348.   end;
  349. end;
  350.  
  351. { TSpinEdit }
  352.  
  353. constructor TSpinEdit.Create(AOwner: TComponent);
  354. begin
  355.   inherited Create(AOwner);
  356.   FButton := TSpinButton.Create (Self);
  357.   FButton.Width := 15;
  358.   FButton.Height := 17;
  359.   FButton.Visible := True;  
  360.   FButton.Parent := Self;
  361.   FButton.FocusControl := Self;
  362.   FButton.OnUpClick := UpClick;
  363.   FButton.OnDownClick := DownClick;
  364.   Text := '0';
  365.   ControlStyle := ControlStyle - [csSetCaption];
  366.   FIncrement := 1;
  367.   FEditorEnabled := True;
  368. end;
  369.  
  370. destructor TSpinEdit.Destroy;
  371. begin
  372.   FButton := nil;
  373.   inherited Destroy;
  374. end;
  375.  
  376. procedure TSpinEdit.GetChildren(Proc: TGetChildProc);
  377. begin
  378.   {intentionally left blank} {!!! this will change}
  379. end;
  380.  
  381. procedure TSpinEdit.KeyDown(var Key: Word; Shift: TShiftState);
  382. begin
  383.   if Key = VK_UP then UpClick (Self)
  384.   else if Key = VK_DOWN then DownClick (Self);
  385.   inherited KeyDown(Key, Shift);
  386. end;
  387.  
  388. procedure TSpinEdit.KeyPress(var Key: Char);
  389. begin
  390.   if not IsValidChar(Key) then
  391.   begin
  392.     Key := #0;
  393.     MessageBeep(0)
  394.   end;
  395.   if Key <> #0 then inherited KeyPress(Key);
  396. end;
  397.  
  398. function TSpinEdit.IsValidChar(Key: Char): Boolean;
  399. begin
  400.   Result := (Key in [DecimalSeparator, '+', '-', '0'..'9']) or
  401.     ((Key < #32) and (Key <> Chr(VK_RETURN)));
  402.   if not FEditorEnabled and Result and ((Key >= #32) or
  403.       (Key = Char(VK_BACK)) or (Key = Char(VK_DELETE))) then
  404.     Result := False;
  405. end;
  406.  
  407. procedure TSpinEdit.CreateParams(var Params: TCreateParams);
  408. begin
  409.   inherited CreateParams(Params);
  410. {  Params.Style := Params.Style and not WS_BORDER;  }
  411.   Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN;
  412. end;
  413.  
  414. procedure TSpinEdit.CreateWnd;
  415. begin
  416.   inherited CreateWnd;
  417.   SetEditRect;
  418. end;
  419.  
  420. procedure TSpinEdit.SetEditRect;
  421. var
  422.   Loc: TRect;
  423. begin
  424.   SendMessage(Handle, EM_GETRECT, 0, LongInt(@Loc));
  425.   Loc.Bottom := ClientHeight + 1;  {+1 is workaround for windows paint bug}
  426.   Loc.Right := ClientWidth - FButton.Width - 2;
  427.   Loc.Top := 0;  
  428.   Loc.Left := 0;  
  429.   SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@Loc));
  430.   SendMessage(Handle, EM_GETRECT, 0, LongInt(@Loc));  {debug}
  431. end;
  432.  
  433. procedure TSpinEdit.WMSize(var Message: TWMSize);
  434. var
  435.   MinHeight: Integer;
  436. begin
  437.   inherited;
  438.   MinHeight := GetMinHeight;
  439.     { text edit bug: if size to less than minheight, then edit ctrl does
  440.       not display the text }
  441.   if Height < MinHeight then   
  442.     Height := MinHeight
  443.   else if FButton <> nil then
  444.   begin
  445.     if NewStyleControls then
  446.       FButton.SetBounds(Width - FButton.Width - 5, 0, FButton.Width, Height - 5)
  447.     else FButton.SetBounds (Width - FButton.Width, 0, FButton.Width, Height);
  448.     SetEditRect;
  449.   end;
  450. end;
  451.  
  452. function TSpinEdit.GetMinHeight: Integer;
  453. var
  454.   DC: HDC;
  455.   SaveFont: HFont;
  456.   I: Integer;
  457.   SysMetrics, Metrics: TTextMetric;
  458. begin
  459.   DC := GetDC(0);
  460.   GetTextMetrics(DC, SysMetrics);
  461.   SaveFont := SelectObject(DC, Font.Handle);
  462.   GetTextMetrics(DC, Metrics);
  463.   SelectObject(DC, SaveFont);
  464.   ReleaseDC(0, DC);
  465.   I := SysMetrics.tmHeight;
  466.   if I > Metrics.tmHeight then I := Metrics.tmHeight;
  467.   Result := Metrics.tmHeight + I div 4 + GetSystemMetrics(SM_CYBORDER) * 4 + 2;
  468. end;
  469.  
  470. procedure TSpinEdit.UpClick (Sender: TObject);
  471. begin
  472.   if ReadOnly then MessageBeep(0)
  473.   else Value := Value + FIncrement;
  474. end;
  475.  
  476. procedure TSpinEdit.DownClick (Sender: TObject);
  477. begin
  478.   if ReadOnly then MessageBeep(0)
  479.   else Value := Value - FIncrement;
  480. end;
  481.  
  482. procedure TSpinEdit.WMPaste(var Message: TWMPaste);   
  483. begin
  484.   if not FEditorEnabled or ReadOnly then Exit;
  485.   inherited;
  486. end;
  487.  
  488. procedure TSpinEdit.WMCut(var Message: TWMPaste);   
  489. begin
  490.   if not FEditorEnabled or ReadOnly then Exit;
  491.   inherited;
  492. end;
  493.  
  494. procedure TSpinEdit.CMExit(var Message: TCMExit);
  495. begin
  496.   inherited;
  497.   if CheckValue (Value) <> Value then
  498.     SetValue (Value);
  499. end;
  500.  
  501. function TSpinEdit.GetValue: LongInt;
  502. begin
  503.   try
  504.     Result := StrToInt (Text);
  505.   except
  506.     Result := FMinValue;
  507.   end;
  508. end;
  509.  
  510. procedure TSpinEdit.SetValue (NewValue: LongInt);
  511. begin
  512.   Text := IntToStr (CheckValue (NewValue));
  513. end;
  514.  
  515. function TSpinEdit.CheckValue (NewValue: LongInt): LongInt;
  516. begin
  517.   Result := NewValue;
  518.   if (FMaxValue <> FMinValue) then
  519.   begin
  520.     if NewValue < FMinValue then
  521.       Result := FMinValue
  522.     else if NewValue > FMaxValue then
  523.       Result := FMaxValue;
  524.   end;
  525. end;
  526.  
  527. procedure TSpinEdit.CMEnter(var Message: TCMGotFocus);
  528. begin
  529.   if AutoSelect and not (csLButtonDown in ControlState) then
  530.     SelectAll;
  531.   inherited;
  532. end;
  533.  
  534. {TTimerSpeedButton}
  535.  
  536. destructor TTimerSpeedButton.Destroy;
  537. begin
  538.   if FRepeatTimer <> nil then
  539.     FRepeatTimer.Free;
  540.   inherited Destroy;
  541. end;
  542.  
  543. procedure TTimerSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  544.   X, Y: Integer);
  545. begin
  546.   inherited MouseDown (Button, Shift, X, Y);
  547.   if tbAllowTimer in FTimeBtnState then
  548.   begin
  549.     if FRepeatTimer = nil then
  550.       FRepeatTimer := TTimer.Create(Self);
  551.  
  552.     FRepeatTimer.OnTimer := TimerExpired;
  553.     FRepeatTimer.Interval := InitRepeatPause;
  554.     FRepeatTimer.Enabled  := True;
  555.   end;
  556. end;
  557.  
  558. procedure TTimerSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  559.                                   X, Y: Integer);
  560. begin
  561.   inherited MouseUp (Button, Shift, X, Y);
  562.   if FRepeatTimer <> nil then
  563.     FRepeatTimer.Enabled  := False;
  564. end;
  565.  
  566. procedure TTimerSpeedButton.TimerExpired(Sender: TObject);
  567. begin
  568.   FRepeatTimer.Interval := RepeatPause;
  569.   if (FState = bsDown) and MouseCapture then
  570.   begin
  571.     try
  572.       Click;
  573.     except
  574.       FRepeatTimer.Enabled := False;
  575.       raise;
  576.     end;
  577.   end;
  578. end;
  579.  
  580. procedure TTimerSpeedButton.Paint;
  581. var
  582.   R: TRect;
  583. begin
  584.   inherited Paint;
  585.   if tbFocusRect in FTimeBtnState then
  586.   begin
  587.     R := Bounds(0, 0, Width, Height);
  588.     InflateRect(R, -3, -3);
  589.     if FState = bsDown then
  590.       OffsetRect(R, 1, 1);
  591.     DrawFocusRect(Canvas.Handle, R);
  592.   end;
  593. end;
  594.  
  595. end.
  596.  
  597.  
  598.