home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d6 / RX275D6.ZIP / Units / RXSpin.pas < prev    next >
Pascal/Delphi Source File  |  1999-10-12  |  31KB  |  1,136 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 1995 AO ROSNO                   }
  6. {         Copyright (c) 1997, 1998 Master-Bank          }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit RXSpin;
  11.  
  12. interface
  13.  
  14. {$I RX.INC}
  15.  
  16. uses {$IFDEF WIN32} Windows, ComCtrls, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  17.   Controls, ExtCtrls, Classes, Graphics, Messages, Forms, StdCtrls, Menus,
  18.   SysUtils;
  19.  
  20. type
  21.  
  22. { TRxSpinButton }
  23.  
  24.   TSpinButtonState = (sbNotDown, sbTopDown, sbBottomDown);
  25.  
  26.   TRxSpinButton = class(TGraphicControl)
  27.   private
  28.     FDown: TSpinButtonState;
  29.     FUpBitmap: TBitmap;
  30.     FDownBitmap: TBitmap;
  31.     FDragging: Boolean;
  32.     FInvalidate: Boolean;
  33.     FTopDownBtn: TBitmap;
  34.     FBottomDownBtn: TBitmap;
  35.     FRepeatTimer: TTimer;
  36.     FNotDownBtn: TBitmap;
  37.     FLastDown: TSpinButtonState;
  38.     FFocusControl: TWinControl;
  39.     FOnTopClick: TNotifyEvent;
  40.     FOnBottomClick: TNotifyEvent;
  41.     procedure TopClick;
  42.     procedure BottomClick;
  43.     procedure GlyphChanged(Sender: TObject);
  44.     function GetUpGlyph: TBitmap;
  45.     function GetDownGlyph: TBitmap;
  46.     procedure SetUpGlyph(Value: TBitmap);
  47.     procedure SetDownGlyph(Value: TBitmap);
  48.     procedure SetDown(Value: TSpinButtonState);
  49.     procedure SetFocusControl(Value: TWinControl);
  50.     procedure DrawAllBitmap;
  51.     procedure DrawBitmap(ABitmap: TBitmap; ADownState: TSpinButtonState);
  52.     procedure TimerExpired(Sender: TObject);
  53.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  54.   protected
  55.     procedure Paint; override;
  56.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  57.       X, Y: Integer); override;
  58.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  59.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  60.       X, Y: Integer); override;
  61.     procedure Notification(AComponent: TComponent;
  62.       Operation: TOperation); override;
  63.   public
  64.     constructor Create(AOwner: TComponent); override;
  65.     destructor Destroy; override;
  66.     property Down: TSpinButtonState read FDown write SetDown default sbNotDown;
  67.   published
  68.     property DragCursor;
  69.     property DragMode;
  70.     property Enabled;
  71.     property Visible;
  72.     property DownGlyph: TBitmap read GetDownGlyph write SetDownGlyph;
  73.     property UpGlyph: TBitmap read GetUpGlyph write SetUpGlyph;
  74.     property FocusControl: TWinControl read FFocusControl write SetFocusControl;
  75.     property ShowHint;
  76.     property ParentShowHint;
  77. {$IFDEF RX_D4}
  78.     property Anchors;
  79.     property Constraints;
  80.     property DragKind;
  81. {$ENDIF}
  82.     property OnBottomClick: TNotifyEvent read FOnBottomClick write FOnBottomClick;
  83.     property OnTopClick: TNotifyEvent read FOnTopClick write FOnTopClick;
  84.     property OnDragDrop;
  85.     property OnDragOver;
  86.     property OnEndDrag;
  87. {$IFDEF WIN32}
  88.     property OnStartDrag;
  89. {$ENDIF}
  90. {$IFDEF RX_D4}
  91.     property OnEndDock;
  92.     property OnStartDock;
  93. {$ENDIF}
  94.   end;
  95.  
  96. { TRxSpinEdit }
  97.  
  98. {$IFDEF CBUILDER}
  99.   TValueType = (vtInt, vtFloat, vtHex);
  100. {$ELSE}
  101.   TValueType = (vtInteger, vtFloat, vtHex);
  102. {$ENDIF}
  103.  
  104. {$IFDEF WIN32}
  105.   TSpinButtonKind = (bkStandard, bkDiagonal);
  106. {$ENDIF}
  107.  
  108.   TRxSpinEdit = class(TCustomEdit)
  109.   private
  110.     FAlignment: TAlignment;
  111.     FMinValue: Extended;
  112.     FMaxValue: Extended;
  113.     FIncrement: Extended;
  114.     FDecimal: Byte;
  115.     FChanging: Boolean;
  116.     FEditorEnabled: Boolean;
  117.     FValueType: TValueType;
  118.     FButton: TRxSpinButton;
  119.     FBtnWindow: TWinControl;
  120.     FArrowKeys: Boolean;
  121.     FOnTopClick: TNotifyEvent;
  122.     FOnBottomClick: TNotifyEvent;
  123. {$IFDEF WIN32}
  124.     FButtonKind: TSpinButtonKind;
  125.     FUpDown: TCustomUpDown;
  126.     function GetButtonKind: TSpinButtonKind;
  127.     procedure SetButtonKind(Value: TSpinButtonKind);
  128.     procedure UpDownClick(Sender: TObject; Button: TUDBtnType);
  129. {$ENDIF}
  130.     function GetMinHeight: Integer;
  131.     procedure GetTextHeight(var SysHeight, Height: Integer);
  132.     function GetValue: Extended;
  133.     function CheckValue(NewValue: Extended): Extended;
  134.     function GetAsInteger: Longint;
  135.     function IsIncrementStored: Boolean;
  136.     function IsMaxStored: Boolean;
  137.     function IsMinStored: Boolean;
  138.     function IsValueStored: Boolean;
  139.     procedure SetArrowKeys(Value: Boolean);
  140.     procedure SetAsInteger(NewValue: Longint);
  141.     procedure SetValue(NewValue: Extended);
  142.     procedure SetValueType(NewType: TValueType);
  143.     procedure SetDecimal(NewValue: Byte);
  144.     function GetButtonWidth: Integer;
  145.     procedure RecreateButton;
  146.     procedure ResizeButton;
  147.     procedure SetEditRect;
  148.     procedure SetAlignment(Value: TAlignment);
  149.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  150.     procedure CMEnter(var Message: TMessage); message CM_ENTER;
  151.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  152.     procedure WMPaste(var Message: TWMPaste); message WM_PASTE;
  153.     procedure WMCut(var Message: TWMCut); message WM_CUT;
  154.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  155.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  156.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  157. {$IFDEF RX_D4}
  158.     procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
  159. {$ENDIF}
  160.   protected
  161.     procedure Change; override;
  162.     function IsValidChar(Key: Char): Boolean; virtual;
  163.     procedure UpClick(Sender: TObject); virtual;
  164.     procedure DownClick(Sender: TObject); virtual;
  165.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  166.     procedure KeyPress(var Key: Char); override;
  167.     procedure CreateParams(var Params: TCreateParams); override;
  168.     procedure CreateWnd; override;
  169.   public
  170.     constructor Create(AOwner: TComponent); override;
  171.     destructor Destroy; override;
  172.     property AsInteger: Longint read GetAsInteger write SetAsInteger default 0;
  173.     property Text;
  174.   published
  175.     property Alignment: TAlignment read FAlignment write SetAlignment
  176.       default taLeftJustify;
  177.     property ArrowKeys: Boolean read FArrowKeys write SetArrowKeys default True;
  178. {$IFDEF WIN32}
  179.     property ButtonKind: TSpinButtonKind read FButtonKind write SetButtonKind
  180.       default bkDiagonal;
  181. {$ENDIF}
  182.     property Decimal: Byte read FDecimal write SetDecimal default 2;
  183.     property EditorEnabled: Boolean read FEditorEnabled write FEditorEnabled default True;
  184.     property Increment: Extended read FIncrement write FIncrement stored IsIncrementStored;
  185.     property MaxValue: Extended read FMaxValue write FMaxValue stored IsMaxStored;
  186.     property MinValue: Extended read FMinValue write FMinValue stored IsMinStored;
  187.     property ValueType: TValueType read FValueType write SetValueType
  188.       default {$IFDEF CBUILDER} vtInt {$ELSE} vtInteger {$ENDIF};
  189.     property Value: Extended read GetValue write SetValue stored IsValueStored;
  190.     property AutoSelect;
  191.     property AutoSize;
  192.     property BorderStyle;
  193.     property Color;
  194.     property Ctl3D;
  195.     property DragCursor;
  196.     property DragMode;
  197.     property Enabled;
  198.     property Font;
  199. {$IFDEF RX_D4}
  200.     property Anchors;
  201.     property BiDiMode;
  202.     property Constraints;
  203.     property DragKind;
  204.     property ParentBiDiMode;
  205. {$ENDIF}
  206. {$IFDEF WIN32}
  207.   {$IFNDEF VER90}
  208.     property ImeMode;
  209.     property ImeName;
  210.   {$ENDIF}
  211. {$ENDIF}
  212.     property MaxLength;
  213.     property ParentColor;
  214.     property ParentCtl3D;
  215.     property ParentFont;
  216.     property ParentShowHint;
  217.     property PopupMenu;
  218.     property ReadOnly;
  219.     property ShowHint;
  220.     property TabOrder;
  221.     property TabStop;
  222.     property Visible;
  223.     property OnBottomClick: TNotifyEvent read FOnBottomClick write FOnBottomClick;
  224.     property OnTopClick: TNotifyEvent read FOnTopClick write FOnTopClick;
  225.     property OnChange;
  226.     property OnClick;
  227.     property OnDblClick;
  228.     property OnDragDrop;
  229.     property OnDragOver;
  230.     property OnEndDrag;
  231.     property OnEnter;
  232.     property OnExit;
  233.     property OnKeyDown;
  234.     property OnKeyPress;
  235.     property OnKeyUp;
  236.     property OnMouseDown;
  237.     property OnMouseMove;
  238.     property OnMouseUp;
  239. {$IFDEF WIN32}
  240.     property OnStartDrag;
  241. {$ENDIF}
  242. {$IFDEF RX_D5}
  243.     property OnContextPopup;
  244. {$ENDIF}
  245. {$IFDEF RX_D4}
  246.     property OnMouseWheelDown;
  247.     property OnMouseWheelUp;
  248.     property OnEndDock;
  249.     property OnStartDock;
  250. {$ENDIF}
  251.   end;
  252.  
  253. implementation
  254.  
  255. uses {$IFDEF WIN32} CommCtrl, {$ENDIF} VCLUtils;
  256.  
  257. {$IFDEF WIN32}
  258.  {$R *.R32}
  259. {$ELSE}
  260.  {$R *.R16}
  261. {$ENDIF}
  262.  
  263. const
  264.   sSpinUpBtn = 'RXSPINUP';
  265.   sSpinDownBtn = 'RXSPINDOWN';
  266.  
  267. const
  268.   InitRepeatPause = 400; { pause before repeat timer (ms) }
  269.   RepeatPause     = 100;
  270.  
  271. { TRxSpinButton }
  272.  
  273. constructor TRxSpinButton.Create(AOwner: TComponent);
  274. begin
  275.   inherited Create(AOwner);
  276.   FUpBitmap := TBitmap.Create;
  277.   FDownBitmap := TBitmap.Create;
  278.   FUpBitmap.Handle := LoadBitmap(HInstance, sSpinUpBtn);
  279.   FDownBitmap.Handle := LoadBitmap(HInstance, sSpinDownBtn);
  280.   FUpBitmap.OnChange := GlyphChanged;
  281.   FDownBitmap.OnChange := GlyphChanged;
  282.   Height := 20;
  283.   Width := 20;
  284.   FTopDownBtn := TBitmap.Create;
  285.   FBottomDownBtn := TBitmap.Create;
  286.   FNotDownBtn := TBitmap.Create;
  287.   DrawAllBitmap;
  288.   FLastDown := sbNotDown;
  289. end;
  290.  
  291. destructor TRxSpinButton.Destroy;
  292. begin
  293.   FTopDownBtn.Free;
  294.   FBottomDownBtn.Free;
  295.   FNotDownBtn.Free;
  296.   FUpBitmap.Free;
  297.   FDownBitmap.Free;
  298.   FRepeatTimer.Free;
  299.   inherited Destroy;
  300. end;
  301.  
  302. procedure TRxSpinButton.GlyphChanged(Sender: TObject);
  303. begin
  304.   FInvalidate := True;
  305.   Invalidate;
  306. end;
  307.  
  308. function TRxSpinButton.GetUpGlyph: TBitmap;
  309. begin
  310.   Result := FUpBitmap;
  311. end;
  312.  
  313. procedure TRxSpinButton.SetUpGlyph(Value: TBitmap);
  314. begin
  315.   if Value <> nil then FUpBitmap.Assign(Value)
  316.   else FUpBitmap.Handle := LoadBitmap(HInstance, sSpinUpBtn);
  317. end;
  318.  
  319. function TRxSpinButton.GetDownGlyph: TBitmap;
  320. begin
  321.   Result := FDownBitmap;
  322. end;
  323.  
  324. procedure TRxSpinButton.SetDownGlyph(Value: TBitmap);
  325. begin
  326.   if Value <> nil then FDownBitmap.Assign(Value)
  327.   else FDownBitmap.Handle := LoadBitmap(HInstance, sSpinDownBtn);
  328. end;
  329.  
  330. procedure TRxSpinButton.SetDown(Value: TSpinButtonState);
  331. var
  332.   OldState: TSpinButtonState;
  333. begin
  334.   OldState := FDown;
  335.   FDown := Value;
  336.   if OldState <> FDown then Repaint;
  337. end;
  338.  
  339. procedure TRxSpinButton.SetFocusControl(Value: TWinControl);
  340. begin
  341.   FFocusControl := Value;
  342. {$IFDEF WIN32}
  343.   if Value <> nil then Value.FreeNotification(Self);
  344. {$ENDIF}
  345. end;
  346.  
  347. procedure TRxSpinButton.Notification(AComponent: TComponent;
  348.   Operation: TOperation);
  349. begin
  350.   inherited Notification(AComponent, Operation);
  351.   if (Operation = opRemove) and (AComponent = FFocusControl) then
  352.     FFocusControl := nil;
  353. end;
  354.  
  355. procedure TRxSpinButton.Paint;
  356. begin
  357.   if not Enabled and not (csDesigning in ComponentState) then
  358.     FDragging := False;
  359.   if (FNotDownBtn.Height <> Height) or (FNotDownBtn.Width <> Width) or
  360.     FInvalidate then DrawAllBitmap;
  361.   FInvalidate := False;
  362.   with Canvas do
  363.     case FDown of
  364.       sbNotDown: Draw(0, 0, FNotDownBtn);
  365.       sbTopDown: Draw(0, 0, FTopDownBtn);
  366.       sbBottomDown: Draw(0, 0, FBottomDownBtn);
  367.     end;
  368. end;
  369.  
  370. procedure TRxSpinButton.DrawAllBitmap;
  371. begin
  372.   DrawBitmap(FTopDownBtn, sbTopDown);
  373.   DrawBitmap(FBottomDownBtn, sbBottomDown);
  374.   DrawBitmap(FNotDownBtn, sbNotDown);
  375. end;
  376.  
  377. procedure TRxSpinButton.DrawBitmap(ABitmap: TBitmap; ADownState: TSpinButtonState);
  378. var
  379.   R, RSrc: TRect;
  380.   dRect: Integer;
  381.   {Temp: TBitmap;}
  382. begin
  383.   ABitmap.Height := Height;
  384.   ABitmap.Width := Width;
  385.   with ABitmap.Canvas do begin
  386.     R := Bounds(0, 0, Width, Height);
  387.     Pen.Width := 1;
  388.     Brush.Color := clBtnFace;
  389.     Brush.Style := bsSolid;
  390.     FillRect(R);
  391.     { buttons frame }
  392.     Pen.Color := clWindowFrame;
  393.     Rectangle(0, 0, Width, Height);
  394.     MoveTo(-1, Height);
  395.     LineTo(Width, -1);
  396.     { top button }
  397.     if ADownState = sbTopDown then Pen.Color := clBtnShadow
  398.     else Pen.Color := clBtnHighlight;
  399.     MoveTo(1, Height - 4);
  400.     LineTo(1, 1);
  401.     LineTo(Width - 3, 1);
  402.     if ADownState = sbTopDown then Pen.Color := clBtnHighlight
  403.       else Pen.Color := clBtnShadow;
  404.     if ADownState <> sbTopDown then begin
  405.       MoveTo(1, Height - 3);
  406.       LineTo(Width - 2, 0);
  407.     end;
  408.     { bottom button }
  409.     if ADownState = sbBottomDown then Pen.Color := clBtnHighlight
  410.       else Pen.Color := clBtnShadow;
  411.     MoveTo(2, Height - 2);
  412.     LineTo(Width - 2, Height - 2);
  413.     LineTo(Width - 2, 1);
  414.     if ADownState = sbBottomDown then Pen.Color := clBtnShadow
  415.       else Pen.Color := clBtnHighlight;
  416.     MoveTo(2, Height - 2);
  417.     LineTo(Width - 1, 1);
  418.     { top glyph }
  419.     dRect := 1;
  420.     if ADownState = sbTopDown then Inc(dRect);
  421.     R := Bounds(Round((Width / 4) - (FUpBitmap.Width / 2)) + dRect,
  422.       Round((Height / 4) - (FUpBitmap.Height / 2)) + dRect, FUpBitmap.Width,
  423.       FUpBitmap.Height);
  424.     RSrc := Bounds(0, 0, FUpBitmap.Width, FUpBitmap.Height);
  425.     {
  426.     if Self.Enabled or (csDesigning in ComponentState) then
  427.       BrushCopy(R, FUpBitmap, RSrc, FUpBitmap.TransparentColor)
  428.     else begin
  429.       Temp := CreateDisabledBitmap(FUpBitmap, clBlack);
  430.       try
  431.         BrushCopy(R, Temp, RSrc, Temp.TransparentColor);
  432.       finally
  433.         Temp.Free;
  434.       end;
  435.     end;
  436.     }
  437.     BrushCopy(R, FUpBitmap, RSrc, FUpBitmap.TransparentColor);
  438.     { bottom glyph }
  439.     R := Bounds(Round((3 * Width / 4) - (FDownBitmap.Width / 2)) - 1,
  440.       Round((3 * Height / 4) - (FDownBitmap.Height / 2)) - 1,
  441.       FDownBitmap.Width, FDownBitmap.Height);
  442.     RSrc := Bounds(0, 0, FDownBitmap.Width, FDownBitmap.Height);
  443.     {
  444.     if Self.Enabled or (csDesigning in ComponentState) then
  445.       BrushCopy(R, FDownBitmap, RSrc, FDownBitmap.TransparentColor)
  446.     else begin
  447.       Temp := CreateDisabledBitmap(FDownBitmap, clBlack);
  448.       try
  449.         BrushCopy(R, Temp, RSrc, Temp.TransparentColor);
  450.       finally
  451.         Temp.Free;
  452.       end;
  453.     end;
  454.     }
  455.     BrushCopy(R, FDownBitmap, RSrc, FDownBitmap.TransparentColor);
  456.     if ADownState = sbBottomDown then begin
  457.       Pen.Color := clBtnShadow;
  458.       MoveTo(3, Height - 2);
  459.       LineTo(Width - 1, 2);
  460.     end;
  461.   end;
  462. end;
  463.  
  464. procedure TRxSpinButton.CMEnabledChanged(var Message: TMessage);
  465. begin
  466.   inherited;
  467.   FInvalidate := True;
  468.   Invalidate;
  469. end;
  470.  
  471. procedure TRxSpinButton.TopClick;
  472. begin
  473.   if Assigned(FOnTopClick) then begin
  474.     FOnTopClick(Self);
  475.     if not (csLButtonDown in ControlState) then FDown := sbNotDown;
  476.   end;
  477. end;
  478.  
  479. procedure TRxSpinButton.BottomClick;
  480. begin
  481.   if Assigned(FOnBottomClick) then begin
  482.     FOnBottomClick(Self);
  483.     if not (csLButtonDown in ControlState) then FDown := sbNotDown;
  484.   end;
  485. end;
  486.  
  487. procedure TRxSpinButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  488.   X, Y: Integer);
  489. begin
  490.   inherited MouseDown(Button, Shift, X, Y);
  491.   if (Button = mbLeft) and Enabled then begin
  492.     if (FFocusControl <> nil) and FFocusControl.TabStop and
  493.       FFocusControl.CanFocus and (GetFocus <> FFocusControl.Handle) then
  494.         FFocusControl.SetFocus;
  495.     if FDown = sbNotDown then begin
  496.       FLastDown := FDown;
  497.       if Y > (-(Height/Width) * X + Height) then begin
  498.         FDown := sbBottomDown;
  499.         BottomClick;
  500.       end
  501.       else begin
  502.         FDown := sbTopDown;
  503.         TopClick;
  504.       end;
  505.       if FLastDown <> FDown then begin
  506.         FLastDown := FDown;
  507.         Repaint;
  508.       end;
  509.       if FRepeatTimer = nil then FRepeatTimer := TTimer.Create(Self);
  510.       FRepeatTimer.OnTimer := TimerExpired;
  511.       FRepeatTimer.Interval := InitRepeatPause;
  512.       FRepeatTimer.Enabled := True;
  513.     end;
  514.     FDragging := True;
  515.   end;
  516. end;
  517.  
  518. procedure TRxSpinButton.MouseMove(Shift: TShiftState; X, Y: Integer);
  519. var
  520.   NewState: TSpinButtonState;
  521. begin
  522.   inherited MouseMove(Shift, X, Y);
  523.   if FDragging then begin
  524.     if (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then begin
  525.       NewState := FDown;
  526.       if Y > (-(Width / Height) * X + Height) then begin
  527.         if (FDown <> sbBottomDown) then begin
  528.           if FLastDown = sbBottomDown then FDown := sbBottomDown
  529.           else FDown := sbNotDown;
  530.           if NewState <> FDown then Repaint;
  531.         end;
  532.       end
  533.       else begin
  534.         if (FDown <> sbTopDown) then begin
  535.           if (FLastDown = sbTopDown) then FDown := sbTopDown
  536.           else FDown := sbNotDown;
  537.           if NewState <> FDown then Repaint;
  538.         end;
  539.       end;
  540.     end else
  541.       if FDown <> sbNotDown then begin
  542.         FDown := sbNotDown;
  543.         Repaint;
  544.       end;
  545.   end;
  546. end;
  547.  
  548. procedure TRxSpinButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  549.   X, Y: Integer);
  550. begin
  551.   inherited MouseUp(Button, Shift, X, Y);
  552.   if FDragging then begin
  553.     FDragging := False;
  554.     if (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then begin
  555.       FDown := sbNotDown;
  556.       FLastDown := sbNotDown;
  557.       Repaint;
  558.     end;
  559.   end;
  560. end;
  561.  
  562. procedure TRxSpinButton.TimerExpired(Sender: TObject);
  563. begin
  564.   FRepeatTimer.Interval := RepeatPause;
  565.   if (FDown <> sbNotDown) and MouseCapture then begin
  566.     try
  567.       if FDown = sbBottomDown then BottomClick else TopClick;
  568.     except
  569.       FRepeatTimer.Enabled := False;
  570.       raise;
  571.     end;
  572.   end;
  573. end;
  574.  
  575. function DefBtnWidth: Integer;
  576. begin
  577.   Result := GetSystemMetrics(SM_CXVSCROLL);
  578.   if Result > 15 then Result := 15;
  579. end;
  580.  
  581. {$IFDEF WIN32}
  582.  
  583. type
  584.   TRxUpDown = class(TCustomUpDown)
  585.   private
  586.     FChanging: Boolean;
  587.     procedure ScrollMessage(var Message: TWMVScroll);
  588.     procedure WMHScroll(var Message: TWMHScroll); message CN_HSCROLL;
  589.     procedure WMVScroll(var Message: TWMVScroll); message CN_VSCROLL;
  590.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  591.   public
  592.     constructor Create(AOwner: TComponent); override;
  593.     destructor Destroy; override;
  594.   published
  595.     property OnClick;
  596.   end;
  597.  
  598. constructor TRxUpDown.Create(AOwner: TComponent);
  599. begin
  600.   inherited Create(AOwner);
  601.   Orientation := udVertical;
  602.   Min := -1;
  603.   Max := 1;
  604.   Position := 0;
  605. end;
  606.  
  607. destructor TRxUpDown.Destroy;
  608. begin
  609.   OnClick := nil;
  610.   inherited Destroy;
  611. end;
  612.  
  613. procedure TRxUpDown.ScrollMessage(var Message: TWMVScroll);
  614. begin
  615.   if Message.ScrollCode = SB_THUMBPOSITION then begin
  616.     if not FChanging then begin
  617.       FChanging := True;
  618.       try
  619.         if Message.Pos > 0 then Click(btNext)
  620.         else if Message.Pos < 0 then Click(btPrev);
  621.         if HandleAllocated then
  622.           SendMessage(Handle, UDM_SETPOS, 0, 0);
  623.       finally
  624.         FChanging := False;
  625.       end;
  626.     end;
  627.   end;
  628. end;
  629.  
  630. procedure TRxUpDown.WMHScroll(var Message: TWMHScroll);
  631. begin
  632.   ScrollMessage(TWMVScroll(Message));
  633. end;
  634.  
  635. procedure TRxUpDown.WMVScroll(var Message: TWMVScroll);
  636. begin
  637.   ScrollMessage(Message);
  638. end;
  639.  
  640. procedure TRxUpDown.WMSize(var Message: TWMSize);
  641. begin
  642.   inherited;
  643.   if Width <> DefBtnWidth then Width := DefBtnWidth;
  644. end;
  645. {$ENDIF WIN32}
  646.  
  647. { TRxSpinEdit }
  648.  
  649. constructor TRxSpinEdit.Create(AOwner: TComponent);
  650. begin
  651.   inherited Create(AOwner);
  652.   Text := '0';
  653.   ControlStyle := ControlStyle - [csSetCaption];
  654.   FIncrement := 1.0;
  655.   FDecimal := 2;
  656.   FEditorEnabled := True;
  657. {$IFDEF WIN32}
  658.   FButtonKind := bkDiagonal;
  659. {$ENDIF}
  660.   FArrowKeys := True;
  661.   RecreateButton;
  662. end;
  663.  
  664. destructor TRxSpinEdit.Destroy;
  665. begin
  666.   Destroying;
  667.   FChanging := True;
  668.   if FButton <> nil then begin
  669.     FButton.Free;
  670.     FButton := nil;
  671.     FBtnWindow.Free;
  672.     FBtnWindow := nil;
  673.   end;
  674. {$IFDEF WIN32}
  675.   if FUpDown <> nil then begin
  676.     FUpDown.Free;
  677.     FUpDown := nil;
  678.   end;
  679. {$ENDIF}
  680.   inherited Destroy;
  681. end;
  682.  
  683. procedure TRxSpinEdit.RecreateButton;
  684. begin
  685.   if (csDestroying in ComponentState) then Exit;
  686.   FButton.Free;
  687.   FButton := nil;
  688.   FBtnWindow.Free;
  689.   FBtnWindow := nil;
  690. {$IFDEF WIN32}
  691.   FUpDown.Free;
  692.   FUpDown := nil;
  693.   if GetButtonKind = bkStandard then begin
  694.     FUpDown := TRxUpDown.Create(Self);
  695.     with TRxUpDown(FUpDown) do begin
  696.       Visible := True;
  697.       SetBounds(0, 0, DefBtnWidth, Self.Height);
  698. {$IFDEF RX_D4}
  699.       if (BiDiMode = bdRightToLeft) then Align := alLeft else
  700. {$ENDIF}
  701.       Align := alRight;
  702.       Parent := Self;
  703.       OnClick := UpDownClick;
  704.     end;
  705.   end
  706.   else begin
  707. {$ENDIF}
  708.     FBtnWindow := TWinControl.Create(Self);
  709.     FBtnWindow.Visible := True;
  710.     FBtnWindow.Parent := Self;
  711.     FBtnWindow.SetBounds(0, 0, Height, Height);
  712.     FButton := TRxSpinButton.Create(Self);
  713.     FButton.Visible := True;
  714.     FButton.Parent := FBtnWindow;
  715.     FButton.FocusControl := Self;
  716.     FButton.OnTopClick := UpClick;
  717.     FButton.OnBottomClick := DownClick;
  718.     FButton.SetBounds(0, 0, FBtnWindow.Width, FBtnWindow.Height);
  719. {$IFDEF WIN32}
  720.   end;
  721. {$ENDIF}
  722. end;
  723.  
  724. procedure TRxSpinEdit.SetArrowKeys(Value: Boolean);
  725. begin
  726.   FArrowKeys := Value;
  727. {$IFDEF WIN32}
  728.   ResizeButton;
  729. {$ENDIF}
  730. end;
  731.  
  732. {$IFDEF WIN32}
  733. function TRxSpinEdit.GetButtonKind: TSpinButtonKind;
  734. begin
  735.   if NewStyleControls then Result := FButtonKind
  736.   else Result := bkDiagonal;
  737. end;
  738.  
  739. procedure TRxSpinEdit.SetButtonKind(Value: TSpinButtonKind);
  740. var
  741.   OldKind: TSpinButtonKind;
  742. begin
  743.   OldKind := FButtonKind;
  744.   FButtonKind := Value;
  745.   if OldKind <> GetButtonKind then begin
  746.     RecreateButton;
  747.     ResizeButton;
  748.     SetEditRect;
  749.   end;
  750. end;
  751.  
  752. procedure TRxSpinEdit.UpDownClick(Sender: TObject; Button: TUDBtnType);
  753. begin
  754.   if TabStop and CanFocus then SetFocus;
  755.   case Button of
  756.     btNext: UpClick(Sender);
  757.     btPrev: DownClick(Sender);
  758.   end;
  759. end;
  760. {$ENDIF WIN32}
  761.  
  762. function TRxSpinEdit.GetButtonWidth: Integer;
  763. begin
  764. {$IFDEF WIN32}
  765.   if FUpDown <> nil then Result := FUpDown.Width else
  766. {$ENDIF}
  767.   if FButton <> nil then Result := FButton.Width
  768.   else Result := DefBtnWidth;
  769. end;
  770.  
  771. procedure TRxSpinEdit.ResizeButton;
  772. {$IFDEF WIN32}
  773. var
  774.   R: TRect;
  775. {$ENDIF}
  776. begin
  777. {$IFDEF WIN32}
  778.   if FUpDown <> nil then begin
  779.     FUpDown.Width := DefBtnWidth;
  780.  {$IFDEF RX_D4}
  781.     if (BiDiMode = bdRightToLeft) then FUpDown.Align := alLeft else
  782.  {$ENDIF}
  783.     FUpDown.Align := alRight;
  784.   end
  785.   else if FButton <> nil then begin { bkDiagonal }
  786.     if NewStyleControls and Ctl3D and (BorderStyle = bsSingle) then
  787.       R := Bounds(Width - Height - 1, -1, Height - 3, Height - 3)
  788.     else
  789.       R := Bounds(Width - Height, 0, Height, Height);
  790.  {$IFDEF RX_D4}
  791.     if (BiDiMode = bdRightToLeft) then begin
  792.       if NewStyleControls and Ctl3D and (BorderStyle = bsSingle) then begin
  793.         R.Left := -1;
  794.         R.Right := Height - 4;
  795.       end
  796.       else begin
  797.         R.Left := 0;
  798.         R.Right := Height;
  799.       end;
  800.     end;
  801.  {$ENDIF}
  802.     with R do
  803.       FBtnWindow.SetBounds(Left, Top, Right - Left, Bottom - Top);
  804.     FButton.SetBounds(0, 0, FBtnWindow.Width, FBtnWindow.Height);
  805.   end;
  806. {$ELSE}
  807.   if FButton <> nil then begin
  808.     FBtnWindow.SetBounds(Width - Height, 0, Height, Height);
  809.     FButton.SetBounds(0, 0, FBtnWindow.Width, FBtnWindow.Height);
  810.   end;
  811. {$ENDIF}
  812. end;
  813.  
  814. procedure TRxSpinEdit.KeyDown(var Key: Word; Shift: TShiftState);
  815. begin
  816.   inherited KeyDown(Key, Shift);
  817.   if ArrowKeys and (Key in [VK_UP, VK_DOWN]) then begin
  818.     if Key = VK_UP then UpClick(Self)
  819.     else if Key = VK_DOWN then DownClick(Self);
  820.     Key := 0;
  821.   end;
  822. end;
  823.  
  824. procedure TRxSpinEdit.Change;
  825. begin
  826.   if not FChanging then inherited Change;
  827. end;
  828.  
  829. procedure TRxSpinEdit.KeyPress(var Key: Char);
  830. begin
  831.   if not IsValidChar(Key) then begin
  832.     Key := #0;
  833.     MessageBeep(0)
  834.   end;
  835.   if Key <> #0 then begin
  836.     inherited KeyPress(Key);
  837.     if (Key = Char(VK_RETURN)) or (Key = Char(VK_ESCAPE)) then begin
  838.       { must catch and remove this, since is actually multi-line }
  839.       GetParentForm(Self).Perform(CM_DIALOGKEY, Byte(Key), 0);
  840.       if Key = Char(VK_RETURN) then Key := #0;
  841.     end;
  842.   end;
  843. end;
  844.  
  845. function TRxSpinEdit.IsValidChar(Key: Char): Boolean;
  846. var
  847.   ValidChars: set of Char;
  848. begin
  849.   ValidChars := ['+', '-', '0'..'9'];
  850.   if ValueType = vtFloat then begin
  851.     if Pos(DecimalSeparator, Text) = 0 then
  852.       ValidChars := ValidChars + [DecimalSeparator];
  853.     if Pos('E', AnsiUpperCase(Text)) = 0 then
  854.       ValidChars := ValidChars + ['e', 'E'];
  855.   end
  856.   else if ValueType = vtHex then begin
  857.     ValidChars := ValidChars + ['A'..'F', 'a'..'f'];
  858.   end;
  859.   Result := (Key in ValidChars) or (Key < #32);
  860.   if not FEditorEnabled and Result and ((Key >= #32) or
  861.     (Key = Char(VK_BACK)) or (Key = Char(VK_DELETE))) then Result := False;
  862. end;
  863.  
  864. procedure TRxSpinEdit.CreateParams(var Params: TCreateParams);
  865. const
  866. {$IFDEF RX_D4}
  867.   Alignments: array[Boolean, TAlignment] of DWORD =
  868.     ((ES_LEFT, ES_RIGHT, ES_CENTER), (ES_RIGHT, ES_LEFT, ES_CENTER));
  869. {$ELSE}
  870.   Alignments: array[TAlignment] of Longint = (ES_LEFT, ES_RIGHT, ES_CENTER);
  871. {$ENDIF}
  872. begin
  873.   inherited CreateParams(Params);
  874.   Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN or
  875. {$IFDEF RX_D4}
  876.     Alignments[UseRightToLeftAlignment, FAlignment];
  877. {$ELSE}
  878.     Alignments[FAlignment];
  879. {$ENDIF}
  880. end;
  881.  
  882. procedure TRxSpinEdit.CreateWnd;
  883. begin
  884.   inherited CreateWnd;
  885.   SetEditRect;
  886. end;
  887.  
  888. procedure TRxSpinEdit.SetEditRect;
  889. var
  890.   Loc: TRect;
  891. begin
  892. {$IFDEF RX_D4}
  893.   if (BiDiMode = bdRightToLeft) then
  894.     SetRect(Loc, GetButtonWidth + 1, 0, ClientWidth - 1,
  895.       ClientHeight + 1) else
  896. {$ENDIF RX_D4}
  897.   SetRect(Loc, 0, 0, ClientWidth - GetButtonWidth - 2, ClientHeight + 1);
  898.   SendMessage(Handle, EM_SETRECTNP, 0, Longint(@Loc));
  899. end;
  900.  
  901. procedure TRxSpinEdit.SetAlignment(Value: TAlignment);
  902. begin
  903.   if FAlignment <> Value then begin
  904.     FAlignment := Value;
  905.     RecreateWnd;
  906.   end;
  907. end;
  908.  
  909. procedure TRxSpinEdit.WMSize(var Message: TWMSize);
  910. var
  911.   MinHeight: Integer;
  912. begin
  913.   inherited;
  914.   MinHeight := GetMinHeight;
  915.   { text edit bug: if size to less than minheight, then edit ctrl does
  916.     not display the text }
  917.   if Height < MinHeight then
  918.     Height := MinHeight
  919.   else begin
  920.     ResizeButton;
  921.     SetEditRect;
  922.   end;
  923. end;
  924.  
  925. procedure TRxSpinEdit.GetTextHeight(var SysHeight, Height: Integer);
  926. var
  927.   DC: HDC;
  928.   SaveFont: HFont;
  929.   SysMetrics, Metrics: TTextMetric;
  930. begin
  931.   DC := GetDC(0);
  932.   GetTextMetrics(DC, SysMetrics);
  933.   SaveFont := SelectObject(DC, Font.Handle);
  934.   GetTextMetrics(DC, Metrics);
  935.   SelectObject(DC, SaveFont);
  936.   ReleaseDC(0, DC);
  937.   SysHeight := SysMetrics.tmHeight;
  938.   Height := Metrics.tmHeight;
  939. end;
  940.  
  941. function TRxSpinEdit.GetMinHeight: Integer;
  942. var
  943.   I, H: Integer;
  944. begin
  945.   GetTextHeight(I, H);
  946.   if I > H then I := H;
  947.   Result := H + {$IFNDEF WIN32} (I div 4) + {$ENDIF}
  948.     (GetSystemMetrics(SM_CYBORDER) * 4) + 1;
  949. end;
  950.  
  951. procedure TRxSpinEdit.UpClick(Sender: TObject);
  952. var
  953.   OldText: string;
  954. begin
  955.   if ReadOnly then MessageBeep(0)
  956.   else begin
  957.     FChanging := True;
  958.     try
  959.       OldText := inherited Text;
  960.       Value := Value + FIncrement;
  961.     finally
  962.       FChanging := False;
  963.     end;
  964.     if CompareText(inherited Text, OldText) <> 0 then begin
  965.       Modified := True;
  966.       Change;
  967.     end;
  968.     if Assigned(FOnTopClick) then FOnTopClick(Self);
  969.   end;
  970. end;
  971.  
  972. procedure TRxSpinEdit.DownClick(Sender: TObject);
  973. var
  974.   OldText: string;
  975. begin
  976.   if ReadOnly then MessageBeep(0)
  977.   else begin
  978.     FChanging := True;
  979.     try
  980.       OldText := inherited Text;
  981.       Value := Value - FIncrement;
  982.     finally
  983.       FChanging := False;
  984.     end;
  985.     if CompareText(inherited Text, OldText) <> 0 then begin
  986.       Modified := True;
  987.       Change;
  988.     end;
  989.     if Assigned(FOnBottomClick) then FOnBottomClick(Self);
  990.   end;
  991. end;
  992.  
  993. {$IFDEF RX_D4}
  994. procedure TRxSpinEdit.CMBiDiModeChanged(var Message: TMessage);
  995. begin
  996.   inherited;
  997.   ResizeButton;
  998.   SetEditRect;
  999. end;
  1000. {$ENDIF}
  1001.  
  1002. procedure TRxSpinEdit.CMFontChanged(var Message: TMessage);
  1003. begin
  1004.   inherited;
  1005.   ResizeButton;
  1006.   SetEditRect;
  1007. end;
  1008.  
  1009. procedure TRxSpinEdit.CMCtl3DChanged(var Message: TMessage);
  1010. begin
  1011.   inherited;
  1012.   ResizeButton;
  1013.   SetEditRect;
  1014. end;
  1015.  
  1016. procedure TRxSpinEdit.CMEnabledChanged(var Message: TMessage);
  1017. begin
  1018.   inherited;
  1019. {$IFDEF WIN32}
  1020.   if FUpDown <> nil then begin
  1021.     FUpDown.Enabled := Enabled;
  1022.     ResizeButton;
  1023.   end;
  1024. {$ENDIF}
  1025.   if FButton <> nil then FButton.Enabled := Enabled;
  1026. end;
  1027.  
  1028. procedure TRxSpinEdit.WMPaste(var Message: TWMPaste);
  1029. begin
  1030.   if not FEditorEnabled or ReadOnly then Exit;
  1031.   inherited;
  1032. end;
  1033.  
  1034. procedure TRxSpinEdit.WMCut(var Message: TWMCut);
  1035. begin
  1036.   if not FEditorEnabled or ReadOnly then Exit;
  1037.   inherited;
  1038. end;
  1039.  
  1040. procedure TRxSpinEdit.CMExit(var Message: TCMExit);
  1041. begin
  1042.   inherited;
  1043.   if CheckValue(Value) <> Value then SetValue(Value);
  1044. end;
  1045.  
  1046. procedure TRxSpinEdit.CMEnter(var Message: TMessage);
  1047. begin
  1048.   if AutoSelect and not (csLButtonDown in ControlState) then SelectAll;
  1049.   inherited;
  1050. end;
  1051.  
  1052. function TRxSpinEdit.GetValue: Extended;
  1053. begin
  1054.   try
  1055.     if ValueType = vtFloat then Result := StrToFloat(Text)
  1056.     else if ValueType = vtHex then Result := StrToInt('$' + Text)
  1057.     else Result := StrToInt(Text);
  1058.   except
  1059.     if ValueType = vtFloat then Result := FMinValue
  1060.     else Result := Trunc(FMinValue);
  1061.   end;
  1062. end;
  1063.  
  1064. procedure TRxSpinEdit.SetValue(NewValue: Extended);
  1065. begin
  1066.   if ValueType = vtFloat then
  1067.     Text := FloatToStrF(CheckValue(NewValue), ffFixed, 15, FDecimal)
  1068.   else if ValueType = vtHex then
  1069.     Text := IntToHex(Round(CheckValue(NewValue)), 1)
  1070.   else
  1071.     Text := IntToStr(Round(CheckValue(NewValue)));
  1072. end;
  1073.  
  1074. function TRxSpinEdit.GetAsInteger: Longint;
  1075. begin
  1076.   Result := Trunc(GetValue);
  1077. end;
  1078.  
  1079. procedure TRxSpinEdit.SetAsInteger(NewValue: Longint);
  1080. begin
  1081.   SetValue(NewValue);
  1082. end;
  1083.  
  1084. procedure TRxSpinEdit.SetValueType(NewType: TValueType);
  1085. begin
  1086.   if FValueType <> NewType then begin
  1087.     FValueType := NewType;
  1088.     Value := GetValue;
  1089.     if FValueType in [{$IFDEF CBUILDER} vtInt {$ELSE} vtInteger {$ENDIF}, vtHex] then
  1090.     begin
  1091.       FIncrement := Round(FIncrement);
  1092.       if FIncrement = 0 then FIncrement := 1;
  1093.     end;
  1094.   end;
  1095. end;
  1096.  
  1097. function TRxSpinEdit.IsIncrementStored: Boolean;
  1098. begin
  1099.   Result := FIncrement <> 1.0;
  1100. end;
  1101.  
  1102. function TRxSpinEdit.IsMaxStored: Boolean;
  1103. begin
  1104.   Result := (MaxValue <> 0.0);
  1105. end;
  1106.  
  1107. function TRxSpinEdit.IsMinStored: Boolean;
  1108. begin
  1109.   Result := (MinValue <> 0.0);
  1110. end;
  1111.  
  1112. function TRxSpinEdit.IsValueStored: Boolean;
  1113. begin
  1114.   Result := (GetValue <> 0.0);
  1115. end;
  1116.  
  1117. procedure TRxSpinEdit.SetDecimal(NewValue: Byte);
  1118. begin
  1119.   if FDecimal <> NewValue then begin
  1120.     FDecimal := NewValue;
  1121.     Value := GetValue;
  1122.   end;
  1123. end;
  1124.  
  1125. function TRxSpinEdit.CheckValue(NewValue: Extended): Extended;
  1126. begin
  1127.   Result := NewValue;
  1128.   if (FMaxValue <> FMinValue) then begin
  1129.     if NewValue < FMinValue then
  1130.       Result := FMinValue
  1131.     else if NewValue > FMaxValue then
  1132.       Result := FMaxValue;
  1133.   end;
  1134. end;
  1135.  
  1136. end.