mmwheel.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: [phone]                   =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 15.02.98 - 15:32:05 $                                        =}
{========================================================================}
unit MMWheel;

{$I COMPILER.INC}

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    Messages,
    Classes,
    SysUtils,
    Controls,
    ExtCtrls,
    Graphics,
    Menus,
    MMObj,
    MMScale;

type
    EMMWheelError      = class(Exception);
    TMMFocusAction     = (faHandleColor,faFrameRect,faAll);
    TMMHandleStyle     = (hsEllipse,hsOwnerDraw);
    TMMDrawHandleEvent = procedure(Sender : TObject; Canvas : TCanvas; Rect : TRect;
                                   Origin : TPoint; Focused : Boolean) of object;
    TMMPaintEvent      = procedure(Sender : TObject; Canvas: TCanvas; Rect : TRect) of object;
const
    {$IFDEF CBUILDER3} {$EXTERNALSYM defMinValue} {$ENDIF}
    defMinValue     = 0;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defMaxValue} {$ENDIF}
    defMaxValue     = 10;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defValue} {$ENDIF}
    defValue        = 0;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defStartAngle} {$ENDIF}
    defStartAngle   = 225;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defEndAngle} {$ENDIF}
    defEndAngle     = 315;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defWidth} {$ENDIF}
    defWidth        = 100;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defHeight} {$ENDIF}
    defHeight       = 100;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defAutoSize} {$ENDIF}
    defAutoSize     = True;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defHandleColor} {$ENDIF}
    defHandleColor  = clMaroon;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defFocusedColor} {$ENDIF}
    defFocusedColor = clRed;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defUpDown} {$ENDIF}
    defUpDown       = False;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defScrollSize} {$ENDIF}
    defScrollSize   = 160;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defLineStep} {$ENDIF}
    defLineStep     = 1;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defPageStep} {$ENDIF}
    defPageStep     = 2;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defFocusAction} {$ENDIF}
    defFocusAction  = faAll;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defHandleStyle} {$ENDIF}
    defHandleStyle  = hsEllipse;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defRadius} {$ENDIF}
    defRadius       = 0;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defHandleSize} {$ENDIF}
    defHandleSize   = 4;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defHandleMargin} {$ENDIF}
    defHandleMargin = 4;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defFrameSpace} {$ENDIF}
    defFrameSpace   = 4;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defScaleMargin} {$ENDIF}
    defScaleMargin  = 3;
    {$IFDEF CBUILDER3} {$EXTERNALSYM defTransparent} {$ENDIF}
    defTransparent  = True;

