开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Delphi控件源码 > 查看源码
MMWheel.pas
资源名称：qqdelphiprog.rar　[点击查看]
上传用户：hylc_2004
上传日期：2014-01-23
资源大小：46800k
文件大小：30k
源码类别：

Delphi控件源码

开发平台：

Delphi

MMWheel.pas：源码内容
  1. {========================================================================}
  2. {=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
  3. {========================================================================}
  4. {=                          All Rights Reserved                         =}
  5. {========================================================================}
  6. {=  D 01099 Dresden             = Tel.: +0351-8012255                   =}
  7. {=  Loewenstr.7a                = info@swiftsoft.de                     =}
  8. {========================================================================}
  9. {=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
  10. {========================================================================}
  11. {=  This code is for reference purposes only and may not be copied or   =}
  12. {=  distributed in any format electronic or otherwise except one copy   =}
  13. {=  for backup purposes.                                                =}
  14. {=                                                                      =}
  15. {=  No Delphi Component Kit or Component individually or in a collection=}
  16. {=  subclassed or otherwise from the code in this unit, or associated   =}
  17. {=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
  18. {=  without express permission from SwiftSoft.                          =}
  19. {=                                                                      =}
  20. {=  For more licence informations please refer to the associated        =}
  21. {=  HelpFile.                                                           =}
  22. {========================================================================}
  23. {=  $Date: 15.02.98 - 15:32:05 $                                        =}
  24. {========================================================================}
  25. unit MMWheel;
  27. {$I COMPILER.INC}
  29. interface
  31. uses
  32. {$IFDEF WIN32}
  33.     Windows,
  34. {$ELSE}
  35.     WinTypes,
  36.     WinProcs,
  37. {$ENDIF}
  38.     Messages,
  39.     Classes,
  40.     SysUtils,
  41.     Controls,
  42.     ExtCtrls,
  43.     Graphics,
  44.     Menus,
  45.     MMObj,
  46.     MMScale;
  48. type
  49.     EMMWheelError      = class(Exception);
  50.     TMMFocusAction     = (faHandleColor,faFrameRect,faAll);
  51.     TMMHandleStyle     = (hsEllipse,hsOwnerDraw);
  52.     TMMDrawHandleEvent = procedure(Sender : TObject; Canvas : TCanvas; Rect : TRect;
  53.                                    Origin : TPoint; Focused : Boolean) of object;
  54.     TMMPaintEvent      = procedure(Sender : TObject; Canvas: TCanvas; Rect : TRect) of object;
  55. const
  56.     {$IFDEF CBUILDER3} {$EXTERNALSYM defMinValue} {$ENDIF}
  57.     defMinValue     = 0;
  58.     {$IFDEF CBUILDER3} {$EXTERNALSYM defMaxValue} {$ENDIF}
  59.     defMaxValue     = 10;
  60.     {$IFDEF CBUILDER3} {$EXTERNALSYM defValue} {$ENDIF}
  61.     defValue        = 0;
  62.     {$IFDEF CBUILDER3} {$EXTERNALSYM defStartAngle} {$ENDIF}
  63.     defStartAngle   = 225;
  64.     {$IFDEF CBUILDER3} {$EXTERNALSYM defEndAngle} {$ENDIF}
  65.     defEndAngle     = 315;
  66.     {$IFDEF CBUILDER3} {$EXTERNALSYM defWidth} {$ENDIF}
  67.     defWidth        = 100;
  68.     {$IFDEF CBUILDER3} {$EXTERNALSYM defHeight} {$ENDIF}
  69.     defHeight       = 100;
  70.     {$IFDEF CBUILDER3} {$EXTERNALSYM defAutoSize} {$ENDIF}
  71.     defAutoSize     = True;
  72.     {$IFDEF CBUILDER3} {$EXTERNALSYM defHandleColor} {$ENDIF}
  73.     defHandleColor  = clMaroon;
  74.     {$IFDEF CBUILDER3} {$EXTERNALSYM defFocusedColor} {$ENDIF}
  75.     defFocusedColor = clRed;
  76.     {$IFDEF CBUILDER3} {$EXTERNALSYM defUpDown} {$ENDIF}
  77.     defUpDown       = False;
  78.     {$IFDEF CBUILDER3} {$EXTERNALSYM defScrollSize} {$ENDIF}
  79.     defScrollSize   = 160;
  80.     {$IFDEF CBUILDER3} {$EXTERNALSYM defLineStep} {$ENDIF}
  81.     defLineStep     = 1;
  82.     {$IFDEF CBUILDER3} {$EXTERNALSYM defPageStep} {$ENDIF}
  83.     defPageStep     = 2;
  84.     {$IFDEF CBUILDER3} {$EXTERNALSYM defFocusAction} {$ENDIF}
  85.     defFocusAction  = faAll;
  86.     {$IFDEF CBUILDER3} {$EXTERNALSYM defHandleStyle} {$ENDIF}
  87.     defHandleStyle  = hsEllipse;
  88.     {$IFDEF CBUILDER3} {$EXTERNALSYM defRadius} {$ENDIF}
  89.     defRadius       = 0;
  90.     {$IFDEF CBUILDER3} {$EXTERNALSYM defHandleSize} {$ENDIF}
  91.     defHandleSize   = 4;
  92.     {$IFDEF CBUILDER3} {$EXTERNALSYM defHandleMargin} {$ENDIF}
  93.     defHandleMargin = 4;
  94.     {$IFDEF CBUILDER3} {$EXTERNALSYM defFrameSpace} {$ENDIF}
  95.     defFrameSpace   = 4;
  96.     {$IFDEF CBUILDER3} {$EXTERNALSYM defScaleMargin} {$ENDIF}
  97.     defScaleMargin  = 3;
  98.     {$IFDEF CBUILDER3} {$EXTERNALSYM defTransparent} {$ENDIF}
  99.     defTransparent  = True;
  101. type
  102.     {-- TMMCustomWheel ---------------------------------------------------}
  103.     TMMCustomWheel = class(TMMCustomControl)
  104.     private
  105.         FAutoSize       : Boolean;
  106.         FBackBmp        : TBitmap;
  107.         FStretched      : TBitmap;
  108.         FMinValue       : Integer;
  109.         FMaxValue       : Integer;
  110.         FValue          : Integer;
  111.         FStartAngle     : Integer;
  112.         FEndAngle       : Integer;
  113.         FHandleColor    : TColor;
  114.         FFocusedColor   : TColor;
  115.         FUpDown         : Boolean;
  116.         FScrollSize     : Integer;
  117.         FLineStep       : Integer;
  118.         FPageStep       : Integer;
  119.         FFocusAction    : TMMFocusAction;
  120.         FScale          : TMMScale;
  121.         FRadius         : Integer;
  122.         FHandleStyle    : TMMHandleStyle;
  123.         FHandleSize     : Integer;
  124.         FFrameSpace     : Integer;
  125.         FScaleMargin    : Integer;
  126.         FHandleMargin   : Integer;
  127.         FTransparent    : Boolean;
  128.         FOnChange       : TNotifyEvent;
  129.         FOnDrawHandle   : TMMDrawHandleEvent;
  130.         FOnPaint        : TMMPaintEvent;
  132.         FAngle          : Integer;
  133.         FDragging       : Boolean;
  134.         FStartY         : Integer;
  135.         FStartValue     : Integer;
  137.         procedure SetAutoSize(Value: Boolean);
  138.         procedure SetBackBmp(Value: TBitmap);
  139.         procedure SetMinValue(Value: Integer);
  140.         procedure SetMaxValue(Value: Integer);
  141.         procedure SetValue(aValue: Integer);
  142.         procedure SetStartAngle(Value: Integer);
  143.         procedure SetEndAngle(Value: Integer);
  144.         procedure SetHandleColor(Value: TColor);
  145.         procedure SetFocusedColor(Value: TColor);
  146.         procedure SetFocusAction(Value: TMMFocusAction);
  147.         procedure SetScrollParam(Index: Integer; Value : Integer);
  148.         procedure SetScale(Value: TMMScale);
  149.         procedure SetRadius(Value: Integer);
  150.         function  GetRadius: Integer;
  151.         procedure SetHandleStyle(Value: TMMHandleStyle);
  152.         procedure SetHandleSize(Value: Integer);
  153.         procedure SetHandleMargin(Value: Integer);
  154.         procedure SetFrameSpace(Value: Integer);
  155.         procedure SetScaleMargin(Value: Integer);
  156.         procedure SetTransparent(Value: Boolean);
  157.         function  GetStretched: TBitmap;
  159.         procedure InitStretched;
  160.         procedure DoneStretched;
  162.         procedure CMColorChanged(var Msg); message CM_COLORCHANGED;
  163.         procedure WMSetFocus(var Msg); message WM_SETFOCUS;
  164.         procedure WMKillFocus(var Msg); message WM_KILLFOCUS;
  166.         procedure ScaleChanged(Sender : TObject);
  167.     protected
  168.         procedure UpdateControl;
  169.         procedure Change; virtual;
  170.         procedure DoChange; dynamic;
  171.         procedure Paint; override;
  172.         procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  173.         procedure RecalcAngle;
  174.         procedure DrawHandle(Angle : Integer); virtual;
  175.         procedure DoDrawHandle(Rect : TRect; Origin : TPoint; Focused : Boolean); dynamic;
  176.         procedure Loaded; override;
  177.         procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  178.         procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  179.         procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  180.         procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  181.         procedure Rotate(X,Y : Integer);
  182.         procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
  183.         procedure DoAutoSize;
  184.         function  ScaleSpace: Integer;
  185.         procedure Changed; override;
  186.         procedure CalcSize(var W, H : Integer);
  187.         property  Stretched: TBitmap read GetStretched;
  189.     public
  190.         constructor Create(AOwner : TComponent); override;
  191.         destructor  Destroy; override;
  193.     protected
  194.         property TabStop default True;
  195.         property AutoSize    : Boolean read FAutoSize write SetAutoSize;
  196.         property BackBmp     : TBitmap read FBackBmp write SetBackBmp;
  197.         property MinValue    : Integer read FMinValue write SetMinValue default defMinValue;
  198.         property MaxValue    : Integer read FMaxValue write SetMaxValue default defMaxValue;
  199.         property Value       : Integer read FValue write SetValue default defValue;
  200.         property StartAngle  : Integer read FStartAngle write SetStartAngle default defStartAngle;
  201.         property EndAngle    : Integer read FEndAngle write SetEndAngle default defEndAngle;
  202.         property HandleColor : TColor  read FHandleColor write SetHandleColor default defHandleColor;
  203.         property FocusedColor: TColor  read FFocusedColor write SetFocusedColor default defFocusedColor;
  204.         property UpDown      : Boolean read FUpDown write FUpDown default defUpDown;
  205.         property ScrollSize  : Integer index 0 read FScrollSize write SetScrollParam default defScrollSize;
  206.         property LineStep    : Integer index 1 read FLineStep write SetScrollParam default defLineStep;
  207.         property PageStep    : Integer index 2 read FPageStep write SetScrollParam default defPageStep;
  208.         property FocusAction : TMMFocusAction read FFocusAction write SetFocusAction default defFocusAction;
  209.         property Scale       : TMMScale read FScale write SetScale;
  210.         property Radius      : Integer read GetRadius write SetRadius default defRadius;
  211.         property HandleStyle : TMMHandleStyle read FHandleStyle write SetHandleStyle default defHandleStyle;
  212.         property HandleSize  : Integer read FHandleSize write SetHandleSize default defHandleSize;
  213.         property HandleMargin: Integer read FHandleMargin write SetHandleMargin default defHandleMargin;
  214.         property FrameSpace  : Integer read FFrameSpace write SetFrameSpace default defFrameSpace;
  215.         property ScaleMargin : Integer read FScaleMargin write SetScaleMargin default defScaleMargin;
  216.         property Transparent : Boolean read FTransparent write SetTransparent default defTransparent;
  217.         property OnChange    : TNotifyEvent read FOnChange write FOnChange;
  218.         property OnDrawHandle: TMMDrawHandleEvent read FOnDrawHandle write FOnDrawHandle;
  219.         property OnPaint     : TMMPaintEvent read FOnPaint write FOnPaint;
  220.     end;
  222.     {-- TMMWheel ---------------------------------------------------------}
  223.     TMMWheel = class(TMMCustomWheel)
  224.     published
  225.         property OnEnter;
  226.         property OnExit;
  227.         property OnKeyDown;
  228.         property OnKeyPress;
  229.         property OnKeyUp;
  230.         property OnChange;
  231.         property OnDrawHandle;
  232.         property OnPaint;
  234.         property Bevel;
  235.         property Visible;
  236.         property Color;
  237.         property Enabled;
  238.         property ParentShowHint;
  239.         property PopupMenu;
  240.         property ShowHint;
  241.         property TabStop;
  242.         property TabOrder;
  243.         property Width;
  244.         property Height;
  246.         property AutoSize;
  247.         property BackBmp;
  248.         property MinValue;
  249.         property MaxValue;
  250.         property Value;
  251.         property StartAngle;
  252.         property EndAngle;
  253.         property HandleColor;
  254.         property FocusedColor;
  255.         property UpDown;
  256.         property ScrollSize;
  257.         property LineStep;
  258.         property PageStep;
  259.         property FocusAction;
  260.         property Scale;
  261.         property Radius;
  262.         property HandleStyle;
  263.         property HandleSize;
  264.         property HandleMargin;
  265.         property FrameSpace;
  266.         property ScaleMargin;
  267.         property Transparent;
  268.      end;
  270. {=========================================================================}
  271. implementation
  273. {$IFDEF WIN32}
  274.   {$R MMWHEEL.D32}
  275. {$ELSE}
  276.   {$R MMWHEEL.D16}
  277. {$ENDIF}
  279. uses
  280.     MMMath,
  281.     MMUtils;
  283. {== TMMCustomWheel ======================================================}
  284. constructor TMMCustomWheel.Create(AOwner : TComponent);
  285. begin
  286.    inherited Create(AOwner);
  288.    ControlStyle := ControlStyle -
  289.                    [csAcceptsControls,csFramed,csSetCaption] +
  290.                    [csCaptureMouse,csOpaque];
  292.    Width           := defWidth;
  293.    Height          := defHeight;
  295.    FScale          := TMMScale.Create;
  296.    FScale.OnChange := ScaleChanged;
  298.    FBackBmp        := TBitmap.Create;
  299.    FBackBmp.Width  := defWidth;
  300.    FBackBmp.Height := defHeight;
  301.    BackBmp := nil;   { set default bitmap }
  303.    FAutoSize       := defAutoSize;
  304.    FMinValue       := defMinValue;
  305.    FMaxValue       := defMaxValue;
  306.    FValue          := defValue;
  307.    FStartAngle     := defStartAngle;
  308.    FEndAngle       := defEndAngle;
  309.    FHandleColor    := defHandleColor;
  310.    FUpDown         := defUpDown;
  311.    FScrollSize     := defScrollSize;
  312.    FLineStep       := defLineStep;
  313.    FPageStep       := defPageStep;
  314.    FFocusAction    := defFocusAction;
  315.    FFocusedColor   := defFocusedColor;
  316.    FHandleStyle    := defHandleStyle;
  317.    FHandleSize     := defHandleSize;
  318.    FHandleMargin   := defHandleMargin;
  319.    FFrameSpace     := defFrameSpace;
  320.    FScaleMargin    := defScaleMargin;
  321.    FTransparent    := defTransparent;
  323.    Bevel.BevelOuter:= bvNone;
  324.    TabStop         := True;
  326.    RecalcAngle;
  328.    ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
  329.    if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
  330. end;
  332. {-- TMMCustomWheel ------------------------------------------------------}
  333. destructor TMMCustomWheel.Destroy;
  334. begin
  335.    DoneStretched;
  336.    FBackBmp.Free;
  337.    FScale.Free;
  339.    inherited Destroy;
  340. end;
  342. {-- TMMCustomWheel ------------------------------------------------------}
  343. procedure TMMCustomWheel.SetAutoSize(Value : Boolean);
  344. begin
  345.    if FAutoSize <> Value then
  346.    begin
  347.       FAutoSize := Value;
  348.       if FAutoSize then
  349.          DoAutoSize;
  350.    end;
  351. end;
  353. {-- TMMCustomWheel ------------------------------------------------------}
  354. procedure TMMCustomWheel.SetBackBmp(Value : TBitmap);
  355. begin
  356.    if (Value <> nil) then
  357.        FBackBmp.Assign(Value)
  358.    else
  359.        FBackBmp.Handle := LoadBitmap(HInstance, 'BM_WHEEL');
  361.    DoneStretched;
  362.    if FAutoSize then
  363.       DoAutoSize;
  365.    Repaint;
  366. end;
  368. {-- TMMCustomWheel ------------------------------------------------------}
  369. procedure TMMCustomWheel.SetMinValue(Value : Integer);
  370. begin
  371.    if Value <> FMinValue then
  372.    begin
  373.       FMinValue := Value;
  374.       UpdateControl;
  375.    end;
  376. end;
  378. {-- TMMCustomWheel ------------------------------------------------------}
  379. procedure TMMCustomWheel.SetMaxValue(Value : Integer);
  380. begin
  381.    if Value <> FMaxValue then
  382.    begin
  383.       FMaxValue := Value;
  384.       UpdateControl;
  385.    end;
  386. end;
  388. {-- TMMCustomWheel ------------------------------------------------------}
  389. procedure TMMCustomWheel.SetValue(aValue : Integer);
  390. begin
  391.    aValue := MinMax(aValue, FMinValue, FMaxValue);
  392.    if FValue <> aValue then
  393.    begin
  394.       FValue := aValue;
  395.       UpdateControl;
  396.       Change;
  397.    end;
  398. end;
  400. {-- TMMCustomWheel ------------------------------------------------------}
  401. procedure TMMCustomWheel.SetStartAngle(Value : Integer);
  402. begin
  403.    Value := MinMax(Value, 0, 360);
  404.    if Value <> FStartAngle then
  405.    begin
  406.       FStartAngle := Value;
  407.       UpdateControl;
  408.    end;
  409. end;
  411. {-- TMMCustomWheel ------------------------------------------------------}
  412. procedure TMMCustomWheel.SetEndAngle(Value : Integer);
  413. begin
  414.    Value := MinMax(Value, 0, 360);
  415.    if Value <> FEndAngle then
  416.    begin
  417.       FEndAngle := Value;
  418.       UpdateControl;
  419.    end;
  420. end;
  422. {-- TMMCustomWheel ------------------------------------------------------}
  423. procedure TMMCustomWheel.SetHandleColor(Value : TColor);
  424. begin
  425.    if Value <> FHandleColor then
  426.    begin
  427.       FHandleColor := Value;
  428.       UpdateControl;
  429.    end;
  430. end;
  432. {-- TMMCustomWheel ------------------------------------------------------}
  433. procedure TMMCustomWheel.SetTransparent(Value : Boolean);
  434. begin
  435.    if Value <> FTransparent then
  436.    begin
  437.       FTransparent := Value;
  438.       Invalidate;
  439.    end;
  440. end;
  442. {-- TMMCustomWheel ------------------------------------------------------}
  443. procedure TMMCustomWheel.SetScrollParam(Index : Integer; Value : Integer);
  444. begin
  445.    if Value <= 0 then
  446.       { TODO: Should be resource id }
  447.       raise EMMWheelError.Create('This parameter should be greater then 0');
  449.    case Index of
  450.       0 : FScrollSize := Value;
  451.       1 : FLineStep := Value;
  452.       2 : FPageStep := Value;
  453.    end;
  454. end;
  456. {-- TMMCustomWheel ------------------------------------------------------}
  457. procedure TMMCustomWheel.SetFocusedColor(Value : TColor);
  458. begin
  459.    if Value <> FFocusedColor then
  460.    begin
  461.       FFocusedColor := Value;
  462.       UpdateControl;
  463.    end;
  464. end;
  466. {-- TMMCustomWheel ------------------------------------------------------}
  467. procedure TMMCustomWheel.SetFocusAction(Value : TMMFocusAction);
  468. begin
  469.    if Value <> FFocusAction then
  470.    begin
  471.       FFocusAction := Value;
  472.       UpdateControl;
  473.    end;
  474. end;
  476. {-- TMMCustomWheel ------------------------------------------------------}
  477. procedure TMMCustomWheel.SetScale(Value: TMMScale);
  478. begin
  479.    FScale.Assign(Value);
  480. end;
  482. {-- TMMCustomWheel ------------------------------------------------------}
  483. procedure TMMCustomWheel.SetRadius(Value : Integer);
  484. begin
  485.    Value := MinMax(Value,0,MaxInt);
  486.    if Value <> FRadius then
  487.    begin
  488.       FRadius := Value;
  489.       UpdateControl;
  490.    end;
  491. end;
  493. {-- TMMCustomWheel ------------------------------------------------------}
  494. function TMMCustomWheel.GetRadius : Integer;
  495. begin
  496.    if FRadius = 0 then
  497.       Result := Min(Width,Height) div 2 - HandleMargin - BevelExtend - FrameSpace - ScaleSpace
  498.    else
  499.       Result := FRadius;
  500. end;
  502. {-- TMMCustomWheel ------------------------------------------------------}
  503. procedure TMMCustomWheel.SetHandleStyle(Value : TMMHandleStyle);
  504. begin
  505.    if FHandleStyle <> Value then
  506.    begin
  507.       FHandleStyle := Value;
  508.       UpdateControl;
  509.    end;
  510. end;
  512. {-- TMMCustomWheel ------------------------------------------------------}
  513. procedure TMMCustomWheel.SetHandleSize(Value : Integer);
  514. begin
  515.    Value := MinMax(Value, 2, MaxInt);
  516.    if FHandleSize <> Value then
  517.    begin
  518.       FHandleSize := Value;
  519.       UpdateControl;
  520.    end;
  521. end;
  523. {-- TMMCustomWheel ------------------------------------------------------}
  524. procedure TMMCustomWheel.SetHandleMargin(Value : Integer);
  525. begin
  526.    Value := MinMax(Value, 0, MaxInt);
  527.    if FHandleMargin <> Value then
  528.    begin
  529.       FHandleMargin := Value;
  530.       UpdateControl;
  531.    end;
  532. end;
  534. {-- TMMCustomWheel ------------------------------------------------------}
  535. procedure TMMCustomWheel.SetFrameSpace(Value : Integer);
  536. begin
  537.    Value := MinMax(Value,0,MaxInt);
  538.    if FFrameSpace <> Value then
  539.    begin
  540.       FFrameSpace := Value;
  541.       DoneStretched;
  542.       if AutoSize then
  543.          DoAutoSize;
  544.    end;
  545. end;
  547. {-- TMMCustomWheel ------------------------------------------------------}
  548. procedure TMMCustomWheel.SetScaleMargin(Value : Integer);
  549. begin
  550.    Value := MinMax(Value,0,MaxInt);
  551.    if FScaleMargin <> Value then
  552.    begin
  553.       FScaleMargin := Value;
  554.       DoneStretched;
  555.       if AutoSize then
  556.          DoAutoSize;
  557.    end;
  558. end;
  560. {-- TMMCustomWheel ------------------------------------------------------}
  561. procedure TMMCustomWheel.ScaleChanged(Sender : TObject);
  562. begin
  563.    DoneStretched;
  564.    if AutoSize then
  565.       DoAutoSize;
  566.    UpdateControl;
  567. end;
  569. {-- TMMCustomWheel ------------------------------------------------------}
  570. procedure TMMCustomWheel.InitStretched;
  571. var
  572.    Temp   : TBitmap;
  573.    SWidth : Integer;
  574.    SHeight: Integer;
  575.    BWidth : Integer;
  576.    BHeight: Integer;
  577.    R      : TRect;
  578.    SRect  : TRect;
  579. begin
  580.    SWidth  := Width - BevelExtend * 2;
  581.    SHeight := Height - BevelExtend * 2;
  583.    if SWidth < 0 then
  584.       SWidth := 0;
  586.    if SHeight < 0 then
  587.       SHeight := 0;
  589.    FStretched        := TBitmap.Create;
  590.    FStretched.Width  := SWidth;
  591.    FStretched.Height := SHeight;
  593.    if (SWidth = 0) or (SHeight = 0) then Exit;
  595.    SRect := Bounds(0,0,SWidth,SHeight);
  597.    FStretched.Canvas.Font:= Font;
  598.    FScale.Canvas         := FStretched.Canvas;
  600.    Temp := TBitmap.Create;
  601.    try
  602.       FStretched.Canvas.Brush.Color := Color;
  603.       FStretched.Canvas.FillRect(SRect);
  604.       R := SRect;
  605.       InflateRect(R,-(FrameSpace+ScaleSpace),-(FrameSpace+ScaleSpace));
  606.       BWidth  := R.Right - R.Left;
  607.       BHeight := R.Bottom - R.Top;
  609.       if (BWidth > 0) and (BHeight > 0) then
  610.       begin
  611.          Temp.Width  := BWidth;
  612.          Temp.Height := BHeight;
  614.          Temp.Canvas.CopyRect(Bounds(0, 0, BWidth, BHeight),
  615.                               FBackBmp.Canvas,
  616.                               Bounds(0, 0, FBackBmp.Width, FBackBmp.Height));
  618.          if Transparent then
  619.             FStretched.Canvas.BrushCopy(R, Temp,
  620.                                         Bounds(0, 0, BWidth, BHeight),
  621.                                         Temp.TransparentColor)
  622.          else
  623.             FStretched.Canvas.CopyRect(R, Temp.Canvas,
  624.                                        Bounds(0, 0, BWidth, BHeight));
  625.       end;
  627.    finally
  628.      Temp.Free;
  629.    end;
  631.    if FScale.Visible then
  632.    with FScale do
  633.    begin
  634.       MinValue := Self.MinValue;
  635.       MaxValue := Self.MaxValue;
  636.       StartAngle := Self.StartAngle;
  637.       EndAngle   := Self.EndAngle;
  638.       R          := SRect;
  639.       InflateRect(R,-(FrameSpace),-(FrameSpace));
  640.       DrawElliptic(FStretched.Canvas, R);
  641.    end;
  643.    if ((FocusAction = faFrameRect) or (FocusAction = faAll)) then
  644.        if Focused then
  645.        begin
  646.           R           := SRect;
  647.           InflateRect(R,-(FrameSpace-2),-(FrameSpace-2));
  648.           FStretched.Canvas.DrawFocusRect(R);
  649.        end;
  650. end;
  652. {-- TMMCustomWheel ------------------------------------------------------}
  653. procedure TMMCustomWheel.DoneStretched;
  654. begin
  655.    FStretched.Free;
  656.    FStretched := nil;
  657. end;
  659. {-- TMMCustomWheel ------------------------------------------------------}
  660. procedure TMMCustomWheel.CalcSize(var W, H : Integer);
  661. var
  662.    Space : Integer;
  663. begin
  664.    Space := BevelExtend + FrameSpace + ScaleSpace;
  666.    W := FBackBmp.Width + 2*Space;
  667.    H := FBackBmp.Height + 2*Space;
  668. end;
  670. {-- TMMCustomWheel ------------------------------------------------------}
  671. procedure TMMCustomWheel.DoAutoSize;
  672. var
  673.    W, H: Integer;
  674. begin
  675.    if csLoading in ComponentState then Exit;
  677.    CalcSize(W,H);
  678.    SetBounds(Left, Top, W, H);
  679. end;
  681. {-- TMMCustomWheel ------------------------------------------------------}
  682. function TMMCustomWheel.ScaleSpace  : Integer;
  683. begin
  684.    if Scale.Visible then
  685.       Result := Scale.ScaleHeight + ScaleMargin
  686.    else
  687.       Result := 0;
  688. end;
  690. {-- TMMCustomWheel ------------------------------------------------------}
  691. procedure TMMCustomWheel.UpdateControl;
  692. begin
  693.    if not (csLoading in ComponentState) then
  694.    begin
  695.       RecalcAngle;
  696.       Invalidate;
  697.    end;
  698. end;
  700. {-- TMMCustomWheel ------------------------------------------------------}
  701. procedure TMMCustomWheel.Change;
  702. begin
  703.    DoChange;
  704. end;
  706. {-- TMMCustomWheel ------------------------------------------------------}
  707. procedure TMMCustomWheel.DoChange;
  708. begin
  709.    if (csLoading in ComponentState) or
  710.       (csReading in ComponentState) then exit;
  712.    if Assigned(FOnChange) then FOnChange(Self);
  713. end;
  715. {-- TMMCustomWheel ------------------------------------------------------}
  716. procedure TMMCustomWheel.RecalcAngle;
  717. var
  718.    dVal : Extended;
  719.    dAng : Extended;
  720. begin
  721.    if FMinValue >= FMaxValue then
  722.       dVal := 0
  723.    else
  724.       dVal := (FValue - FMinValue) / (FMaxValue - FMinValue);
  726.    if FStartAngle > FEndAngle then
  727.       dAng := 360
  728.    else
  729.       dAng := FStartAngle + (360 - FEndAngle);
  731.    FAngle := Round(FStartAngle - dVal * dAng);
  733.    if FAngle < 0 then
  734.       FAngle := FAngle + 360;
  735. end;
  737. {-- TMMCustomWheel ------------------------------------------------------}
  738. procedure TMMCustomWheel.Paint;
  739. begin
  740.    with Canvas do
  741.    begin
  742.       { Do not use inherited Paint because we don't need to clear space }
  743.       { before blitting }
  744.       if assigned(FOnPaint) then
  745.          FOnPaint(Self,Canvas,ClientRect)
  746.       else
  747.       begin
  748.          Bevel.PaintBevel(Canvas,ClientRect,True);
  749.          Draw(BevelExtend, BevelExtend, Stretched);
  750.       end;
  751.       DrawHandle(FAngle);
  752.    end;
  753. end;
  755. {-- TMMCustomWheel ------------------------------------------------------}
  756. procedure TMMCustomWheel.DrawHandle(Angle : Integer);
  757. var
  758.    X, Y: Integer;
  759.    HS  : Integer;
  760. begin
  761.    X    := (Width div 2) + Round(Radius * cos(Angle / 180 * Pi));
  762.    Y    := (Height div 2) - Round(Radius * sin(Angle / 180 * Pi));
  764.    with Canvas do
  765.    begin
  766.       if Focused and ((FocusAction = faHandleColor) or (FocusAction = faAll)) then
  767.          Brush.Color := FocusedColor
  768.       else
  769.          Brush.Color := HandleColor;
  771.       Brush.Style := bsSolid;
  772.       Pen.Style   := psSolid;
  773.       Pen.Color   := Brush.Color;
  775.       if HandleStyle = hsOwnerDraw then
  776.          DoDrawHandle(ClientRect, Point(X,Y), Focused)
  777.       else
  778.       begin
  779.          HS := HandleSize div 2;
  780.          Ellipse(X-HS,Y-HS,X+HS,Y+HS);
  781.       end;
  782.    end;
  783. end;
  785. {-- TMMCustomWheel ------------------------------------------------------}
  786. procedure TMMCustomWheel.DoDrawHandle(Rect : TRect; Origin : TPoint; Focused : Boolean);
  787. begin
  788.    if Assigned(FOnDrawHandle) then
  789.       FOnDrawHandle(Self,Canvas,Rect,Origin,Focused);
  790. end;
  792. {-- TMMCustomWheel ------------------------------------------------------}
  793. procedure TMMCustomWheel.Loaded;
  794. begin
  795.    inherited Loaded;
  796.    if AutoSize then
  797.       DoAutoSize;
  798.    UpdateControl;
  799. end;
  801. {-- TMMCustomWheel ------------------------------------------------------}
  802. function TMMCustomWheel.GetStretched: TBitmap;
  803. begin
  804.    if FStretched = nil then
  805.       InitStretched;
  806.    Result := FStretched;
  807. end;
  809. {-- TMMCustomWheel ------------------------------------------------------}
  810. procedure TMMCustomWheel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  811. begin
  812.    if AutoSize then
  813.       CalcSize(AWidth,AHeight);
  814.    inherited SetBounds(ALeft,ATop,AWidth,AHeight);
  815.    DoneStretched;
  816.    Invalidate;
  817. end;
  819. {-- TMMCustomWheel ------------------------------------------------------}
  820. procedure TMMCustomWheel.CMColorChanged(var Msg);
  821. begin
  822.    DoneStretched;
  823.    inherited;
  824. end;
  826. {-- TMMCustomWheel ------------------------------------------------------}
  827. procedure TMMCustomWheel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  828. begin
  829.    if (Button = mbLeft) and not FDragging then
  830.    begin
  831.       FDragging := True;
  832.       SetFocus;
  833.       if not FUpDown then
  834.          Rotate(X,Y)
  835.       else
  836.       begin
  837.          FStartY         := Y;
  838.          FStartValue     := Value;
  839.       end;
  840.    end;
  841. end;
  843. {-- TMMCustomWheel ------------------------------------------------------}
  844. procedure TMMCustomWheel.MouseMove(Shift: TShiftState; X, Y: Integer);
  845. begin
  846.    if (ssLeft in Shift) and FDragging then
  847.       if not FUpDown then
  848.          Rotate(X,Y)
  849.       else
  850.          Value := FStartValue + Round((FStartY - Y) * (MaxValue - MinValue) / ScrollSize);
  851. end;
  853. {-- TMMCustomWheel ------------------------------------------------------}
  854. procedure TMMCustomWheel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  855. begin
  856.    if (Button = mbLeft) and FDragging then
  857.    begin
  858.       FDragging := False;
  859.       if not FUpDown then
  860.          Rotate(X,Y);
  861.    end;
  862. end;
  864. {-- TMMCustomWheel ------------------------------------------------------}
  865. procedure TMMCustomWheel.KeyDown(var Key: Word; Shift: TShiftState);
  866. begin
  867.    inherited KeyDown(Key,Shift);
  868.    case Key of
  869.       VK_DOWN, VK_LEFT: Value := Value - FLineStep;
  870.       VK_UP, VK_RIGHT : Value := Value + FLineStep;
  871.       VK_NEXT         : Value := Value - FPageStep;
  872.       VK_PRIOR        : Value := Value + FPageStep;
  873.       VK_HOME         : Value := FMaxValue;
  874.       VK_END          : Value := FMinValue;
  875.      else
  876.         Exit;
  877.    end;
  878.    Key := 0;
  879. end;
  881. {-- TMMCustomWheel ------------------------------------------------------}
  882. procedure TMMCustomWheel.Rotate(X, Y : Integer);
  883. var
  884.    dX, dY : Extended;
  885.    dAngle : Extended;
  886.    Ang    : Extended;
  887.    S, E   : Extended;
  889. begin
  890.    dX := X - (Width div 2);
  891.    dY := (Height div 2) - Y;
  893.    if (dX = 0) and (dY = 0) then Exit;
  895.    Ang := ArcTan2(dY, dX) / Pi * 180;
  896.    if Ang < 0 then
  897.       Ang := 360 + Ang;
  899.    S := FStartAngle;
  900.    if FStartAngle > FEndAngle then
  901.       E := S
  902.    else
  903.       E := FEndAngle;
  905.    dAngle := S + (360 - E);
  907.    if (Ang > S) and (Ang < E) then
  908.        if (Ang - S) < ((E - S) / 2) then
  909.            Ang := S
  910.        else
  911.            Ang := E;
  913.    Ang := FStartAngle - Ang;
  914.    if Ang < 0 then
  915.       Ang := 360 + Ang;
  917.    if (MaxValue < MinValue) or (dAngle = 0) then
  918.        Value := MinValue
  919.    else
  920.        Value := Round((MaxValue - MinValue) * (Ang / dAngle)) + MinValue;
  921. end;
  923. {-- TMMCustomWheel ------------------------------------------------------}
  924. procedure TMMCustomWheel.WMGetDlgCode(var Message: TWMGetDlgCode);
  925. begin
  926.    Message.Result := DLGC_WANTARROWS;
  927. end;
  929. {-- TMMCustomWheel ------------------------------------------------------}
  930. procedure TMMCustomWheel.WMSetFocus(var Msg);
  931. begin
  932.    DoneStretched;
  933.    UpdateControl;
  934. end;
  936. {-- TMMCustomWheel ------------------------------------------------------}
  937. procedure TMMCustomWheel.WMKillFocus(var Msg);
  938. begin
  939.    DoneStretched;
  940.    UpdateControl;
  941. end;
  943. {-- TMMCustomWheel ------------------------------------------------------}
  944. procedure TMMCustomWheel.Changed;
  945. begin
  946.    { Looks like bevel has changed }
  947.    DoneStretched;
  948.    if AutoSize then
  949.       DoAutoSize;
  950.    UpdateControl;
  951. end;
  953. end.