spinse.pas

FlexGraphics是一套创建矢量图形的VCL组件

unit SpinSE;

// Set this define if you use ThemeManager library
// in Delphi/C++Builder lower 7.0 
{.DEFINE XPTHEMES}

{$IFNDEF VER80}                { DELPHI 1.0     }
 {$IFNDEF VER90}               { DELPHI 2.0     }
  {$IFNDEF VER93}              { C++Builder 1.0 }
   {$IFNDEF VER100}            { DELPHI 3.0     }
    {$IFNDEF VER110}           { C++Builder 3.0 }
     {$IFNDEF VER120}          { DELPHI 4.0 }
      {$IFNDEF VER125}         { C++Builder 4.0 }
       {$IFNDEF VER130}        { DELPHI/C++Builder 5.0 }
        {$IFNDEF VER140}       { DELPHI/C++Builder 6.0 }
         {$DEFINE DELPHI7_UP}  { DELPHI/C++Builder higher 6.0 }
         {$DEFINE XPTHEMES}
        {$ENDIF}
       {$ENDIF}
      {$ENDIF}
     {$ENDIF}
    {$ENDIF}
   {$ENDIF}
  {$ENDIF}
 {$ENDIF}
{$ENDIF}

{$IFDEF VER200}
  {$DEFINE DELPHI12_UP}
{$ENDIF}

interface

uses
  Windows, Classes, StdCtrls, ExtCtrls, Controls, Messages, SysUtils,
  {$IFDEF XPTHEMES}
    {$IFDEF DELPHI7_UP} Themes, {$ELSE} ThemeSrv, {$ENDIF}
  {$ENDIF}
  Forms, Graphics, Menus, Buttons;

const
  InitRepeatPause = 400;  { pause before repeat timer (ms) }
  RepeatPause     = 70;  { pause before hint window displays (ms)}

type
  TUpDownBtnSE = ( udbNone, udbUp, udbDown );

  TCustomUpDownSE = class(TCustomControl)
  private
   FRepeatTimer: TTimer;
   FFocusControl: TWinControl;
   FOnUpClick: TNotifyEvent;
   FOnDownClick: TNotifyEvent;
   FHighlighted: TUpDownBtnSE;
   FPressed: TUpDownBtnSE;
   procedure TimerExpired(Sender: TObject);
   procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
   procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
   procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  protected
   procedure Paint; override;
   procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
   procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
     X, Y: Integer); override;
   procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
     override;
   procedure KeyDown(var Key: Word; Shift: TShiftState); override;
   procedure DoUpClick; virtual;
   procedure DoDownClick; virtual;
   property  FocusControl: TWinControl read FFocusControl write FFocusControl;
   property  OnDownClick: TNotifyEvent read FOnDownClick write FOnDownClick;
   property  OnUpClick: TNotifyEvent read FOnUpClick write FOnUpClick;
  public
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
   property   Pressed: TUpDownBtnSE read FPressed;
  end;

  TUpDownSE = class(TCustomUpDownSE)
  published
    property Align;
    property Anchors;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property FocusControl;
    property ParentCtl3D;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnDownClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnStartDock;
    property OnStartDrag;
    property OnUpClick;
  end;

  TFlexSpinValueType = (
    fvtInteger,
    fvtFloat
  );

  TFlexSpinUpDownEvent = procedure(Sender: TObject;
    var NewValue: extended) of object;

  TFlexSpinValidChar = procedure(Sender: TObject; AChar: char;
    var IsValid: boolean) of object;

  TCustomSpinEditSE = class(TCustomEdit)
  private
   FMinValue: extended;
   FMaxValue: extended;
   FIncrement: extended;
   FButton: TUpDownSE;
   FEditorEnabled: Boolean;
   FDigitsOnly: boolean;
   FDecimal: integer;
   FOnUpClick: TFlexSpinUpDownEvent;
   FOnDownClick: TFlexSpinUpDownEvent;
   FOnIsCharValid: TFlexSpinValidChar;
   function  GetMinHeight: Integer;
   function  GetValue: extended;
   function  CheckValue(NewValue: extended): extended;
   procedure SetValue(NewValue: extended);
   procedure SetEditRect;
   procedure SetDigitsOnly(const Value: boolean);
   function  GetIntValue: integer;
   procedure SetIntValue(const Value: integer);
   procedure SetDecimal(const Value: integer);
   procedure CMEnter(var Message: TCMGotFocus); message CM_ENTER;
   procedure CMExit(var Message: TCMExit); message CM_EXIT;
   procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
   procedure WMSize(var Message: TWMSize); message WM_SIZE;
   procedure WMPaste(var Message: TWMPaste); message WM_PASTE;
   procedure WMCut(var Message: TWMCut); message WM_CUT;
  protected
   procedure DoUpClick(var NewValue: extended); virtual;
   procedure DoDownClick(var NewValue: extended); virtual;
   {$IFNDEF DELPHI12_UP}
   procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
   {$ENDIF}
   function  IsValidChar(Key: Char): Boolean; virtual;
   procedure UpClick(Sender: TObject); virtual;
   procedure DownClick(Sender: TObject); virtual;
   procedure KeyDown(var Key: Word; Shift: TShiftState); override;
   procedure KeyPress(var Key: Char); override;
   procedure CreateParams(var Params: TCreateParams); override;
   procedure CreateWnd; override;
   property  EditorEnabled: Boolean read FEditorEnabled write FEditorEnabled default True;
   property  Increment: extended read FIncrement write FIncrement;
   property  MaxValue: extended read FMaxValue write FMaxValue;
   property  MinValue: extended read FMinValue write FMinValue;
   property  Value: extended read GetValue write SetValue;
   property  IntValue: integer read GetIntValue write SetIntValue;
   property  Decimal: integer read FDecimal write SetDecimal default 0;
   property  DigitsOnly: boolean read FDigitsOnly write SetDigitsOnly
     default false;
   property  OnDownClick: TFlexSpinUpDownEvent read FOnDownClick
     write FOnDownClick;
   property  OnUpClick: TFlexSpinUpDownEvent read FOnUpClick write FOnUpClick;
   property  OnIsCharValid: TFlexSpinValidChar read FOnIsCharValid
     write FOnIsCharValid;
  public
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
   {$IFDEF DELPHI12_UP}
   procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
   {$ENDIF}
   property  Button: TUpDownSE read FButton;
  end;


  TSpinEditSE = class(TCustomSpinEditSE)
  published
    property Anchors;
    property AutoSelect;
    property AutoSize;
    property Color;
    property Constraints;
    property Ctl3D;
    property Decimal;
    property DigitsOnly;
    property DragCursor;
    property DragMode;
    property EditorEnabled;
    property Enabled;
    property Font;
    property Increment;
    property MaxLength;
    property MaxValue;
    property MinValue;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Value;
    property Visible;
    property OnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
    property OnIsCharValid; 
    property OnDownClick;
    property OnUpClick;
  end;

