vrspinner.pas

作工控的好控件

{*****************************************************}
{                                                     }
{     Varian Component Workshop                       }
{                                                     }
{     Varian Software NL (c) 1996-2000                }
{     All Rights Reserved                             }
{                                                     }
{*****************************************************}

unit VrSpinner;

{$I VRLIB.INC}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  CommCtrl, {$IFDEF VER110} ImgList,{$ENDIF} VrClasses, VrControls,
  VrTypes, VrSysUtils, VrThreads;


const
  InitRepeatPause = 400;
  RepeatPause     = 100;

type
  TVrSpinButton = class;
  TVrTimerSpinButton = class;

  TVrSpinButtonType = (stUp, stDown, stLeft, stRight);

  TVrSpinner = class (TWinControl)
  private
    FUpButton: TVrTimerSpinButton;
    FDownButton: TVrTimerSpinButton;
    FFocusedButton: TVrTimerSpinButton;
    FFocusControl: TWinControl;
    FOrientation: TVrOrientation;
    FPalette: TVrPalette;
    FOnUpClick: TNotifyEvent;
    FOnDownClick: TNotifyEvent;
    function CreateButton(BtnType: TVrSpinButtonType): TVrTimerSpinButton;
    procedure BtnClick(Sender: TObject);
    procedure BtnMouseDown (Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure SetFocusBtn (Btn: TVrTimerSpinButton);
    procedure ChangeSize (var W: Integer; var H: Integer);
    procedure SetOrientation(Value: TVrOrientation);
    procedure SetPalette(Value: TVrPalette);
    procedure PaletteModified(Sender: TObject);
    procedure WMSize(var Message: TWMSize);  message WM_SIZE;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  protected
    procedure Loaded; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  published
    property FocusControl: TWinControl read FFocusControl write FFocusControl;
    property Orientation: TVrOrientation read FOrientation write SetOrientation default voVertical;
    property Palette: TVrPalette read FPalette write SetPalette;
    property OnDownClick: TNotifyEvent read FOnDownClick write FOnDownClick;
    property OnUpClick: TNotifyEvent read FOnUpClick write FOnUpClick;
    property Align;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    property Color default clBtnFace;
    property DragCursor;
{$IFDEF VER110}
    property DragKind;
{$ENDIF}
    property DragMode;
    property Enabled;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnDragDrop;
    property OnDragOver;
{$IFDEF VER110}
    property OnEndDock;
{$ENDIF}
    property OnEndDrag;
    property OnEnter;
    property OnExit;
{$IFDEF VER110}
    property OnStartDock;
{$ENDIF}
    property OnStartDrag;
  end;

  TVrSpinButton = class(TVrGraphicControl)
  private
    FBtnType: TVrSpinButtonType;
    FPalette: TVrPalette;
    ImageList: TImageList;
    Bitmap: TBitmap; //Mask
    MouseBtnDown: Boolean;
    procedure SetBtnType(Value: TVrSpinButtonType);
    procedure SetPalette(Value: TVrPalette);
    procedure PaletteModified(Sender: TObject);
    function InControl(X, Y: Integer): Boolean;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure LoadBitmaps; virtual;
    function ImageRect: TRect;
    procedure Paint; override;
    procedure Click; override;
    procedure DoClick;
    property BtnType: TVrSpinButtonType read FBtnType write SetBtnType default stUp;
    property Palette: TVrPalette read FPalette write SetPalette;
    property Color default clBtnFace;
    property ParentColor default true;
    property Enabled;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  { TTimerSpeedButton }

  TTimeBtnState = set of (tbFocusRect, tbAllowTimer);

  TVrTimerSpinButton = class(TVrSpinButton)
  private
    FRepeatTimer: TVrTimer;
    FTimeBtnState: TTimeBtnState;
    procedure TimerExpired(Sender: TObject);
  protected
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
  public
    destructor Destroy; override;
    property TimeBtnState: TTimeBtnState read FTimeBtnState write FTimeBtnState;
  end;


implementation

{$R VRSPINNER.D32}

const
  ResId: array[TVrSpinButtonType] of PChar =
    ('ARROWS_UP', 'ARROWS_DOWN', 'ARROWS_LEFT', 'ARROWS_RIGHT');



{ TVrSpinner }
constructor TVrSpinner.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle -
    [csAcceptsControls, csSetCaption, csFramed] + [csOpaque];
  Width := 35;
  Height := 40;
  Color := clBtnFace;
  ParentColor := true;
  FOrientation := voVertical;
  FPalette := TVrPalette.Create;
  FPalette.OnChange := PaletteModified;
  FUpButton := CreateButton(stUp);
  FDownButton := CreateButton(stDown);
  FFocusedButton := FUpButton;
end;

destructor TVrSpinner.Destroy;
begin
  FPalette.Free;
  inherited Destroy;
end;

function TVrSpinner.CreateButton(BtnType: TVrSpinButtonType): TVrTimerSpinButton;
begin
  Result := TVrTimerSpinButton.Create (Self);
  Result.OnClick := BtnClick;
  Result.OnMouseDown := BtnMouseDown;
  Result.Visible := True;
  Result.Enabled := True;
  Result.TimeBtnState := [tbAllowTimer];
  Result.BtnType := BtnType;
  Result.Palette.Assign(Palette);
  Result.Parent := Self;
end;

procedure TVrSpinner.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FFocusControl) then
    FFocusControl := nil;
