rvspinedit.pas

richviewaction 1.58 需要richview 1.9.46

{*******************************************************}
{                                                       }
{       RichViewActions                                 }
{       TRVSpinEdit v1.1                                }
{                                                       }
{       Copyright (c) Sergey Tkachenko                  }
{       [e-mail]                               }
{       http://www.trichview.com                        }
{                                                       }
{*******************************************************}

{==============================================================================}
{
  One more implementation of spin editor...

  Why it's better than TSpinEdit:
  1) can enter floating-point value
  2) has "indeterminate" state (blank editor)
  4) uses up-down control instead of speedbuttons - thus has a native
     look in themed XP applications
  5) supports mouse wheel
  6) supports large increments (Increment*10) on PageUp and PageDown.

  Properties:
  Value, MinValue, MaxValue, Increment: Extended
  Indeterminate: Boolean
  IntegerValue: Boolean (default True) - disallowing/allowing entering
    floating-point value.
  Funtions:
  AsInteger: Integer - returns rounded value
}
{==============================================================================}

{$I RV_Defs.inc}
{$I RichViewActions.inc}

unit RVSpinEdit;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, StdCtrls, Forms, Graphics,
  ComCtrls {$IFDEF USERVKSDEVTE}, te_theme, te_controls, te_utils, te_winapi{$ENDIF};

type

  TRVSpinEdit = class(TCustomEdit)
  private
    FMinValue: Extended;
    FMaxValue: Extended;
    FIncrement: Extended;
    {$IFNDEF USERVKSDEVTE}
    FButton: TUpDown;
    {$ELSE}
    FPainting, FUpdating: boolean;
    FOldButtonPos: integer;
    FButton: TTeSpinButton;
    {$ENDIF}
    FEditorEnabled: Boolean;
    FIntegerValue: Boolean;
    FDigits: Integer;
    function GetMinHeight: Integer;
    function GetValue: Extended;
    function CheckValue (NewValue: Extended): Extended;
    procedure SetValue (NewValue: Extended);
    procedure SetEditRect;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure CMEnter(var Message: TCMGotFocus); message CM_ENTER;
    procedure CMExit(var Message: TCMExit);   message CM_EXIT;
    procedure WMPaste(var Message: TWMPaste);   message WM_PASTE;
    procedure WMCut(var Message: TWMCut);   message WM_CUT;
    procedure CMEnabledChanged (var Msg: TMessage); message CM_ENABLEDCHANGED;
    procedure CMBiDiModeChanged(var Msg: TMessage); message CM_BIDIMODECHANGED;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure UpDownMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    {$IFNDEF USERVKSDEVTE}
    procedure UpDownClick(Sender: TObject; Button: TUDBtnType);
    procedure UpDownClickEx(Sender: TObject; Delta: Integer);
    {$ELSE}
    procedure UpDownClick(Sender: TObject; var AllowChange: Boolean);
    procedure DoPaint;
    procedure SNMThemeMessage(var Msg: TMessage); message SNM_THEMEMESSAGE;
    procedure PaintBorder(Canvas: TCanvas; ARect: TRect);
    procedure PaintBuffer(Canvas: TCanvas; ARect: TRect);
    {$ENDIF}
    procedure SetIndeterminate(const NewIndeterminate: Boolean);
    function GetIndeterminate: Boolean;
    procedure AdjustItself;
  protected
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    function IsValidChar(Key: Char): Boolean; virtual;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    {$IFDEF USERVKSDEVTE}
    procedure WndProc(var Message: TMessage); override;
    procedure Change; override;
    {$ENDIF}
    function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
    function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function AsInteger: Integer;
  published
    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 Indeterminate: Boolean read GetIndeterminate write SetIndeterminate default False;
    property IntegerValue: Boolean read FIntegerValue write FIntegerValue default True;
    property Digits: Integer read FDigits write FDigits default 2;
    property Anchors;
    property AutoSelect;
    property AutoSize;
    property BiDiMode;
    property Color;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property MaxLength;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property TabStop;
    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;
  end;

implementation {===============================================================}

uses CommCtrl;

const Eps = 1e-20;

type
  TRVUpDownClickEx = procedure (Sender: TObject; Delta: Integer) of object;

  TRVUpDown = class ({$IFNDEF USERVKSDEVTE}TUpDown{$ELSE}TTeSpinButton{$ENDIF})
  {$IFNDEF USERVKSDEVTE}
  private
    FOnClickEx: TRVUpDownClickEx;
    procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  public
    property OnClickEx: TRVUpDownClickEx read FOnClickEx write FOnClickEx;
  {$ENDIF}
  end;

{$IFNDEF USERVKSDEVTE}

procedure TRVUpDown.CNNotify(var Message: TWMNotify);
begin
  with Message do
    if NMHdr^.code = UDN_DELTAPOS then
    begin
      if Assigned(OnClickEx) then
        OnClickEx(Self, PNMUpDown(Message.NMHdr).iDelta);
      Result := 0;
    end;
end;

{$ENDIF}

