Delphi控件源码

开发平台：
Delphi

MMCtrl.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: +49(0)351-8037944               =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/index.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: 03.11.98 - 21:39:50 $                                        =}
{========================================================================}
unit MMCtrl;
{$I COMPILER.INC}
interface
uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    Forms,
    SysUtils,
    Messages,
    Classes,
    Graphics,
    Controls,
    Dialogs,
    ExtCtrls,
    Menus,
    Buttons,
    MMObj,
    MMUtils,
    MMMath,
    MMString,
    MMBmpLst,
    MMObsrv;
type
  TMMOrientation   = (orVertical,orHorizontal);
  TMMZeroPosition  = (zpBottomLeft,zpTopRight);
  TMMGetGylphIndex = procedure(Sender: TObject; IsDown: Boolean; var Index: integer) of object;
  TMMGetBackGround = procedure(Sender: TObject; Bmp: TBitmap; R: TRect) of object;
  {-- TMMBitmapSlider ---------------------------------------------------------}
  TMMBitmapSlider = class(TMMCustomBitmapListControl)
  private
    FAutoSize                : Boolean;
    FDragging                : Boolean;
    FHandCursor              : Boolean;
    FThumbCursor             : TCursor;
    FThumbWidth, FThumbHeight: Byte;
    FMax,FMin,FPosition      : Longint;
    FLineSize                : Integer;
    FPageSize                : Integer;
    FZeroPosition            : TMMZeroPosition;
    FOrientation             : TMMOrientation;
    FSaveBitmap              : TBitmap;
    FDragOffset              : integer;
    FDragVal                 : Longint;
    FThumbRect               : TRect;
    FSensitivity             : integer;
    FLogMode                 : Boolean;
    FNeedTrackEnd            : Boolean;
    FForceChange             : Boolean;
    FMargin                  : integer;
    FNumGlyphs               : integer;
    FNumThumbGlyphs          : integer;
    FBitmapOK                : Boolean;
    FBitmapThumbIndex        : integer;
    FThumbMargin             : integer;
    FOnChange                : TNotifyEvent;
    FOnTrack                 : TNotifyEvent;
    FOnTrackEnd              : TNotifyEvent;
    FOnGetGlyphIndex         : TMMGetGylphIndex;
    FOnGetThumbGlyphIndex    : TMMGetGylphIndex;
    FOnGetBackground         : TMMGetBackGround;
    procedure SetBitmapThumbIndex(aValue: integer);
    procedure SetMargin(aValue: integer);
    procedure SetThumbMargin(aValue: integer);
    procedure UpdateSlider;
    procedure SetAutoSize(aValue: Boolean);
    procedure SetNumThumbGlyphs(aValue: integer);
    procedure SetNumGlyphs(aValue: integer);
    procedure SetMax(aValue: Longint);
    procedure SetMin(aValue: Longint);
    procedure SetOrientation(aValue: TMMOrientation);
    procedure SetZeroPosition(aValue: TMMZeroPosition);
    procedure SetPosition(aValue: Longint);
    function  GetPosition: Longint;
    function  UpdatePosition(aValue: Longint): Boolean;
    procedure SetSensitivity(aValue: integer);
    procedure SetLogMode(aValue: Boolean);
    function  NewPosition(WhereX,WhereY: Integer): Longint;
    function  IsVert: Boolean;
    function  IsInverted: Boolean;
    function  GetSrcRect(index: integer): TRect;
    function  GetThumbSrcRect(index: integer): TRect;
    procedure DrawBitmapImage(Canvas: TCanvas; Bitmap: TBitmap; X,Y: integer; Src: TRect);
    procedure WhereIsThumb(const ClientRect: TRect; var aRect: TRect);
    procedure DrawThumb(Canvas: TCanvas; aRect: TRect);
    procedure RedrawThumb;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    function  GetThumbBitmap: TBitmap;
  protected
    procedure Change; dynamic;
    procedure Track; dynamic;
    procedure TrackEnd; dynamic;
    procedure Paint; override;
    procedure BitmapChanged; override;
    function  FindTransparentColor: TColor; 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 SetThumbCursor(AtThumb: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetMinMax(aMin,aMax: Longint);
    function ThumbBitmapValid: Boolean;
    property ThumbBitmap: TBitmap read GetThumbBitmap;
  published
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnStartDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnTrack: TNotifyEvent read FOnTrack write FOnTrack;
    property OnTrackEnd: TNotifyEvent read FOnTrackEnd write FOnTrackEnd;
    property OnGetGlyphIndex: TMMGetGylphIndex read FOnGetGlyphIndex write FOnGetGlyphIndex;
    property OnGetThumbGlyphIndex: TMMGetGylphIndex read FOnGetThumbGlyphIndex write FOnGetThumbGlyphIndex;
    property OnGetBackground: TMMGetBackground read FOnGetBackground write FOnGetBackground;
    property Width default 200;
    property Height default 40;
    property DragCursor;
    property Visible;
    property Enabled;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TransparentColor;
    property TransparentMode;
    property BitmapList;
    property BitmapIndex;
    property BitmapBackIndex;
    property BitmapThumbIndex: Integer read FBitmapThumbIndex write SetBitmapThumbIndex default -1;
    property Margin: integer read FMargin write SetMargin default 2;
    property ThumbMargin: integer read FThumbMargin write SetThumbMargin default 0;
    property NumGlyphs: integer read FNumGlyphs write SetNumGlyphs default 1;
    property NumThumbGlyphs: integer read FNumThumbGlyphs write SetNumThumbGlyphs default 1;
    property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
    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 ZeroPosition: TMMZeroPosition read FZeroPosition write SetZeroPosition default zpBottomLeft;
    property Position: Longint read GetPosition write SetPosition default 0;
    property Logarithmic: Boolean read FLogMode write SetLogMode default False;
    property Sensitivity: Integer read FSensitivity write SetSensitivity default -24;
    property Transparent;
  end;
implementation
{== TMMBitmapSlider ===========================================================}
constructor TMMBitmapSlider.Create(AOwner: TComponent);
begin
   FBitmapOK := False;
   inherited Create(AOwner);
   ControlStyle := ControlStyle - [csOpaque];
   FAutoSize          := False;
   FNumGlyphs         :=  1;
   FNumThumbGlyphs    :=  1;
   FBitmapThumbIndex  := -1;
   FThumbCursor       := crDefault;
   FForceChange       := False;
   FSaveBitmap        := TBitmap.Create;
   SetBounds(0,0,40,200);
   FHandCursor        := False;
   FMin               := 0;
   FMax               := 10;
   FLineSize          := 1;
   FPageSize          := 5;
   FOrientation       := orHorizontal;
   FZeroPosition      := zpBottomLeft;
   FPosition          := 0;
   FDragging          := False;
   FDragOffset        := 0;
   FDragVal           := 0;
   FSensitivity       := -24;
   FLogMode           := False;
   FNeedTrackEnd      := False;
   FMargin            := 2;
   FThumbMargin       := 0;
   
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
destructor TMMBitmapSlider.Destroy;
begin
   FSaveBitmap.Free;
   FSaveBitmap := nil;
   inherited Destroy;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.BitmapChanged;
begin
   UpdateSlider;
end;
{-- TMMBitmapSlider -----------------------------------------------------------}
procedure TMMBitmapSlider.SetBitmapThumbIndex(aValue: integer);
begin
   if (FBitmapThumbIndex <> aValue) then
   begin
      FBitmapThumbIndex := Max(aValue,-1);
      BitmapChanged;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.ThumbBitmapValid: Boolean;
begin
   Result := assigned(BitmapList) and (FBitmapThumbIndex >= 0) and (FBitmapThumbIndex <  BitmapList.Count);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.GetThumbBitmap: TBitmap;
begin
   if ThumbBitmapValid then
      Result := BitmapList[BitmapThumbIndex]
   else
      Result := nil;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.UpdateSlider;
begin
   if ThumbBitmapValid then
   begin
      FThumbWidth := ThumbBitmap.Width div FNumThumbGlyphs;
      FThumbHeight:= ThumbBitmap.Height;
   end;
   if BitmapValid and AutoSize then
   begin
      { adjust sizes }
      if (Orientation = orHorizontal) then
          SetBounds(Left,Top,Width,Height div FNumGlyphs)
      else
          SetBounds(Left,Top,Width div FNumGlyphs,Height);
   end;
   FBitmapOK := False;
   Invalidate;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetAutoSize(aValue: Boolean);
begin
   if (aValue <> FAutoSize) then
   begin
      FAutoSize := aValue;
      UpdateSlider;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.Change;
begin
   if (csLoading in ComponentState) or
      (csReading in ComponentState) or
      (csDestroying in ComponentState) then exit;
   if assigned(FOnChange) then FOnChange(Self);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.GetSrcRect(index: integer): TRect;
begin
   index := Min(index,FNumGlyphs-1);
   if (Orientation = orHorizontal) then
   begin
      Result.Left := 0;
      Result.Top := index * (Bitmap.Height div FNumGlyphs);
      Result.Right := Bitmap.Width;
      Result.Bottom := (index+1) * (Bitmap.Height div FNumGlyphs);
   end
   else
   begin
      Result.Left := index * (Bitmap.Width div FNumGlyphs);
      Result.Top := 0;
      Result.Right := (index+1) * (Bitmap.Width div FNumGlyphs);
      Result.Bottom := Bitmap.Height;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.GetThumbSrcRect(index: integer): TRect;
begin
   index := Min(index,FNumThumbGlyphs-1);
   Result.Left := index * (ThumbBitmap.Width div FNumThumbGlyphs);
   Result.Top := 0;
   Result.Right := (index+1) * (ThumbBitmap.Width div FNumThumbGlyphs);
   Result.Bottom := ThumbBitmap.Height;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetNumGlyphs(aValue: integer);
begin
   if (FNumGlyphs <> aValue) then
   begin
      FNumGlyphs := Max(aValue,1);
      UpdateSlider;
      Refresh;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetNumThumbGlyphs(aValue: integer);
begin
   if (FNumThumbGlyphs <> aValue) then
   begin
      FNumThumbGlyphs := Max(aValue,1);
      UpdateSlider;
      Refresh;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.Track;
begin
   FNeedTrackEnd := True;
   if assigned(FOnTrack) then FOnTrack(Self);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.TrackEnd;
begin
   if FNeedTrackEnd then
   begin
      if assigned(FOnTrackEnd) then FOnTrackEnd(Self);
      FNeedTrackEnd := False;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.CMEnabledChanged(var Message: TMessage);
begin
   if (csDesigning in ComponentState) or not FBitmapOK then
      Invalidate
   else
      RedrawThumb;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetBounds(aLeft, aTop, aWidth, aHeight: integer);
begin
   if BitmapValid and AutoSize then
   begin
      aWidth := Bitmap.Width;
      aHeight:= Bitmap.Height;
      if (Orientation = orHorizontal) then
          aHeight := aHeight div FNumGlyphs
      else
          aWidth := aWidth div FNumGlyphs;
   end;
   if (Width <> aWidth) or (Height <> aHeight) and (FSaveBitmap <> nil) then
   begin
      FSaveBitmap.Width  := aWidth;
      FSaveBitmap.Height := 2*aHeight;
      FBitmapOK          := False;
   end;
   inherited SetBounds(aLeft, aTop, aWidth, aHeight);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetSensitivity(aValue: integer);
var
   oldVal: integer;
begin
   aValue:= MinMax(aValue, -96, -10);
   if aValue <> FSensitivity then
   begin
      oldVal := Position;
      FSensitivity:= aValue;
      Position := oldVal;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetLogMode;
var
   oldVal: integer;
begin
   if (aValue <> FlogMode) then
   begin
      oldVal := Position;
      FLogMode := aValue;
      if not (csLoading in ComponentState) then FMax := Max(FMax,FMin+Ord(FLogMode));
      Position := oldVal;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetMin(aValue: Longint);
begin
   SetMinMax(aValue,FMax);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetMax(aValue: Longint);
begin
   SetMinMax(FMin,aValue);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetMinMax(aMin,aMax: Longint);
begin
   if (FMin <> aMin) or (FMax <> aMax) then
   begin
      FMin := aMin;
      FMax := aMax;
      if not (csLoading in ComponentState) then
         FMax := Max(FMax,FMin+Ord(FLogMode));
      FForceChange := True;
      Position := MinMax(Position,FMin,FMax);
      FForceChange := False;
      if (csDesigning in ComponentState) or not FBitmapOK then
          Invalidate
      else
          RedrawThumb;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetOrientation(aValue: TMMOrientation);
begin
   if (aValue <> FOrientation) then
   begin
      FOrientation := aValue;
      UpdateSlider;
   end;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK2}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetZeroPosition(aValue: TMMZeroPosition);