end;

procedure TVrSpinner.ChangeSize(var W: Integer; var H: Integer);
begin
  if (FUpButton = nil) or (csLoading in ComponentState) then Exit;
  if W < 15 then W := 15;
  if FOrientation = voVertical then
  begin
    FUpButton.SetBounds (0, 0, W, H div 2);
    FDownButton.SetBounds (0, FUpButton.Height - 1, W, H - FUpButton.Height + 1);
  end
  else
  begin
    FUpButton.SetBounds (0, 0, W div 2, H);
    FDownButton.SetBounds(W div 2, 0, W div 2, H);
  end;
end;

procedure TVrSpinner.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
  W, H: Integer;
begin
  W := AWidth;
  H := AHeight;
  ChangeSize (W, H);
  inherited SetBounds (ALeft, ATop, W, H);
end;

procedure TVrSpinner.WMSize(var Message: TWMSize);
var
  W, H: Integer;
begin
  inherited;
  { check for minimum size }
  W := Width;
  H := Height;
  ChangeSize (W, H);
  if (W <> Width) or (H <> Height) then
    inherited SetBounds(Left, Top, W, H);
  Message.Result := 0;
end;

procedure TVrSpinner.WMSetFocus(var Message: TWMSetFocus);
begin
  FFocusedButton.TimeBtnState := FFocusedButton.TimeBtnState + [tbFocusRect];
  FFocusedButton.UpdateControlCanvas;
end;

procedure TVrSpinner.WMKillFocus(var Message: TWMKillFocus);
begin
  FFocusedButton.TimeBtnState := FFocusedButton.TimeBtnState - [tbFocusRect];
  FFocusedButton.UpdateControlCanvas;
end;

procedure TVrSpinner.KeyDown(var Key: Word; Shift: TShiftState);
begin
  case Key of
    VK_UP:
      if FOrientation = voVertical then
      begin
        SetFocusBtn (FUpButton);
        FUpButton.DoClick;
      end;
    VK_DOWN:
      if FOrientation = voVertical then
      begin
        SetFocusBtn (FDownButton);
        FDownButton.DoClick;
      end;
    VK_LEFT:
      if FOrientation = voHorizontal then
      begin
        SetFocusBtn (FUpButton);
        FUpButton.DoClick;
      end;
    VK_RIGHT:
      if FOrientation = voHorizontal then
      begin
        SetFocusBtn (FDownButton);
        FDownButton.DoClick;
      end;

    VK_SPACE:
      FFocusedButton.DoClick;
  end;
end;

procedure TVrSpinner.BtnMouseDown (Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then