mmslider.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [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: 30.03.98 - 16:35:32 $                                        =}
{========================================================================}
unit MMSlider;

{$I COMPILER.INC}

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    Forms,
    SysUtils,
    Messages,
    Classes,
    Graphics,
    Controls,
    Dialogs,
    ExtCtrls,
    Menus,
    MMObj,
    MMUtils,
    MMBCache,
    MMMath,
    MMString,
    MMScale;


type
  TMMOrientation    = (orVertical,orHorizontal);
  TMMThumbStyle     = (tsRect,tsOwnerDraw);
  TMMGrooveStyle    = (gsRect,gsOwnerDraw);
  TMMFocusAction    = (faNone, faFocusThumb, faFocusRect, faFocusColor, faAll);
  TMMScalePos       = (spAboveOrLeft, spBelowOrRight, spBoth);
  TMMThumbDrawEvent = procedure(Sender: TObject; aCanvas: TCanvas; aRect: TRect;
                                Dragged,Focused: Boolean) of object;
  TMMGrooveDrawEvent= procedure(Sender: TObject; aCanvas: TCanvas; var aRect: TRect) of object;

  {-- TMMCustomSlider ---------------------------------------------------}
  TMMCustomSlider = class(TMMCustomControl)
  private
    FDragging                : Boolean;
    FGroove                  : TMMBevel;
    FHandCursor              : Boolean;
    FThumbCursor             : TCursor;
    FMax,FMin,FPosition      : Longint;
    FLineSize                : Integer;
    FPageSize                : Integer;
    FOrientation             : TMMOrientation;
    FFocusAction             : TMMFocusAction;
    FThumbWidth, FThumbHeight: Byte;
    FThumbColor              : TColor;
    FThumbBorder             : Boolean;
    FGrooveColor             : TColor;
    FFocusColor              : TColor;
    FDisabledColor           : TColor;
    FFocusTime               : Boolean;
    FScaleDistance           : Integer;
    FScalePos                : TMMScalePos;
    FScale                   : TMMScale;
    FGrooveSize              : Byte;
    FThumbStyle              : TMMThumbStyle;
    FGrooveStyle             : TMMGrooveStyle;
    FBitmap                  : TBitmap;
    FForceChange             : Boolean;
    FDragOffset              : integer;
    FDragVal                 : Longint;
    HalfTW,HalfTH            : Integer;
    FThumbRect               : TRect;
    FPicLeft                 : TBitmap;
    FPicRight                : TBitmap;
    FSensitivity             : integer;
    FLogMode                 : Boolean;
    FNeedTrackEnd            : Boolean;

    FOnChange                : TNotifyEvent;
    FOnTrack                 : TNotifyEvent;
    FOnTrackEnd              : TNotifyEvent;
    FOnDrawThumb             : TMMThumbDrawEvent;
    FOnDrawGroove            : TMMGrooveDrawEvent;
    FOnGetFocus              : TNotifyEvent; { Added January, 30 2000 }
    FOnLostFocus             : TNotifYEvent; { Added January, 30 2000 }
    FOnMouseEnter            : TNotifyEvent; { Added January, 30 2000 }
    FOnMouseLeave            : TNotifyEvent; { Added January, 30 2000 }

    procedure SetColors(index: integer; aValue: TColor);
    procedure SetMax(aValue: Longint);
    procedure SetMin(aValue: Longint);
    procedure SetOrientation(aValue: TMMOrientation);
    procedure SetPosition(aValue: Longint);
    function  GetPosition: Longint;
    function  UpdatePosition(aValue: Longint): Boolean;
    procedure UpdateFocusTimer(Enable: Boolean);
    procedure SetScaleDist(aValue: Integer);
    procedure SetScalePos(aValue: TMMScalePos);
    procedure SetScale(Value: TMMScale);
    procedure SetFocusAction(aValue: TMMFocusAction);
    procedure SetGrooveSize(aValue: Byte);
    procedure SetThumbSize(index: integer; aValue: Byte);
    procedure SetThumbBorder(aValue: Boolean);
    procedure SetThumbStyle(aValue: TMMThumbStyle);
    procedure SetGrooveStyle(aValue: TMMGrooveStyle);
    procedure SetSensitivity(aValue: integer);
    procedure SetLogMode(aValue: Boolean);
    procedure SetGroove(aValue: TMMBevel);
    procedure GrooveChanged(Sender: TObject);
    procedure ScaleChanged(Sender: TObject);
    procedure TimerAction(Sender: TObject);
    procedure UpdateBitmap(aWidth,aHeight: integer);
    function  NewPosition(WhereX,WhereY: Integer): integer;
    function  IsVert: Boolean;
    procedure WhereIsThumb(const ClientRect: TRect; var aRect: TRect);
    procedure DrawTrench(Canvas: TCanvas; aRect: TRect);
    procedure DrawScale(Canvas: TCanvas; aRect: TRect);
    procedure DrawThumb(Canvas: TCanvas; aRect: TRect);
    function  DrawGroove(Canvas: TCanvas; aRect: TRect): TRect;
    function  DrawPics(Canvas: TCanvas; aRect: TRect): TRect;
    procedure SetPicLeft(Value: TBitmap);
    procedure SetPicRight(Value: TBitmap);
    procedure PicChanged(Sender: TObject);
    function  CalcClientRect: TRect;

    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SetFocus;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KillFocus;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER; { Added January, 30 2000 }
    procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE; { Added January, 30 2000 }

  protected
    procedure Change; dynamic;
    procedure Track; dynamic;
    procedure TrackEnd; dynamic;
    procedure OwnerDrawThumb(aCanvas: TCanvas; aRect: TRect; Dragged,Focused: Boolean); dynamic;
    procedure OwnerDrawGroove(aCanvas: TCanvas; var aRect: TRect); dynamic;
    procedure Paint; override;
    procedure Loaded; override;
    procedure SetBounds(aLeft, aTop, aWidth, aHeight: integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure SetThumbCursor(AtThumb: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure SetMinMax(aMin,aMax: Longint);

  protected
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnTrack: TNotifyEvent read FOnTrack write FOnTrack;
    property OnTrackEnd: TNotifyEvent read FOnTrackEnd write FOnTrackEnd;
    property OnDrawThumb: TMMThumbDrawEvent read FOnDrawThumb write FOnDrawThumb;
    property OnDrawGroove: TMMGrooveDrawEvent read FOnDrawGroove write FOnDrawGroove;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property OnGetFocus: TNotifyEvent read FOnGetFOcus write FOnGetFocus;
    property OnLostFocus: TNotifyEvent read FOnLostFocus write FOnLostFocus;

    property TabStop default True;
    property Width default 200;
    property Height default 40;
    property Groove: TMMBevel read FGroove write SetGroove;
    property FocusAction: TMMFocusAction read FFocusAction write SetFocusAction default faFocusRect;
    property FocusColor: TColor index 0 read FFocusColor write SetColors default clActiveCaption;
    property GrooveColor: TColor index 1 read FGrooveColor write SetColors default clBtnFace;
    property ThumbColor: TColor index 2 read FThumbColor write SetColors default clBtnFace;
    property DisabledColor: TColor index 3 read FDisabledColor write SetColors default clWhite;

    property HandCursor: Boolean read FHandCursor write FHandCursor default False;
    property ThumbCursor: TCursor read FThumbCursor write FThumbCursor default crDefault;

    property MinValue: Longint read FMin write SetMin default 0;
    property MaxValue: Longint read FMax write SetMax default 10;
    property LineSize: Integer read FLineSize write FLineSize default 1;
    property PageSize: Integer read FPageSize write FPageSize default 5;
    property Orientation: TMMOrientation read FOrientation write SetOrientation default orHorizontal;
    property Position: Longint read GetPosition write SetPosition default 0;
    property GrooveSize: Byte read FGrooveSize write SetGrooveSize default 3;
    property GrooveStyle: TMMGrooveStyle read FGrooveStyle write SetGrooveStyle default gsRect;
    property ThumbWidth: Byte index 0 read FThumbWidth write SetThumbSize default 11;
    property ThumbHeight: Byte index 1 read FThumbHeight write SetThumbSize default 23;
    property ThumbStyle: TMMThumbStyle read FThumbStyle write SetThumbStyle default tsRect;
    property ThumbBorder: Boolean read FThumbBorder write SetThumbBorder default True;
    property ScaleDistance: Integer read FScaleDistance write SetScaleDist default 10;
    property ScalePosition: TMMScalePos read FScalePos write SetScalePos default spBelowOrRight;
    property Scale: TMMScale read FScale write SetScale;

    property PicLeft: TBitmap read FPicLeft write SetPicLeft;
    property PicRight: TBitmap read FPicRight write SetPicRight;

    property Logarithmic: Boolean read FLogMode write SetLogMode default False;
    property Sensitivity: Integer read FSensitivity write SetSensitivity default -24;
  end;

  {-- TMMSlider ---------------------------------------------------------}
  TMMSlider = class(TMMCustomSlider)
  published
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnChange;
    property OnTrack;
    property OnTrackEnd;
    property OnDrawThumb;
    property OnDrawGroove;
    property OnMouseEnter; { Added January, 30 2000 }
    property OnMouseLeave; { Added January, 30 2000 }
    property OnGetFocus;   { Added January, 30 2000 }
    property OnLostFocus;  { Added January, 30 2000 }

    property Align;
    property Visible;
    property Color;
    property Enabled;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabStop;
    property TabOrder;
    property Width;
    property Height;
    property Bevel;
    property Groove;
    property FocusAction;
    property FocusColor;
    property GrooveColor;
    property ThumbColor;
    property ThumbBorder;
    property DisabledColor;
    property HandCursor;
    property ThumbCursor;
    property MinValue;
    property MaxValue;
    property LineSize;
    property PageSize;
    property Orientation;
    property Position;
    property GrooveSize;
    property ThumbWidth;
    property ThumbHeight;
    property ThumbStyle;
    property GrooveStyle;

    property ScaleDistance;
    property ScalePosition;
    property Scale;

    property PicLeft;
    property PicRight;

    property Logarithmic;
    property Sensitivity;
  end;

implementation

const
     FocusTimer: TTimer = nil;
     
{== TMMCustomSlider =====================================================}
constructor TMMCustomSlider.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);

   FBitmap := nil;
   FGroove := TMMBevel.Create;
   FGroove.OnChange := GrooveChanged;
   Bevel.BorderWidth := 5;
   Height := 40;
   Width := 200;
   FFocusAction:= faFocusRect;
   FHandCursor := False;
   FThumbCursor := crDefault;
   FMin := 0;
   FMax := 10;
   FForceChange := False;
   FLineSize := 1;
   FPageSize := 5;
   FOrientation := orHorizontal;
   FPosition := 0;
   FGrooveSize := 3;
   FDragging := False;
   FDragVal := 0;
   FDragOffset := 0;
   ThumbStyle := tsRect;
   GrooveStyle := gsRect;
   FFocusColor := clActiveCaption;
   FGrooveColor := clBtnFace;
   FThumbColor := clBtnFace;
   FThumbBorder:= True;
   FDisabledColor := clWhite;
   FScalePos := spBelowOrRight;
   FScale := TMMScale.Create;
   FScale.OnChange  := ScaleChanged;
   FScale.Visible := False;
   FScale.Origin := soOuter;
   FScale.Connect := True;
   FScaleDistance := 10;
   FFocusTime := False;
   FSensitivity := -24;
   FLogMode := False;
   FNeedTrackEnd := False;
   TabStop := True;
   FThumbWidth := 11;
   ThumbHeight := 23;

   FPicLeft := TBitmap.Create;
   FPicRight := TBitmap.Create;
   FPicLeft.OnChange := PicChanged;
   FPicRight.OnChange := PicChanged;

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

{-- TMMCustomSlider -----------------------------------------------------}
destructor TMMCustomSlider.Destroy;
begin
   FGroove.OnChange := Nil;
   FGroove.Free;

   RemoveCacheBitmap(FBitmap);

   UpdateFocusTimer(False);

   FScale.Free;

   FPicLeft.Free;
   FPicRight.Free;

   inherited Destroy;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.Change;
begin
   if (csLoading in ComponentState) or
      (csReading in ComponentState) then exit;

   if assigned(FOnChange) then FOnChange(Self);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.Track;
begin
   FNeedTrackEnd := True;
   if assigned(FOnTrack) then FOnTrack(Self);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.TrackEnd;
begin
   if FNeedTrackEnd then
   begin
      if assigned(FOnTrackEnd) then FOnTrackEnd(Self);
      FNeedTrackEnd := False;
   end;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.OwnerDrawThumb(aCanvas: TCanvas; aRect: TRect; Dragged,Focused: Boolean);
begin
   if assigned(FOnDrawThumb) then FOnDrawThumb(Self,aCanvas,aRect,Dragged,Focused);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.OwnerDrawGroove(aCanvas: TCanvas; var aRect: TRect);
begin
   if Assigned(FOnDrawGroove) then FOnDrawGroove(Self,aCanvas,aRect);
end;

{-- TMMCustomSlider -----------------------------------------------------}
Procedure TMMCustomSlider.SetGroove(aValue: TMMBevel);
begin
   FGroove.Assign(aValue);
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.GrooveChanged(Sender: TObject);
begin
   Changed;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.ScaleChanged(Sender: TObject);
begin
   Changed;
end;

{-- TMMCustomSlider -----------------------------------------------------}
procedure TMMCustomSlider.PicChanged(Sender: TObject);
begin
   Changed;
end;

{-- TMMCustomSlider -----------------------------------------------------}
function  TMMCustomSlider.CalcClientRect: TRect;
begin
    Result := BeveledRect;

    if not FPicLeft.Empty then
        if Orientation = orHorizontal then
            Inc(Result.Left,FPicLeft.Width)
        else