begin
   if (aValue <> FZeroPosition) then
   begin
      FZeroPosition := aValue;
      Invalidate;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.DrawBitmapImage(Canvas: TCanvas; Bitmap: TBItmap; X, Y: integer; Src: TRect);
var
   Done,H,W: integer;
begin
   if (Orientation = orVertical) and (Src.Bottom-Src.Top >= Height) or
      (Orientation = orHorizontal) and (Src.Right-Src.Left >= Width) then
   begin
      DrawTransparentBitmapEx(Canvas.Handle, Bitmap.Handle, X, Y, Src, GetTransparentColor);
   end
   else if (Orientation = orVertical) then
   begin
      Done := 0;
      Dec(Src.Bottom,2);
      while (Done < Height) do
      begin
         DrawTransparentBitmapEx(Canvas.Handle, Bitmap.Handle, X, Y+Done, Src, GetTransparentColor);
         H := Src.Bottom-Src.Top;
         if (Done = 0) then Inc(Src.Top,2);
         inc(Done,H);
      end;
   end
   else
   begin
      Done := 0;
      Dec(Src.Right,2);
      while (Done < Width) do
      begin
         DrawTransparentBitmapEx(Canvas.Handle, Bitmap.Handle, X+Done, Y, Src, GetTransparentColor);
         W := Src.Right-Src.Left;
         if (Done = 0) then Inc(Src.Left,4);
         inc(Done,W);
      end;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.RedrawThumb;
