Delphi控件源码

开发平台：
Delphi

VrTrackBar.pas：源码内容
							{*****************************************************}
{                                                     }
{     Varian Component Workshop                       }
{                                                     }
{     Varian Software NL (c) 1996-2000                }
{     All Rights Reserved                             }
{                                                     }
{*****************************************************}
unit VrTrackBar;
{$I VRLIB.INC}
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  VrConst, VrTypes, VrClasses, VrControls, VrSysUtils, VrSystem;
type
  TVrTrackBarOption = (toActiveClick, toMouseClip, toHandPoint,
    toFixedPoints, toThumbOpaque);
  TVrTrackBarOptions = set of TVrTrackBarOption;
  TVrTrackBar = class(TVrCustomImageControl)
  private
    FMinValue: Integer;
    FMaxValue: Integer;
    FPosition: Integer;
    FStyle: TVrProgressStyle;
    FOrientation: TVrOrientation;
    FOptions: TVrTrackBarOptions;
    FFrequency: Integer;
    FBorderWidth: Integer;
    FGutterBevel: TVrBevel;
    FGutterWidth: Integer;
    FGutterColor: TColor;
    FTickMarks: TVrTickMarks;
    FTickColor: TColor;
    FScaleOffset: Integer;
    FFocusColor: TColor;
    FFocusOffset: Integer;
    FBackImageIndex: Integer;
    FThumbImageIndex: Integer;
    FBitmapList: TVrBitmapList;
    FBitmapListLink: TVrChangeLink;
    FOnChange: TNotifyEvent;
    FHit: Integer;
    FClipOn: Boolean;
    FFocused: Boolean;
    FThumbRect: TRect;
    FThumbWidth: Integer;
    FThumbHeight: Integer;
    FThumbImage: TBitmap;
    FThumbDown: Boolean;
    FThumbHasMouse: Boolean;
    FThumbStates: TVrNumGlyphs;
    procedure SetMinValue(Value: Integer);
    procedure SetMaxValue(Value: Integer);
    procedure SetPosition(Value: Integer);
    procedure SetStyle(Value: TVrProgressStyle);
    procedure SetOrientation(Value: TVrOrientation);
    procedure SetOptions(Value: TVrTrackBarOptions);
    procedure SetFrequency(Value: Integer);
    procedure SetBorderWidth(Value: Integer);
    procedure SetGutterWidth(Value: Integer);
    procedure SetGutterColor(Value: TColor);
    procedure SetGutterBevel(Value: TVrBevel);
    procedure SetTickMarks(Value: TVrTickMarks);
    procedure SetTickColor(Value: TColor);
    procedure SetScaleOffset(Value: Integer);
    procedure SetThumbStates(Value: TVrNumGlyphs);
    procedure SetFocusColor(Value: TColor);
    procedure SetFocusOffset(Value: Integer);
    procedure SetBackImageIndex(Value: Integer);
    procedure SetThumbImageIndex(Value: Integer);
    procedure SetBitmapList(Value: TVrBitmapList);
    procedure DrawScale(Canvas: TCanvas; Offset, ThumbOffset,
      RulerLength, PointsStep, PointsHeight, ExtremePointsHeight: Integer);
    procedure GutterBevelChanged(Sender: TObject);
    procedure BitmapListChanged(Sender: TObject);
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
    procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure GetThumbImage;
    procedure SetThumbTop(ATop: Integer);
    procedure SetThumbLeft(ALeft: Integer);
    procedure CenterThumb;
    procedure Paint; override;
    procedure PaintThumb;
    procedure Change; dynamic;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function GetViewWidth: Integer;
    function GetOffsetByValue(Value: Integer): Integer;
    function GetValueByOffset(Offset: Integer): Integer;
    function GetBitmap(Index: Integer): TBitmap;
    function GetSliderRect: TRect;
    function GetMinIndent(Rect: TRect): Integer;
    procedure SetThumbOffset(Value: Integer);
    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;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property MaxValue: Integer read FMaxValue write SetMaxValue default 100;
    property MinValue: Integer read FMinValue write SetMinValue default 0;
    property Position: Integer read FPosition write SetPosition default 0;
    property Orientation: TVrOrientation read FOrientation write SetOrientation default voHorizontal;
    property Style: TVrProgressStyle read FStyle write SetStyle default psBottomLeft;
    property Options: TVrTrackBarOptions read FOptions write SetOptions
      default [toActiveClick, toMouseClip, toHandPoint, toThumbOpaque];
    property Frequency: Integer read FFrequency write SetFrequency default 10;
    property BorderWidth: Integer read FBorderWidth write SetBorderWidth default 10;
    property GutterBevel: TVrBevel read FGutterBevel write SetGutterBevel;
    property GutterWidth: Integer read FGutterWidth write SetGutterWidth default 9;
    property GutterColor: TColor read FGutterColor write SetGutterColor default clBlack;
    property TickMarks: TVrTickMarks read FTickMarks write SetTickMarks default tmBoth;
    property TickColor: TColor read FTickColor write SetTickColor default clBlack;
    property ThumbStates: TVrNumGlyphs read FThumbStates write SetThumbStates default 1;
    property BackImageIndex: Integer read FBackImageIndex write SetBackImageIndex default -1;
    property ThumbImageIndex: Integer read FThumbImageIndex write SetThumbImageIndex default -1;
    property BitmapList: TVrBitmapList read FBitmapList write SetBitmapList;
    property ScaleOffset: Integer read FScaleOffset write SetScaleOffset default 5;
    property FocusColor: TColor read FFocusColor write SetFocusColor default clBlack;
    property FocusOffset: Integer read FFocusOffset write SetFocusOffset default 0;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Align;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    property Enabled;
    property Color;
    property Cursor;
    property DragMode;
{$IFDEF VER110}
    property DragKind;
{$ENDIF}
    property DragCursor;
    property ParentColor;
    property ParentShowHint;
    property ShowHint;
    property TabOrder;
    property TabStop default false;
    property Visible;
    property OnClick;
{$IFDEF VER130}
    property OnContextPopup;
{$ENDIF}
    property OnEnter;
    property OnExit;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
    property OnKeyDown;
    property OnKeyUp;
    property OnKeyPress;
    property OnDragOver;
{$IFDEF VER110}
    property OnEndDock;
{$ENDIF}
    property OnDragDrop;
    property OnEndDrag;
{$IFDEF VER110}
    property OnStartDock;
{$ENDIF}
    property OnStartDrag;
  end;
