
{*******************************************************}
{                                                       }
{       RichViewActions                                 }
{       TRVSpinEdit v1.1                                }
{                                                       }
{       Copyright (c) Sergey Tkachenko                  }
{       svt@trichview.com                               }
{       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
    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;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  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='+') or (Key='-') or ((Key>='0') and (Key<='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;
  end;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if not Enabled then exit;
  case Key of
  VK_UP, VK_DOWN, VK_NEXT, VK_PRIOR:
    if ReadOnly then
      MessageBeep(0)
    else
      case Key of
        VK_UP:
          Value := Value+Increment;
        VK_DOWN:
          Value := Value-Increment;
        VK_NEXT:
          Value := Value-Increment*10;
        VK_PRIOR:
          Value := Value+Increment*10;
      end;
  end;
  inherited KeyDown(Key, Shift);
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.KeyPress(var Key: Char);
begin
  if not Enabled then exit;
  if not IsValidChar(Key) then begin
    Key := #0;
    MessageBeep(0)
  end;
  if (Key <> #0) then
    inherited KeyPress(Key);
end;
{------------------------------------------------------------------------------}
function TRVSpinEdit.GetValue: Extended;
begin
  try
    if Text<>'' then
      Result := StrToFloat (Text)
    else
      Result := CheckValue(0);
  except
    Result := CheckValue(0);
  end;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.SetValue(NewValue: Extended);
begin
  if IntegerValue or (Digits=0) then
    Text := FloatToStr (CheckValue (NewValue))
  else
    Text := FloatToStrF (CheckValue (NewValue), ffFixed, 18, Digits);
end;
{------------------------------------------------------------------------------}
{$IFNDEF USERVKSDEVTE}
procedure TRVSpinEdit.UpDownClick(Sender: TObject; Button: TUDBtnType);
begin
  FButton.Position := 0;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.UpDownClickEx(Sender: TObject; Delta: Integer);
begin
  if ReadOnly then
  begin
    MessageBeep(0);
    exit;
  end;
  Value := Value + Increment*Delta;
end;
{$ELSE}
procedure TRVSpinEdit.UpDownClick(Sender: TObject; var AllowChange: Boolean);
var
  Delta: integer;
begin
  if FUpdating then
    exit;
  if ReadOnly then
  begin
    MessageBeep(0);
    Exit;
  end;
  Delta := FButton.Position - FOldButtonPos;
  Value := Value + Increment * Delta;
  if not Indeterminate then begin
    FUpdating := True;
    try
      FButton.Position := AsInteger;
      FOldButtonPos := AsInteger;
    finally
      FUpdating := False;
    end;
  end;
end;
{$ENDIF}
{------------------------------------------------------------------------------}
function TRVSpinEdit.DoMouseWheelDown(Shift: TShiftState;
  MousePos: TPoint): Boolean;
begin
  if not ReadOnly then
    Value := Value - FIncrement;
  Result := True;
end;
{------------------------------------------------------------------------------}
function TRVSpinEdit.DoMouseWheelUp(Shift: TShiftState;
  MousePos: TPoint): Boolean;
begin
  if not ReadOnly then
    Value := Value + FIncrement;
  Result := True;
end;
{------------------------------------------------------------------------------}
function TRVSpinEdit.GetIndeterminate: Boolean;
begin
  Result := Trim(Text)='';
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.SetIndeterminate(const NewIndeterminate: Boolean);
begin
  if NewIndeterminate then
    Text := ''
  else if Text='' then
    Value := CheckValue(0);
end;
{------------------------------------------------------------------------------}
function TRVSpinEdit.AsInteger: Integer;
begin
  Result := Round(Value);
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.CMEnabledChanged(var Msg: TMessage);
begin
  inherited;
  FButton.Enabled := Enabled;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.CMBiDiModeChanged(var Msg: TMessage);
begin
   inherited;
   AdjustItself;
end;
{------------------------------------------------------------------------------}
procedure TRVSpinEdit.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  Message.Result := DLGC_WANTARROWS;
end;

{$IFDEF USERVKSDEVTE}
procedure TRVSpinEdit.DoPaint;
var
  MyDC: HDC;
  TempDC: HDC;
  OldBmp, TempBmp: HBITMAP;
begin
  if Parent = nil then Exit;
  if not HandleAllocated then Exit;

  FPainting := True;

  HideCaret(Handle);
  
  MyDC := GetDC(Handle);
  try
    TempDC := CreateCompatibleDC(MyDC);
    try
      TempBmp := CreateCompatibleBitmap(MyDC, Succ(ClientWidth), Succ(ClientHeight));
      try
        OldBmp := SelectObject(TempDC, TempBmp);

        PaintTo(TempDC, 0, 0);

        if BorderStyle = bsSingle then
          BitBlt(MyDC, 0, 0, ClientWidth, ClientHeight, TempDC, 2, 2, SRCCOPY)
        else
          BitBlt(MyDC, 0, 0, ClientWidth, ClientHeight, TempDC, 0, 0, SRCCOPY);

        SelectObject(TempDC, OldBmp);
      finally
        DeleteObject(TempBmp);
      end;
    finally
      DeleteDC(TempDC);
    end;
  finally
    ReleaseDC(Handle, MyDC);

    ShowCaret(Handle);
  end;

  FPainting := False;
end;

procedure TRVSpinEdit.SNMThemeMessage(var Msg: TMessage);
var
  R: TRect;
begin
  if not HandleAllocated then Exit;
  case Msg.wParam of
    SMP_REPAINT, SMP_APPLYTHEME, SMP_CHANGETHEME, SMP_REMOVETHEME:
      begin
        SendMessage(Handle, WM_NCPAINT, 0, 0);
        R := GetClientRect;
        InvalidateRect(Handle, @R, true);
      end;
  end;
end;

procedure TRVSpinEdit.WndProc(var Message: TMessage);
var
  Canvas: TCanvas;
  R: TRect;
begin
  case Message.Msg of
    CN_CTLCOLOREDIT, CN_CTLCOLORSTATIC:
      begin
        inherited ;
        SetBkMode(THandle(Message.wParam), TRANSPARENT);
      end;
    WM_NCPAINT:
      begin
        GetWindowRect(Handle, R);
        OffsetRect(R, -R.Left, -R.Top);

        if BorderStyle = bsNone then
          InflateRect(R, 2, 2);

        Canvas := TCanvas.Create;
        Canvas.Handle := GetWindowDC(Handle);

        ExcludeClipRect(Canvas.Handle, R.Left + 2, R.Top + 2, R.Left + 2 + ClientWidth, R.Top + 2 + ClientHeight);

        PaintBorder(Canvas, R);

        ReleaseDC(Handle, Canvas.Handle);
        Canvas.Handle := 0;
        Canvas.Free;
        Message.Result := 0;
      end;
    WM_ERASEBKGND:
      begin
        Canvas := TCanvas.Create;
        Canvas.Handle := THandle(Message.wParam);

        if Canvas.Handle <> 0 then
        begin
          R := Rect(0, 0, Width, Height);
          InflateRect(R, 2, 2);

          PaintBuffer(Canvas, R);
        end;

        Canvas.Handle := 0;
        Canvas.Free;

        Message.Result := 1;
        Exit;
      end;
    WM_PAINT:
      begin
        inherited ;

        Canvas := TCanvas.Create;
        Canvas.Handle := GetDC(Handle);

        if not FPainting then
          DoPaint;

        ReleaseDC(Handle, Canvas.Handle);
        Canvas.Handle := 0;
        Canvas.Free;
      end;
  else
    inherited ;
  end;
end;

procedure TRVSpinEdit.PaintBorder(Canvas: TCanvas; ARect: TRect);
var
  Theme: HTheme;
  Part, ThemeState: integer;
  DrawState: TTeEditDrawState;
begin
  if IsObjectDefined(kescEdit) then
  begin
    if not Enabled then
      DrawState := kedsDisabled
    else
      if Focused then
        DrawState := kedsFocused
      else
        DrawState := kedsNormal;

    CurrentTheme.EditDraw(kescEdit, Canvas, EditInfo(ARect, DrawState));
  end
  else
    if UseThemes and (BorderStyle = bsSingle) then
    begin
      Theme := OpenThemeData(0, 'Edit');
      Part := integer(EP_EDITText);

      if not Enabled then
        ThemeState := integer(ETS_DISABLED)
      else
        if Focused then
          ThemeState := integer(ETS_SELECTED)
        else
          ThemeState := integer(ETS_NORMAL);

      DrawThemeBackground(Theme, Canvas.Handle, Part, ThemeState, ARect, nil);

      CloseThemeData(Theme);
    end
    else
    begin
      DrawEdge(Canvas, ARect, clBtnShadow, clBtnHighlight);
      InflateRect(ARect, -1, -1);
      DrawEdge(Canvas, ARect, cl3DDkShadow, clBtnFace);
    end;
end;

procedure TRVSpinEdit.PaintBuffer(Canvas: TCanvas; ARect: TRect);
var
  Theme: HTheme;
  Part, ThemeState: integer;
  DrawState: TTeEditDrawState;
begin
  if IsObjectDefined(kescEdit) then
  begin
    if not Enabled then
      DrawState := kedsDisabled
    else
      if Focused then
        DrawState := kedsFocused
      else
        DrawState := kedsNormal;

    CurrentTheme.EditDraw(kescEdit, Canvas, EditInfo(ARect, DrawState));
  end
  else
    if not UseThemes then
    begin
      { Default drawing }
      FillRect(Canvas, ARect, Color);
    end
    else
    begin
      { XP style }
      Theme := OpenThemeData(0, 'Edit');
      Part := integer(EP_EDITText);
      if not Enabled then
        ThemeState := integer(ETS_DISABLED)
      else
        if Focused then
          ThemeState := integer(ETS_SELECTED)
        else
          ThemeState := integer(ETS_NORMAL);
      DrawThemeBackground(Theme, Canvas.Handle, Part, ThemeState, ARect, nil);
      CloseThemeData(Theme);
    end;
end;

procedure TRVSpinEdit.Change;
begin
  DoPaint;
  inherited Change;
end;

{$ENDIF}

end.