var
   index: integer;
   SrcRect: TRect;
begin
   if Visible then
   begin
      { copy saved background to temp bitmap (top) }
      FSaveBitmap.Canvas.CopyRect(Rect(0,0,Width,Height),
                                  FSaveBitmap.Canvas,
                                  Rect(0,Height,Width,2*Height));
      if (NumGlyphs > 1) and BitmapValid then
      begin
         Index := 0;
         if assigned(FOnGetGlyphIndex) then
         begin
            FOnGetGlyphIndex(Self, FDragging, Index);
            Index := MinMax(Index,0,FNumGlyphs-1);
         end;
         SrcRect := GetSrcRect(Index);
         { draw the image to the top bitmap }
         DrawBitmapImage(FSaveBitmap.Canvas,Bitmap,0,0,SrcRect);
      end;
      { draw Thumb to Bitmap }
      DrawThumb(FSaveBitmap.Canvas,FThumbRect);
      { and copy to screen }
      Canvas.Draw(0,0,FSaveBitmap);
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.UpdatePosition(aValue: Longint): Boolean;
var
   aRect: TRect;
begin
   if (aValue <> FPosition) or FForceChange then
   begin
      Result := True;
      FPosition := MinMax(aValue,FMin,FMax);
      if not (csDesigning in ComponentState) and
         not (csLoading in ComponentState) then
      begin
         WhereIsThumb(ClientRect,aRect);
         if (aRect.Left <> FThumbRect.Left) or (aRect.Top <> FThumbRect.Top) or
            (aRect.Right <> FThumbRect.Right) or (aRect.Bottom <> FThumbRect.Bottom) then
         begin
            FThumbRect := aRect;
            if FBitmapOK then
               RedrawThumb
            else
               Refresh;
         end;
         Change;
      end
      else Refresh;
   end
   else Result := False;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetPosition(aValue: Longint);