implementation
{$R VRTRACKBAR.D32}
const
  ThumbNames: array[0..1] of PChar =
    ('VRTB_VERT', 'VRTB_HORI');
{ TVrTrackBar }
constructor TVrTrackBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  Width := 175;
  Height := 45;
  TabStop := false;
  FMinValue := 0;
  FMaxValue := 100;
  FPosition := 0;
  FStyle := psBottomLeft;
  FOrientation := voHorizontal;
  FOptions := [toActiveClick, toMouseClip, toHandPoint, ToThumbOpaque];
  FFrequency := 10;
  FBorderWidth := 10;
  FTickMarks := tmBoth;
  FTickColor := clBlack;
  FScaleOffset := 5;
  FFocusColor := clBlack;
  FFocusOffset := 0;
  FGutterWidth := 9;
  FGutterColor := clBlack;
  FGutterBevel := TVrBevel.Create;
  with FGutterBevel do
  begin
    InnerStyle := bsNone;
    InnerSpace := 0;
    InnerOutline := osNone;
    OuterStyle := bsLowered;
    OuterSpace := 0;
    OuterOutline := osNone;
    OnChange := GutterBevelChanged;
  end;
  FBackImageIndex := -1;
  FThumbImageIndex := -1;
  FBitmapListLink := TVrChangeLink.Create;
  FBitmapListLink.OnChange := BitmapListChanged;
  FThumbImage := TBitmap.Create;
  FThumbStates := 1;
  GetThumbImage;
end;
destructor TVrTrackBar.Destroy;
begin
  FThumbImage.Free;
  FGutterBevel.Free;
  FBitmapListLink.Free;
  inherited Destroy;