{================================ TRVSpinEdit =================================}
constructor TRVSpinEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDigits := 2;
  FButton := TRVUpDown.Create (Self);
  {$IFDEF USERVKSDEVTE}
  FButton.EnabledSlider := false;
  FButton.OnChanging := UpDownClick;
  FButton.Min := Low(Integer);
  FButton.Max := High(Integer);
  FButton.ControlStyle := FButton.ControlStyle-[csDoubleClicks];	
  {$ELSE}
  FButton.OnClick := UpDownClick;
  TRVUpDown(FButton).OnClickEx := UpDownClickEx;
  FButton.Min := -10;
  FButton.Max := +10;
  {$ENDIF}
  FButton.Width := 15;
  FButton.Height := 17;
  FButton.Visible := True;
  FButton.Parent := Self;
  FButton.OnMouseDown := UpDownMouseDown;
  FButton.Position := 0;  
  //FButton.Wrap := True;
  FMaxValue := 1000;
  FIntegerValue := True;
  Text := '0';
  ControlStyle := ControlStyle - [csSetCaption];
  FIncrement := 1;
  FEditorEnabled := True;
end;
{------------------------------------------------------------------------------}
destructor TRVSpinEdit.Destroy;
begin
  FButton := nil;
  inherited;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.CreateWnd;
begin
  inherited CreateWnd;
  SetEditRect;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.GetChildren(Proc: TGetChildProc; Root: TComponent);
begin

end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.SetEditRect;
var
  Loc: TRect;
begin
  SendMessage(Handle, EM_GETRECT, 0, LongInt(@Loc));
  Loc.Bottom := ClientHeight + 1;
  Loc.Top := 0;
  if BiDiMode in [bdRightToLeft, bdRightToLeftNoAlign] then begin
    Loc.Right := ClientWidth+1;
    Loc.Left := FButton.Width+2;
    end
  else begin
    Loc.Right := ClientWidth - FButton.Width - 2;
    Loc.Left := 0;
  end;
  SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@Loc));
end;
{------------------------------------------------------------------------------}
function TRVSpinEdit.GetMinHeight: Integer;
var
  DC: HDC;
  SaveFont: HFont;
  I: Integer;
  SysMetrics, Metrics: TTextMetric;
begin
  DC := GetDC(0);
  GetTextMetrics(DC, SysMetrics);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Metrics);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
  I := SysMetrics.tmHeight;
  if I > Metrics.tmHeight then I := Metrics.tmHeight;
  Result := Metrics.tmHeight + I div 4 + GetSystemMetrics(SM_CYBORDER) * 4 + 2;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.AdjustItself;
var
  MinHeight: Integer;
  BorderWidth: Integer;
begin
  inherited;
  MinHeight := GetMinHeight;
  if Height < MinHeight then
    Height := MinHeight
  else if FButton <> nil then begin
    if NewStyleControls and Ctl3D then begin
      BorderWidth := (Height-ClientHeight) div 2;
      if BiDiMode in [bdRightToLeft, bdRightToLeftNoAlign] then
        FButton.SetBounds(0, 0, FButton.Width, Height - BorderWidth*2)
      else
        FButton.SetBounds(Width - FButton.Width - BorderWidth*2, 0, FButton.Width, Height - BorderWidth*2)
      end
    else
      if BiDiMode in [bdRightToLeft, bdRightToLeftNoAlign] then
        FButton.SetBounds (2, 2, FButton.Width, Height - 4)
      else
        FButton.SetBounds (Width - FButton.Width-2, 2, FButton.Width, Height - 4);
    SetEditRect;
  end;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.WMSize(var Message: TWMSize);
begin
  AdjustItself;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.CMEnter(var Message: TCMGotFocus);
begin
  inherited;
  if AutoSelect and not (csLButtonDown in ControlState) then
    SelectAll;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.CMExit(var Message: TCMExit);
begin
  inherited;
  if Text='' then
    Indeterminate := True
  else if not (Abs(CheckValue(Value)-Value)<Eps) then
    SetValue (Value);
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.UpDownMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if TabStop and CanFocus and (GetFocus<>Handle) then
    SetFocus;
end;
{------------------------------------------------------------------------------}
function TRVSpinEdit.IsValidChar(Key: Char): Boolean;
begin
  Result :=((Key=DecimalSeparator) and not IntegerValue) or
           (Key in ['+', '-', '0'..'9']) or
           ((Key < #32) and (Key <> Chr(VK_RETURN)));
  if not FEditorEnabled and Result and ((Key >= #32) or
      (Key = Char(VK_BACK)) or (Key = Char(VK_DELETE))) then
    Result := False;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.WMCut(var Message: TWMCut);
begin
  if not FEditorEnabled or ReadOnly then
    exit;
  inherited;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.WMPaste(var Message: TWMPaste);
begin
  if not FEditorEnabled or ReadOnly then
    exit;
  inherited;
end;
{------------------------------------------------------------------------------}
function TRVSpinEdit.CheckValue(NewValue: Extended): Extended;
begin
  Result := NewValue;
  if IntegerValue then
    try
      Result := Round(Result);
    except
      Result := CheckValue(0);
    end;
  if not (Abs(FMaxValue-FMinValue)<Eps) then begin
    if FMinValue-NewValue>Eps  then
      Result := FMinValue
    else if NewValue-FMaxValue>Eps then
      Result := FMaxValue;