var
   aPos: Float;
begin
   if FLogMode and (aValue <> 0) then
   begin
      aPos:= Log10(aValue/(FMax-FMin))*20 + -FSensitivity;
      aPos:= MinMax(Round(aPos*(FMax-FMin)/-FSensitivity),FMin,FMax);
      aValue := Round(aPos);
   end;
   UpdatePosition(aValue);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.GetPosition: Longint;
var
   aPos: Float;
begin
   aPos := MinMax(FPosition,FMin,FMax);
   if FLogMode and (aPos <> 0) then
   begin
      aPos:= Pow(10,(aPos*(-FSensitivity)/(FMax-FMin)-(-FSensitivity))/20)*(FMax-FMin);
   end;
   Result := MinMax(Round(aPos),FMin,FMax);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.NewPosition(WhereX,WhereY: Integer): Longint;
var
  aHeight,aWidth: Integer;
begin
   { Calculate the nearest position to where the mouse is located }
   with ClientRect do
   begin
      aHeight := (Bottom - Top) - FThumbHeight;
      aWidth  := (Right - Left) - FThumbWidth;
      WhereY  := WhereY - Top - (FThumbHeight div 2);
      WhereX  := WhereX - Left - (FThumbWidth div 2);
   end;
   if IsVert then
   begin
      if IsInverted then
         Result := Round((WhereY/aHeight)*(FMax-FMin)+FMin)
      else
         Result := Round(((aHeight-WhereY)/aHeight)*(FMax-FMin)+FMin);
   end
   else
   begin
      if IsInverted then
         Result := Round(((aWidth-WhereX)/aWidth)*(FMax-FMin)+FMin)
      else
         Result := Round((WhereX/aWidth)*(FMax-FMin)+FMin);
   end;
   Result := Min(Max(Result,FMin),FMax);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.IsVert: Boolean;