type
    {-- TMMCustomWheel ---------------------------------------------------}
    TMMCustomWheel = class(TMMCustomControl)
    private
        FAutoSize       : Boolean;
        FBackBmp        : TBitmap;
        FStretched      : TBitmap;
        FMinValue       : Integer;
        FMaxValue       : Integer;
        FValue          : Integer;
        FStartAngle     : Integer;
        FEndAngle       : Integer;
        FHandleColor    : TColor;
        FFocusedColor   : TColor;
        FUpDown         : Boolean;
        FScrollSize     : Integer;
        FLineStep       : Integer;
        FPageStep       : Integer;
        FFocusAction    : TMMFocusAction;
        FScale          : TMMScale;
        FRadius         : Integer;
        FHandleStyle    : TMMHandleStyle;
        FHandleSize     : Integer;
        FFrameSpace     : Integer;
        FScaleMargin    : Integer;
        FHandleMargin   : Integer;
        FTransparent    : Boolean;
        FOnChange       : TNotifyEvent;
        FOnDrawHandle   : TMMDrawHandleEvent;
        FOnPaint        : TMMPaintEvent;

        FAngle          : Integer;
        FDragging       : Boolean;
        FStartY         : Integer;
        FStartValue     : Integer;

        procedure SetAutoSize(Value: Boolean);
        procedure SetBackBmp(Value: TBitmap);
        procedure SetMinValue(Value: Integer);
        procedure SetMaxValue(Value: Integer);
        procedure SetValue(aValue: Integer);
        procedure SetStartAngle(Value: Integer);
        procedure SetEndAngle(Value: Integer);
        procedure SetHandleColor(Value: TColor);
        procedure SetFocusedColor(Value: TColor);
        procedure SetFocusAction(Value: TMMFocusAction);
        procedure SetScrollParam(Index: Integer; Value : Integer);
        procedure SetScale(Value: TMMScale);
        procedure SetRadius(Value: Integer);
        function  GetRadius: Integer;
        procedure SetHandleStyle(Value: TMMHandleStyle);
        procedure SetHandleSize(Value: Integer);
        procedure SetHandleMargin(Value: Integer);
        procedure SetFrameSpace(Value: Integer);
        procedure SetScaleMargin(Value: Integer);
        procedure SetTransparent(Value: Boolean);
        function  GetStretched: TBitmap;

        procedure InitStretched;
        procedure DoneStretched;

        procedure CMColorChanged(var Msg); message CM_COLORCHANGED;
        procedure WMSetFocus(var Msg); message WM_SETFOCUS;
        procedure WMKillFocus(var Msg); message WM_KILLFOCUS;

        procedure ScaleChanged(Sender : TObject);
    protected
        procedure UpdateControl;
        procedure Change; virtual;
        procedure DoChange; dynamic;
        procedure Paint; override;
        procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
        procedure RecalcAngle;
        procedure DrawHandle(Angle : Integer); virtual;
        procedure DoDrawHandle(Rect : TRect; Origin : TPoint; Focused : Boolean); dynamic;
        procedure Loaded; override;
        procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
        procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
        procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
        procedure KeyDown(var Key: Word; Shift: TShiftState); override;
        procedure Rotate(X,Y : Integer);
        procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
        procedure DoAutoSize;
        function  ScaleSpace: Integer;
        procedure Changed; override;
        procedure CalcSize(var W, H : Integer);
        property  Stretched: TBitmap read GetStretched;

    public
        constructor Create(AOwner : TComponent); override;
        destructor  Destroy; override;

    protected
        property TabStop default True;
        property AutoSize    : Boolean read FAutoSize write SetAutoSize;
        property BackBmp     : TBitmap read FBackBmp write SetBackBmp;
        property MinValue    : Integer read FMinValue write SetMinValue default defMinValue;
        property MaxValue    : Integer read FMaxValue write SetMaxValue default defMaxValue;
        property Value       : Integer read FValue write SetValue default defValue;
        property StartAngle  : Integer read FStartAngle write SetStartAngle default defStartAngle;
        property EndAngle    : Integer read FEndAngle write SetEndAngle default defEndAngle;
        property HandleColor : TColor  read FHandleColor write SetHandleColor default defHandleColor;
        property FocusedColor: TColor  read FFocusedColor write SetFocusedColor default defFocusedColor;
        property UpDown      : Boolean read FUpDown write FUpDown default defUpDown;
        property ScrollSize  : Integer index 0 read FScrollSize write SetScrollParam default defScrollSize;
        property LineStep    : Integer index 1 read FLineStep write SetScrollParam default defLineStep;
        property PageStep    : Integer index 2 read FPageStep write SetScrollParam default defPageStep;
        property FocusAction : TMMFocusAction read FFocusAction write SetFocusAction default defFocusAction;
        property Scale       : TMMScale read FScale write SetScale;
        property Radius      : Integer read GetRadius write SetRadius default defRadius;
        property HandleStyle : TMMHandleStyle read FHandleStyle write SetHandleStyle default defHandleStyle;
        property HandleSize  : Integer read FHandleSize write SetHandleSize default defHandleSize;
        property HandleMargin: Integer read FHandleMargin write SetHandleMargin default defHandleMargin;
        property FrameSpace  : Integer read FFrameSpace write SetFrameSpace default defFrameSpace;
        property ScaleMargin : Integer read FScaleMargin write SetScaleMargin default defScaleMargin;
        property Transparent : Boolean read FTransparent write SetTransparent default defTransparent;
        property OnChange    : TNotifyEvent read FOnChange write FOnChange;
        property OnDrawHandle: TMMDrawHandleEvent read FOnDrawHandle write FOnDrawHandle;
        property OnPaint     : TMMPaintEvent read FOnPaint write FOnPaint;
    end;

    {-- TMMWheel ---------------------------------------------------------}
    TMMWheel = class(TMMCustomWheel)
    published
        property OnEnter;
        property OnExit;
        property OnKeyDown;
        property OnKeyPress;
        property OnKeyUp;
        property OnChange;
        property OnDrawHandle;
        property OnPaint;

        property Bevel;
        property Visible;
        property Color;
        property Enabled;
        property ParentShowHint;
        property PopupMenu;
        property ShowHint;
        property TabStop;
        property TabOrder;
        property Width;
        property Height;

        property AutoSize;
        property BackBmp;
        property MinValue;
        property MaxValue;
        property Value;
        property StartAngle;
        property EndAngle;
        property HandleColor;
        property FocusedColor;
        property UpDown;
        property ScrollSize;
        property LineStep;
        property PageStep;
        property FocusAction;
        property Scale;
        property Radius;
        property HandleStyle;
        property HandleSize;
        property HandleMargin;
        property FrameSpace;
        property ScaleMargin;
        property Transparent;
     end;

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