end;
procedure TVrTrackBar.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure TVrTrackBar.GetThumbImage;
begin
  FThumbImage.Assign(GetBitmap(FThumbImageIndex));
  if FThumbImage.Empty then
  begin
    if Orientation = voVertical then
    FThumbImage.LoadFromResourceName(hInstance, ThumbNames[0])
    else FThumbImage.LoadFromResourceName(hInstance, ThumbNames[1]);
  end;
  FThumbHeight := FThumbImage.Height;
  FThumbWidth := FThumbImage.Width div ThumbStates;
  CenterThumb;
end;
function TVrTrackBar.GetBitmap(Index: Integer): TBitmap;
begin
  Result := nil;
  if Assigned(FBitmapList) then
    Result := FBitmapList.GetBitmap(Index);
end;
procedure TVrTrackBar.SetThumbLeft(ALeft: Integer);
begin
  FThumbRect := Bounds(ALeft, FThumbRect.Top, FThumbWidth, FThumbHeight);
end;
procedure TVrTrackBar.SetThumbTop(ATop: Integer);
begin
  FThumbRect := Bounds(FThumbRect.Left, ATop, FThumbWidth, FThumbHeight);
end;
procedure TVrTrackBar.CenterThumb;
begin
  if Orientation = voVertical then
    SetThumbLeft((Width - FThumbWidth) div 2)
  else SetThumbTop((Height - FThumbHeight) div 2);
end;
function TVrTrackBar.GetSliderRect: TRect;
begin
  Result := ClientRect;
  InflateRect(Result, -BorderWidth, -BorderWidth);
end;
function TVrTrackBar.GetMinIndent(Rect: TRect): Integer;
begin
  if Orientation = voVertical then
    Result := MaxIntVal(0, Rect.Top)
  else
    Result := MaxIntVal(0, Rect.Left);
end;
function TVrTrackBar.GetViewWidth: Integer;
var
  R: TRect;
begin
  R := GetSliderRect;
  if Orientation = voVertical then
  Result := HeightOf(R) - FThumbHeight
  else Result := WidthOf(R) - FThumbWidth;
end;
function TVrTrackBar.GetOffsetByValue(Value: Integer): Integer;
var
  Range: Double;
  R: TRect;
  MinIndent: Integer;
begin
  R := GetSliderRect;
  MinIndent := GetMinIndent(R);
  Range := MaxValue - MinValue;
  Result := Round((Value - MinValue) / Range * GetViewWidth) + MinIndent;
  if (FOrientation = voVertical) and (FStyle = psBottomLeft) then
    Result := R.Top + R.Bottom - Result - FThumbHeight
  else
  if (FOrientation = voHorizontal) and (FStyle = psTopRight) then
    Result := R.Left + R.Right - Result - FThumbWidth;
end;
function TVrTrackBar.GetValueByOffset(Offset: Integer): Integer;
var
  R: TRect;
  Range: Double;
  MinIndent: Integer;
begin
  R := GetSliderRect;
  MinIndent := GetMinIndent(R);
  if Orientation = voVertical then
    Offset := ClientHeight - Offset - FThumbHeight;
  Range := FMaxValue - FMinValue;
  Result := Round((Offset - MinIndent) * Range / GetViewWidth);
  if (toFixedPoints in Options) then
    Result := Round(Result / Frequency) * Frequency;
  Result := MinIntVal(FMinValue + MaxIntVal(Result, 0), FMaxValue);
end;
procedure TVrTrackBar.SetThumbOffset(Value: Integer);
var
  R: TRect;
  MinIndent: Integer;
begin
  R := GetSliderRect;
  MinIndent := GetMinIndent(R);
  Value := MinIntVal(MaxIntVal(Value, MinIndent),
    MinIndent + GetViewWidth);
  if (toFixedPoints in Options) then
  begin
    if FStyle = psBottomLeft then Value := GetValueByOffset(Value)
    else Value := FMaxValue - GetValueByOffset(Value) + FMinValue;
    Value := MinIntVal(GetOffsetByValue(Value), GetViewWidth);
  end;
  if FStyle = psBottomLeft then Position := GetValueByOffset(Value)
  else Position := FMaxValue - GetValueByOffset(Value) + FMinValue;
end;
procedure TVrTrackBar.Paint;
var
  R: TRect;
  Bmp: TBitmap;
  Offset, Value: Integer;