begin
   Result := (Orientation = orVertical);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.IsInverted: Boolean;
begin
   Result := (ZeroPosition = zpTopRight);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
function TMMBitmapSlider.FindTransparentColor: TColor;
var
   HBM: HBITMAP;
begin
   Result := clDefault;
   if assigned(BitmapList) then
   begin
      if ThumbBitmapValid then
          HBM := ThumbBitmap.Handle
      else if BitmapValid then
          HBM := Bitmap.Handle
      else exit;
      Result := MMUtils.GetTransparentColor(HBM);
   end;
 end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetMargin(aValue: integer);
begin
   if (aValue <> FMargin) then
   begin
      FMargin := MinMax(aValue,0,25);
      Refresh;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetThumbMargin(aValue: integer);
begin
   if (aValue <> FThumbMargin) then
   begin
      FThumbMargin := MinMax(aValue,-5,5);
      Refresh;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if PtInRect(FThumbRect,Point(X,Y)) then
   begin
      if (Button = mbLeft) then FDragging := True;
      SetThumbCursor(True);
   end;
   if (Button = mbLeft) then
   begin
      if IsVert then
         FDragOffset := Y
      else
         FDragOffset := X;
      FDragVal := FPosition;
      if not FDragging then
         UpdatePosition(NewPosition(X,Y))
      else if (FNumThumbGlyphs > 1) then
         RedrawThumb;
      Track;
   end;
   inherited MouseDown(Button, Shift, X, Y);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.MouseMove(Shift: TShiftState; X, Y: Integer);
var
   aPos,aWidth,aHeight: integer;
begin
   if not FDragging then
   begin
     {$IFDEF WIN32}
     SetThumbCursor(ptInRect(FThumbRect,Point(X,Y)));
     {$ELSE}
     SetThumbCursor(ptInRect(FThumbRect,Point(X,Y)) or FDragging);
     {$ENDIF}
   end;
   {Is the left mouse button down and dragging the thumb bar?}
   if (ssLeft in Shift) and FDragging then
   begin
      with ClientRect do
      begin
         aHeight := (Bottom - Top) - FThumbHeight - 2*Margin;
         aWidth  := (Right - Left) - FThumbWidth - 2*Margin;
      end;
      if IsVert then
      begin
         if IsInverted then
            aPos := Round(((Y-FDragOffset)*(FMax-FMin))/aHeight)
         else
            aPos := Round(((FDragOffset-Y)*(FMax-FMin))/aHeight);
      end
      else
      begin
         if IsInverted then
            aPos := Round(((FDragOffset-X)*(FMax-FMin))/aWidth)
         else
            aPos := Round(((X-FDragOffset)*(FMax-FMin))/aWidth);
      end;
      aPos := Min(Max(FDragVal+aPos,FMin),FMax);
      if UpdatePosition(aPos) then Track;
   end;
   inherited MouseMove(Shift, X, Y);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   if (Button = mbLeft) then
   begin
      FDragging := False;
      if (FNumThumbGlyphs > 1) then RedrawThumb;
      Update;
      TrackEnd;
   end;
   inherited MouseUp(Button, Shift, X, Y);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.WhereIsThumb(const ClientRect: TRect; var aRect: Trect);
var
  Each           : Real;
  ThumbX,ThumbY  : integer;
  aWidth, aHeight: integer;