implementation

// TCustomFlexUpDown ///////////////////////////////////////////////////////////

constructor TCustomUpDownSE.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 ControlStyle := ControlStyle - [csAcceptsControls, csSetCaption] +
   [csOpaque];
 Width := 20;
 Height := 25;
end;

destructor TCustomUpDownSE.Destroy;
begin
 FRepeatTimer.Free;
 FRepeatTimer := Nil;
 inherited;
end;

procedure TCustomUpDownSE.CMMouseLeave(var Message: TMessage);
begin
 FHighlighted := udbNone;
 Invalidate;
end;

procedure TCustomUpDownSE.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
 Message.Result := DLGC_WANTARROWS;
end;

procedure TCustomUpDownSE.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
 Message.Result := 1;
end;

procedure TCustomUpDownSE.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
 if (X >= 0) and (Y >= 0) and (X < Width) and (Y < Height) then begin
  if Y <= Height div 2
   then FHighlighted := udbUp
   else FHighlighted := udbDown;
  if FPressed = udbNone then Invalidate;
 end;
 inherited;
end;

procedure TCustomUpDownSE.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
 if (FHighlighted <> udbNone) and (Button = mbLeft) then begin
  FPressed := FHighlighted;
  Invalidate;
  case FPressed of
   udbUp   : DoUpClick;
   udbDown : DoDownClick;
  end;
  if FRepeatTimer = nil then begin
   FRepeatTimer := TTimer.Create(Self);
   FRepeatTimer.OnTimer := TimerExpired;
  end else
   FRepeatTimer.Enabled := false;
  FRepeatTimer.Interval := InitRepeatPause;
  FRepeatTimer.Enabled  := true;
 end;
 inherited;
end;

procedure TCustomUpDownSE.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
 inherited;
 FRepeatTimer.Free;
 FRepeatTimer := Nil;
 if FPressed <> udbNone then begin
  FPressed := udbNone;
  Invalidate;
 end;
end;

procedure TCustomUpDownSE.TimerExpired(Sender: TObject);
begin
 FRepeatTimer.Interval := RepeatPause;
 if (FPressed = udbNone) or not MouseCapture then begin
  FRepeatTimer.Enabled := false;
  exit;
 end;
 try
  case FPressed of
   udbUp   : DoUpClick;
   udbDown : DoDownClick;
  end;
 except
  FRepeatTimer.Enabled := False;
  raise;
 end;
end;

procedure TCustomUpDownSE.KeyDown(var Key: Word; Shift: TShiftState);
begin
 case Key of
  VK_UP   : DoUpClick;
  VK_DOWN : DoDownClick;
 end;
 inherited;
end;