begin
  with BitmapImage, BitmapCanvas do
  begin
    Bmp := GetBitmap(BackImageIndex);
    if Bmp = nil then
    begin
      Brush.Color := Self.Color;
      FillRect(ClientRect);
    end else StretchDraw(ClientRect, Bmp);
    Pen.Color := TickColor;
    case Orientation of
      voVertical:
        begin
          Offset := (ClientWidth - FGutterWidth) div 2;
          R := Bounds(Offset, BorderWidth, GutterWidth,
            ClientHeight - FBorderWidth * 2);
          if (FTickMarks in [tmBoth, tmTopLeft]) then
            DrawScale(BitmapCanvas, R.Left - FScaleOffset, FThumbHeight div 2,
                      GetViewWidth, Frequency, -3, -4);
          if (FTickMarks in [tmBoth, tmBottomRight]) then
            DrawScale(BitmapCanvas, R.Right + FScaleOffset, FThumbHeight div 2,
                      GetViewWidth, Frequency, 3, 4);
        end;
      voHorizontal:
        begin
          Offset := (ClientHeight - FGutterWidth) div 2;
          R := Bounds(BorderWidth, Offset,
            ClientWidth - FBorderWidth * 2, GutterWidth);
          if (FTickMarks in [tmBoth, tmTopLeft]) then
            DrawScale(BitmapCanvas, R.Top - FScaleOffset, FThumbWidth div 2,
                      GetViewWidth, Frequency, -3, -4);
          if (FTickMarks in [tmBoth, tmBottomRight]) then
            DrawScale(BitmapCanvas, R.Bottom + FScaleOffset, FThumbWidth div 2,
                      GetViewWidth, Frequency, 3, 4);
        end;
    end;
    if GutterBevel.Visible then
    begin
      GutterBevel.Paint(BitmapCanvas, R);
      Brush.Color := GutterColor;
      FillRect(R);
    end;
    if (Focused) and (FocusOffset > -1) then
    begin
      R := ClientRect;
      InflateRect(R, -FocusOffset, -FocusOffset);
      Brush.Color := FocusColor;
      FrameRect(R);
    end;
  end; { Bitmap, BitmapCanvas }
  Value := GetOffsetByValue(Position);
  if Orientation = voVertical then
    SetThumbTop(Value) else SetThumbLeft(Value);
  PaintThumb;
  inherited Paint;
end;
procedure TVrTrackBar.PaintThumb;
var
  Index: Integer;
  SrcRect: TRect;
  TransColor: TColor;
begin
  Index := 0;
  if not Enabled then Index := 1;
  if FThumbDown then Index := 2;
  if (FThumbHasMouse) and (not FThumbDown) then Index := 3;
  if Index > ThumbStates - 1 then Index := 0;
  SrcRect := Bounds(Index * FThumbWidth, 0, FThumbWidth, FThumbHeight);
  with BitmapCanvas do
  begin
    TransColor := FThumbImage.TransparentColor;
    Brush.Color := TransColor;
    if toThumbOpaque in Options then Brush.Style := bsSolid
    else Brush.Style := bsClear;
    BrushCopy(FThumbRect, FThumbImage, SrcRect, TransColor);
  end;
end;
procedure TVrTrackBar.DrawScale(Canvas: TCanvas; Offset, ThumbOffset,
  RulerLength, PointsStep, PointsHeight, ExtremePointsHeight: Integer);
const
  MinInterval = 3;
var
  Interval, Scale, Cnt, I, Value: Integer;
  X, H, X1, X2, Y1, Y2, Tmp: Integer;
  Range: Double;