begin
   aWidth := ClientRect.Right - ClientRect.Left;
   aHeight := ClientRect.Bottom - ClientRect.Top;
   { Calculate where to paint the thumb bar - store in aRect }
   if IsVert then
   begin
      if (FMax-FMin = 0) then
          Each := (aHeight-FThumbHeight-2*Margin)/1
      else
          Each := (aHeight-FThumbHeight-2*Margin)/Max(FMax-FMin,Sign(FMin));
      if IsInverted then
         ThumbY := Round(Each*(FPosition-FMin))+Margin
      else
         ThumbY := (aHeight-Round(Each*(FPosition-FMin))-FThumbHeight)-Margin;
      ThumbY := ClientRect.Top + Max(0,Min(aHeight-FThumbHeight-Margin,ThumbY));
      ThumbX := ClientRect.Left + ((aWidth+1) div 2) - ((FThumbWidth+1) div 2) + FThumbMargin;
   end
   else
   begin
      if (FMax-FMin = 0) then
          Each := (aWidth-FThumbWidth-2*Margin)/1
      else
          Each := (aWidth-FThumbWidth-2*Margin)/(FMax-FMin);
      if IsInverted then
         ThumbX := (aWidth-Round(Each*(FPosition-FMin))-FThumbWidth)-Margin
      else
         ThumbX := Round(Each*(FPosition-FMin))+Margin;
      ThumbX := ClientRect.Left + Max(0,Min(aWidth-FThumbWidth-Margin,ThumbX))+FThumbMargin;
      ThumbY := ClientRect.Top + ((aHeight+1) div 2) - ((FThumbHeight+1) div 2);
   end;
   aRect := Rect(ThumbX,ThumbY,ThumbX+FThumbWidth,ThumbY+FThumbHeight);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.SetThumbCursor(AtThumb: Boolean);
begin
   if AtThumb then
      if FHandCursor then
         SetCursor(Screen.Cursors[crsHand5])
      else
         SetCursor(Screen.Cursors[ThumbCursor])
   else
       SetCursor(Screen.Cursors[Cursor]);
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.DrawThumb(Canvas: TCanvas; aRect: TRect);
var
   index: integer;
   SrcRect: TRect;
begin
   with Canvas,aRect do
   begin
      if ThumbBitmapValid then
      begin
         index := 0;
         if assigned(FOnGetThumbGlyphIndex) then
         begin
            FOnGetThumbGlyphIndex(Self, FDragging, Index);
            Index := MinMax(Index,0,FNumThumbGlyphs-1);
         end
         else
         begin
            case FNumThumbGlyphs of   {normal,disabled,down,down }
               2: if not Enabled then Index := 1;
               3: if not Enabled then
                     Index := 1
                  else if Dragging then
                     Index := 2;
            end;
         end;
         SrcRect := GetThumbSrcRect(index);
         DrawTransparentBitmapEx(Handle, ThumbBitmap.Handle,
                                 aRect.Left, aRect.Top,
                                 SrcRect,
                                 GetTransparentColor);
      end;
   end;
end;
{-- TMMBitmapSlider -----------------------------------------------------}
procedure TMMBitmapSlider.Paint;
var
   S: string;
   SrcRect: TRect;
   index,Done,H,W: integer;
begin
   if (FSaveBitmap = nil) then exit;
   if not (csDesigning in ComponentState) and assigned(FOnGetBackground) then
   begin
      FOnGetBackground(Self,FSaveBitmap,Rect(0,Height,Width,2*Height));
   end
   else
   begin
      { save the actual background to the bottom of the bitmap }
      FSaveBitmap.Canvas.CopyRect(Rect(0,Height,Width,2*Height),Canvas,ClientRect);
   end;
   FBitmapOK := True;
   { draw the image to our bitmap }
   with FSaveBitmap.Canvas,ClientRect do
   begin
      if not BitmapValid then
      begin
         if (csDesigning in ComponentState) then
         begin
            Font := Self.Font;
            Brush.Style := bsClear;
            S := 'Empty';
            TextOut((Right-TextWidth(S)) div 2,Height+((Bottom-TextHeight(S))) div 2,S);
            Pen.Style   := psDot;
            Rectangle(Left,Height+Top,Right,Height+Bottom);
            Pen.Mode := pmCopy;
         end;
      end
      else
      begin
         Index := 0;
         if assigned(FOnGetGlyphIndex) then
         begin
            FOnGetGlyphIndex(Self, FDragging, Index);
            Index := MinMax(Index,0,FNumGlyphs-1);
         end;
         SrcRect := GetSrcRect(Index);
         { draw the background to the top of the bitmap }
         DrawBitmapImage(FSaveBitmap.Canvas,Bitmap,0,Height,SrcRect);
      end;
   end;
   { copy the background to screen }
   Canvas.CopyRect(ClientRect,FSaveBitmap.Canvas,Rect(0,Height,Width,2*Height));
   { draw the Thumb }
   WhereIsThumb(ClientRect,FThumbRect);
   DrawThumb(Canvas,FThumbRect);
end;
end.

						