{$IFDEF WIN32}
  {$R MMWHEEL.D32}
{$ELSE}
  {$R MMWHEEL.D16}
{$ENDIF}

uses
    MMMath,
    MMUtils;

{== TMMCustomWheel ======================================================}
constructor TMMCustomWheel.Create(AOwner : TComponent);
begin
   inherited Create(AOwner);

   ControlStyle := ControlStyle -
                   [csAcceptsControls,csFramed,csSetCaption] +
                   [csCaptureMouse,csOpaque];

   Width           := defWidth;
   Height          := defHeight;

   FScale          := TMMScale.Create;
   FScale.OnChange := ScaleChanged;

   FBackBmp        := TBitmap.Create;
   FBackBmp.Width  := defWidth;
   FBackBmp.Height := defHeight;
   BackBmp := nil;   { set default bitmap }

   FAutoSize       := defAutoSize;
   FMinValue       := defMinValue;
   FMaxValue       := defMaxValue;
   FValue          := defValue;
   FStartAngle     := defStartAngle;
   FEndAngle       := defEndAngle;
   FHandleColor    := defHandleColor;
   FUpDown         := defUpDown;
   FScrollSize     := defScrollSize;
   FLineStep       := defLineStep;
   FPageStep       := defPageStep;
   FFocusAction    := defFocusAction;
   FFocusedColor   := defFocusedColor;
   FHandleStyle    := defHandleStyle;
   FHandleSize     := defHandleSize;
   FHandleMargin   := defHandleMargin;
   FFrameSpace     := defFrameSpace;
   FScaleMargin    := defScaleMargin;
   FTransparent    := defTransparent;

   Bevel.BevelOuter:= bvNone;
   TabStop         := True;

   RecalcAngle;

   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMCustomWheel ------------------------------------------------------}
destructor TMMCustomWheel.Destroy;
begin
   DoneStretched;
   FBackBmp.Free;
   FScale.Free;

   inherited Destroy;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetAutoSize(Value : Boolean);
begin
   if FAutoSize <> Value then
   begin
      FAutoSize := Value;
      if FAutoSize then
         DoAutoSize;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetBackBmp(Value : TBitmap);
begin
   if (Value <> nil) then
       FBackBmp.Assign(Value)
   else
       FBackBmp.Handle := LoadBitmap(HInstance, 'BM_WHEEL');

   DoneStretched;
   if FAutoSize then
      DoAutoSize;

   Repaint;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetMinValue(Value : Integer);
begin
   if Value <> FMinValue then
   begin
      FMinValue := Value;
      UpdateControl;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetMaxValue(Value : Integer);
begin
   if Value <> FMaxValue then
   begin
      FMaxValue := Value;
      UpdateControl;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetValue(aValue : Integer);
begin
   aValue := MinMax(aValue, FMinValue, FMaxValue);
   if FValue <> aValue then
   begin
      FValue := aValue;
      UpdateControl;
      Change;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetStartAngle(Value : Integer);
begin
   Value := MinMax(Value, 0, 360);
   if Value <> FStartAngle then
   begin
      FStartAngle := Value;
      UpdateControl;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetEndAngle(Value : Integer);
begin
   Value := MinMax(Value, 0, 360);
   if Value <> FEndAngle then
   begin
      FEndAngle := Value;
      UpdateControl;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetHandleColor(Value : TColor);
begin
   if Value <> FHandleColor then
   begin
      FHandleColor := Value;
      UpdateControl;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetTransparent(Value : Boolean);
begin
   if Value <> FTransparent then
   begin
      FTransparent := Value;
      Invalidate;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetScrollParam(Index : Integer; Value : Integer);
begin
   if Value <= 0 then
      { TODO: Should be resource id }
      raise EMMWheelError.Create('This parameter should be greater then 0');

   case Index of
      0 : FScrollSize := Value;
      1 : FLineStep := Value;
      2 : FPageStep := Value;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetFocusedColor(Value : TColor);
begin
   if Value <> FFocusedColor then
   begin
      FFocusedColor := Value;
      UpdateControl;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetFocusAction(Value : TMMFocusAction);
begin
   if Value <> FFocusAction then
   begin
      FFocusAction := Value;
      UpdateControl;
   end;
end;

{-- TMMCustomWheel ------------------------------------------------------}
procedure TMMCustomWheel.SetScale(Value: TMMScale);