begin
  Scale := 0;
  Range := FMaxValue - FMinValue;
  repeat
    Inc(Scale);
    Cnt := Round(Range / (Scale * PointsStep)) + 1;
    if Cnt > 1 then
      Interval := RulerLength div (Cnt - 1)
    else Interval := RulerLength;
  until (Interval >= MinInterval + 1) or (Interval >= RulerLength);
  Value := FMinValue;
  for I := 1 to Cnt do
  begin
    H := PointsHeight;
    if I = Cnt then Value := FMaxValue;
    if (Value = FMaxValue) or (Value = FMinValue) then H := ExtremePointsHeight;
    X := GetOffsetByValue(Value);
    if Orientation = voHorizontal then
    begin
      X1 := X + ThumbOffset;
      Y1 := Offset;
      X2 := X1;
      Y2 := Y1 + H;
      if Y1 > Y2 then
      begin
        Tmp := Y1;
        Y1 := Y2;
        Y2 := Tmp;
      end;
    end
    else
    begin
      X1 := Offset;
      Y1 := X + ThumbOffset;
      X2 := X1 + H;
      Y2 := Y1;
      if X1 > X2 then
      begin
        Tmp := X1;
        X1 := X2;
        X2 := Tmp;
      end;
    end;
    Canvas.MoveTo(X1, Y1);
    Canvas.LineTo(X2, Y2);
    Inc(Value, Scale * PointsStep);
  end;
end;
procedure TVrTrackBar.WMSize(var Message: TWMSize);
begin
  inherited;
  CenterThumb;
  UpdateControlCanvas;
end;
procedure TVrTrackBar.WMSetCursor(var Message: TWMSetCursor);
var
  P: TPoint;
begin
  GetCursorPos(P);
  if (not Designing) and PtInRect(FThumbRect, ScreenToClient(P)) then
  begin
    if (toHandPoint in Options) then
      Windows.SetCursor(Screen.Cursors[VrCursorHandPoint]);
  end else inherited;
end;
procedure TVrTrackBar.WMGetDlgCode(var Msg: TWMGetDlgCode);
begin
  Msg.Result := DLGC_WANTARROWS;
end;
procedure TVrTrackBar.CMFocusChanged(var Message: TCMFocusChanged);
var
  Active: Boolean;
begin
  with Message do Active := (Sender = Self);
  if Active <> FFocused then
  begin
    FFocused := Active;
    UpdateControlCanvas;
  end;
  inherited;
end;
procedure TVrTrackBar.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  UpdateControlCanvas;
end;
procedure TVrTrackBar.Change;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;
procedure TVrTrackBar.GutterBevelChanged(Sender: TObject);
begin
  UpdateControlCanvas;
end;
procedure TVrTrackBar.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) then
    if AComponent = BitmapList then BitmapList := nil;
end;
procedure TVrTrackBar.BitmapListChanged(Sender: TObject);
begin
  GetThumbImage;
  UpdateControlCanvas;
end;
procedure TVrTrackBar.SetBackImageIndex(Value: Integer);
begin
  if FBackImageIndex <> Value then
  begin
    FBackImageIndex := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetThumbImageIndex(Value: Integer);
begin
  if FThumbImageIndex <> Value then
  begin
    FThumbImageIndex := Value;
    GetThumbImage;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetBitmapList(Value: TVrBitmapList);
begin
  if FBitmapList <> nil then
    FBitmapList.RemoveLink(FBitmapListLink);
  FBitmapList := Value;
  if FBitmapList <> nil then
    FBitmapList.InsertLink(FBitmapListLink);
  GetThumbImage;
  UpdateControlCanvas;
end;
procedure TVrTrackBar.SetMaxValue(Value: Integer);
begin
  if FMaxValue <> Value then
  begin
    FMaxValue := Value;
    if FPosition > FMaxValue then Position := FMaxValue
    else UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetMinValue(Value: Integer);
begin
  if FMinValue <> Value then
  begin
    FMinValue := Value;
    if FPosition < FMinValue then Position := FMinValue
    else UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetPosition(Value: Integer);
begin
  if Value < FMinValue then Value := FMinValue;
  if Value > FMaxValue then Value := FMaxValue;
  if FPosition <> Value then
  begin
    FPosition := Value;
    UpdateControlCanvas;
    Change;
  end;
end;
procedure TVrTrackBar.SetOrientation(Value: TVrOrientation);
begin
  if FOrientation <> Value then
  begin
    FOrientation := Value;
    if not Loading then
      BoundsRect := Bounds(Left, Top, Height, Width);
    GetThumbImage;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetStyle(Value: TVrProgressStyle);
begin
  if FStyle <> Value then
  begin
    FStyle := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetOptions(Value: TVrTrackBarOptions);
begin
  if FOptions <> Value then
  begin
    FOptions := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetFrequency(Value: Integer);
begin
  if FFrequency <> Value then
  begin
    FFrequency := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetBorderWidth(Value: Integer);
begin
  if FBorderWidth <> Value then
  begin
    FBorderWidth := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetGutterWidth(Value: Integer);
begin
  if FGutterWidth <> Value then
  begin
    FGutterWidth := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetGutterColor(Value: TColor);
begin
  if FGutterColor <> Value then
  begin
    FGutterColor := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetGutterBevel(Value: TVrBevel);
begin
  FGutterBevel.Assign(Value);
end;
procedure TVrTrackBar.SetTickMarks(Value: TVrTickMarks);
begin
  if FTickMarks <> Value then
  begin
    FTickMarks := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetTickColor(Value: TColor);
begin
  if FTickColor <> Value then
  begin
    FTickColor := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetFocusColor(Value: TColor);
begin
  if FFocusColor <> Value then
  begin
    FFocusColor := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetScaleOffset(Value: Integer);
begin
  if FScaleOffset <> Value then
  begin
    FScaleOffset := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetFocusOffset(Value: Integer);
begin
  if FFocusOffset <> Value then
  begin
    FFocusOffset := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.SetThumbStates(Value: TVrNumGlyphs);
begin
  if FThumbStates <> Value then
  begin
    FThumbStates := Value;
    if not Loading then
      GetThumbImage;
    UpdateControlCanvas;
  end;
end;
procedure TVrTrackBar.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  R: TRect;
  P: TPoint;
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) then
  begin
    if TabStop then SetFocus;
    P := Point(X, Y);
    if PtInRect(FThumbRect, P) then
    begin
      FThumbDown := True;
      if Orientation = voHorizontal then FHit := X - FThumbRect.Left
      else FHit := Y - FThumbRect.Top;
      if (toMouseClip in Options) then
      begin
        R := Bounds(ClientOrigin.X, ClientOrigin.Y,
          ClientWidth, ClientHeight);
        ClipCursor(@R);
        FClipOn := True;
      end;
      UpdateControlCanvas;
    end
    else
    if (toActiveClick in Options) then
    begin
      if Orientation = voHorizontal then
        FHit := X - FThumbWidth div 2
      else FHit := Y - FThumbHeight div 2;
      SetThumbOffset(FHit);
    end;
  end;
end;
procedure TVrTrackBar.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  OldValue: Boolean;
begin
  if FThumbDown then
  begin
    if FOrientation = voVertical then
      SetThumbOffset(Y - FHit)
    else
      SetThumbOffset(X - FHit);
  end
  else
  begin
    OldValue := FThumbHasMouse;
    FThumbHasMouse := PtInRect(FThumbRect, Point(X, Y));
    if OldValue <> FThumbHasMouse then UpdateControlCanvas;
  end;
  inherited MouseMove(Shift, X, Y);
end;
procedure TVrTrackBar.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if FThumbDown then
  begin
    FThumbDown := false;
    UpdateControlCanvas;
  end;
  if FClipOn then
  begin
    ClipCursor(nil);
    FClipOn := false;
  end;
  inherited MouseUp(Button, Shift, X, Y);
end;
procedure TVrTrackBar.KeyDown(var Key: Word; Shift: TShiftState);
  function Adjust(Value: Integer): Integer;
  begin
    Result := Value;
    if Style = psTopRight then Result := -Result;
  end;
begin
  if Shift = [] then
  begin
    if Key = VK_HOME then Position := FMaxValue
    else if Key = VK_END then Position := FMinValue;
    if Orientation = voHorizontal then
    begin
      if Key = VK_LEFT then Position := Position + Adjust(-Frequency)
      else if Key = VK_RIGHT then Position := Position + Adjust(Frequency);
    end
    else
    begin
      if Key = VK_UP then Position := Position + Adjust(Frequency)
      else if Key = VK_DOWN then Position := Position + Adjust(-Frequency);
    end;
  end;
  inherited KeyDown(Key, Shift);
end;
end.

						