Delphi控件源码

开发平台：
Delphi

VrSlider.pas：源码内容
							{*****************************************************}
{                                                     }
{     Varian Component Workshop                       }
{                                                     }
{     Varian Software NL (c) 1996-2000                }
{     All Rights Reserved                             }
{                                                     }
{*****************************************************}
unit VrSlider;
{$I VRLIB.INC}
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  VrConst, VrTypes, VrClasses, VrControls, VrSysUtils, VrSystem;
type
  TVrSliderOption = (soActiveClick, soMouseClip, soHandPoint, soThumbOpaque);
  TVrSliderOptions = set of TVrSliderOption;
  TVrSliderStyle = (ssBottomLeft, ssTopRight);
  TVrSlider = class(TVrCustomImageControl)
  private
    FBevel: TVrBevel;
    FPalette: TVrPalette;
    FThumbRect: TRect;
    FThumbWidth: Integer;
    FThumbHeight: Integer;
    FThumbImage: TBitmap;
    FThumbImageIndex: Integer;
    FThumbStates: TVrNumGlyphs;
    FThumbIndent: Integer;
    FBackImageOrg: TBitmap;
    FBackImageNew: TBitmap;
    FMinValue: Integer;
    FMaxValue: Integer;
    FPosition: Integer;
    FOrientation: TVrOrientation;
    FSpacing: Integer;
    FTickWidth: Integer;
    FSolidFill: Boolean;
    FStyle: TVrSliderStyle;
    FOptions: TVrSliderOptions;
    FKeyIncrement: Integer;
    FBorderColor: TColor;
    FBorderWidth: Integer;
    FFocusColor: TColor;
    FHit: Integer;
    FClipOn: Boolean;
    FFocused: Boolean;
    FThumbDown: Boolean;
    FThumbHasMouse: Boolean;
    FBitmapList: TVrBitmapList;
    FBitmapListLink: TVrChangeLink;
    FOnChange: TNotifyEvent;
    procedure SetMinValue(Value: Integer);
    procedure SetMaxValue(Value: Integer);
    procedure SetPosition(Value: Integer);
    procedure SetTickWidth(Value: Integer);
    procedure SetSpacing(Value: Integer);
    procedure SetSolidFill(Value: Boolean);
    procedure SetOrientation(Value: TVrOrientation);
    procedure SetStyle(Value: TVrSliderStyle);
    procedure SetThumbImageIndex(Value: Integer);
    procedure SetThumbStates(Value: TVrNumGlyphs);
    procedure SetThumbIndent(Value: Integer);
    procedure SetOptions(Value: TVrSliderOptions);
    procedure SetBorderColor(Value: TColor);
    procedure SetBorderWidth(Value: Integer);
    procedure SetFocusColor(Value: TColor);
    procedure SetBitmapList(Value: TVrBitmapList);
    procedure SetPalette(Value: TVrPalette);
    procedure SetBevel(Value: TVrBevel);
    procedure BevelChanged(Sender: TObject);
    procedure PaletteModified(Sender: TObject);
    procedure BitmapListChanged(Sender: TObject);
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
    procedure CMFocusChanged(var Message: TCMFocusChanged); message CM_FOCUSCHANGED;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  protected
    procedure GetThumbImage;
    procedure SetThumbTop(ATop: Integer);
    procedure SetThumbLeft(ALeft: Integer);
    procedure CenterThumb;
    procedure CreateBackImages;
    procedure Loaded; override;
    procedure Paint; override;
    procedure PaintThumb;
    procedure Changed; dynamic;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure DrawVert(Canvas: TCanvas; Rect: TRect; Color: TColor);
    procedure DrawHorz(Canvas: TCanvas; Rect: TRect; Color: TColor);
    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 Spacing: Integer read FSpacing write SetSpacing default 1;
    property TickWidth: Integer read FTickWidth write SetTickWidth default 1;
    property Orientation: TVrOrientation read FOrientation write SetOrientation default voVertical;
    property SolidFill: Boolean read FSolidFill write SetSolidFill default True;
    property Style: TVrSliderStyle read FStyle write SetStyle default ssBottomLeft;
    property ThumbStates: TVrNumGlyphs read FThumbStates write SetThumbStates default 1;
    property Options: TVrSliderOptions read FOptions write SetOptions
      default [soHandPoint, soThumbOpaque];
    property KeyIncrement: Integer read FKeyIncrement write FKeyIncrement default 5;
    property BorderColor: TColor read FBorderColor write SetBorderColor default clBtnFace;
    property BorderWidth: Integer read FBorderWidth write SetBorderWidth default 1;
    property FocusColor: TColor read FFocusColor write SetFocusColor default clBlue;
    property Bevel: TVrBevel read FBevel write SetBevel;
    property Palette: TVrPalette read FPalette write SetPalette;
    property ThumbImageIndex: Integer read FThumbImageIndex write SetThumbImageIndex default -1;
    property ThumbIndent: Integer read FThumbIndent write SetThumbIndent default 2;
    property BitmapList: TVrBitmapList read FBitmapList write SetBitmapList;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    property Enabled;
    property Color default clBlack;
    property Cursor;
    property DragMode;
{$IFDEF VER110}
    property DragKind;
{$ENDIF}
    property DragCursor;
    property ParentColor default false;
    property ParentShowHint;
    property ShowHint;
    property TabOrder;
    property TabStop default false;
    property Visible;
    property OnClick;
{$IFDEF VER130}
    property OnContextPopup;
{$ENDIF}
    property OnDblClick;
    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 VRSLIDER.D32}
const
  ThumbNames: array[0..1] of PChar =
    ('VRSLIDERTHUMB_VERT', 'VRSLIDERTHUMB_HORI');
function CreateLCDImage(AWidth, AHeight: Integer;
  ForeColor, BackColor: TColor): TBitmap;
begin
  Result := TBitmap.Create;
  with TBitmap(Result) do
  begin
    Width := AWidth;
    Height := AHeight;
    Canvas.Brush.Bitmap := CreateDitherPattern(ForeColor, BackColor);
    Canvas.FillRect(BitmapRect(Result));
    Canvas.Brush.Bitmap.Free;
    Canvas.Brush.Bitmap := nil;
  end;
end;
constructor TVrSlider.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  Width := 36;
  Height := 171;
  Color := clBlack;
  ParentColor := false;
  Tabstop := false;
  FMinValue := 0;
  FMaxValue := 100;
  FPosition := 0;
  FSpacing := 1;
  FTickWidth := 1;
  FOrientation := voVertical;
  FSolidFill := True;
  FStyle := ssBottomLeft;
  FOptions := [soHandPoint, soThumbOpaque];
  FKeyIncrement := 5;
  FBorderColor := clBtnFace;
  FBorderWidth := 1;
  FFocusColor := clBlue;
  FThumbStates := 1;
  FThumbIndent := 2;
  FThumbImage := TBitmap.Create;
  FBackImageOrg := TBitmap.Create;
  FBackImageNew := TBitmap.Create;
  FBevel := TVrBevel.Create;
  with FBevel do
  begin
    InnerStyle := bsLowered;
    InnerWidth := 2;
    InnerColor := clBlack;
    OnChange := BevelChanged;
  end;
  FPalette := TVrPalette.Create;
  FPalette.OnChange := PaletteModified;
  FThumbImageIndex := -1;
  FBitmapListLink := TVrChangeLink.Create;
  FBitmapListLink.OnChange := BitmapListChanged;
  GetThumbImage;
end;
destructor TVrSlider.Destroy;
begin
  FBevel.Free;
  FPalette.Free;
  FThumbImage.Free;
  FBackImageOrg.Free;
  FBackImageNew.Free;
  FBitmapListLink.Free;
  inherited Destroy;
end;
procedure TVrSlider.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure TVrSlider.Loaded;
begin
  inherited Loaded;
  GetThumbImage;
end;
procedure TVrSlider.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) then
    if AComponent = BitmapList then BitmapList := nil;
end;
procedure TVrSlider.GetThumbImage;
begin
  FThumbImage.Assign(GetBitmap(FThumbImageIndex));
  if FThumbImage.Empty then
  begin
    if Orientation = voVertical then
    FThumbImage.LoadFromResourceName(hInstance, ThumbNames[1])
    else FThumbImage.LoadFromResourceName(hInstance, ThumbNames[0]);
  end;
  FThumbHeight := FThumbImage.Height;
  FThumbWidth := FThumbImage.Width div ThumbStates;
  CenterThumb;
end;
function TVrSlider.GetBitmap(Index: Integer): TBitmap;
begin
  Result := nil;
  if Assigned(FBitmapList) then
    Result := FBitmapList.GetBitmap(Index);
end;
procedure TVrSlider.SetThumbLeft(ALeft: Integer);
begin
  FThumbRect := Bounds(ALeft, FThumbRect.Top, FThumbWidth, FThumbHeight);
end;
procedure TVrSlider.SetThumbTop(ATop: Integer);
begin
  FThumbRect := Bounds(FThumbRect.Left, ATop, FThumbWidth, FThumbHeight);
end;
procedure TVrSlider.CenterThumb;
begin
  if Orientation = voVertical then
    SetThumbLeft((Width - FThumbWidth) div 2)
  else SetThumbTop((Height - FThumbHeight) div 2);
end;
function TVrSlider.GetSliderRect: TRect;
begin
  Result := ClientRect;
  InflateRect(Result, -BorderWidth - ThumbIndent, -BorderWidth - ThumbIndent);
end;
function TVrSlider.GetMinIndent(Rect: TRect): Integer;
begin
  if Orientation = voVertical then
    Result := MaxIntVal(0, Rect.Top)
  else
    Result := MaxIntVal(0, Rect.Left);
end;
function TVrSlider.GetViewWidth: Integer;
var
  R: TRect;
begin
  R := GetSliderRect;
  if Orientation = voVertical then
  Result := HeightOf(R) - FThumbHeight
  else Result := WidthOf(R) - FThumbWidth;
end;
function TVrSlider.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 = ssBottomLeft) then
    Result := R.Top + R.Bottom - Result - FThumbHeight
  else
  if (FOrientation = voHorizontal) and (FStyle = ssTopRight) then
    Result := R.Left + R.Right - Result - FThumbWidth;
end;
function TVrSlider.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);
  Result := MinIntVal(FMinValue + MaxIntVal(Result, 0), FMaxValue);
end;
procedure TVrSlider.SetThumbOffset(Value: Integer);
var
  R: TRect;
  MinIndent: Integer;
begin
  R := GetSliderRect;
  MinIndent := GetMinIndent(R);
  Value := MinIntVal(MaxIntVal(Value, MinIndent),
    MinIndent + GetViewWidth);
  if FStyle = ssBottomLeft then Position := GetValueByOffset(Value)
  else Position := FMaxValue - GetValueByOffset(Value) + FMinValue;
end;
procedure TVrSlider.Paint;
var
  Value: Integer;
  BevelRect, SrcRect, DestRect: TRect;
  CurrentColor: TColor;
begin
  ClearBitmapCanvas;
  BevelRect := ClientRect;
  if BorderWidth > 0 then
  begin
    if FFocused then CurrentColor := FFocusColor
    else CurrentColor := FBorderColor;
    DrawFrame3D(BitmapCanvas, BevelRect,
      CurrentColor, CurrentColor, BorderWidth);
  end;
  Bevel.Paint(BitmapCanvas, BevelRect);
  BitmapCanvas.CopyRect(BevelRect,
    FBackImageOrg.Canvas, BitmapRect(FBackImageOrg));
  Value := GetOffsetByValue(Position);
  if Orientation = voVertical then
    SetThumbTop(Value) else SetThumbLeft(Value);
  DestRect := BevelRect;
  SrcRect := BitmapRect(FBackImageNew);
  if Orientation = voVertical then
  begin
    if Style = ssBottomLeft then
    begin
      DestRect.Top := FThumbRect.Top + FThumbHeight div 2;
      SrcRect.Top := DestRect.Top - BevelRect.Top;
    end else
    begin
      DestRect.Bottom := FThumbRect.Bottom - FThumbHeight div 2;
      SrcRect.Bottom := HeightOf(DestRect);
    end;
  end else
  begin
    if Style = ssBottomLeft then
    begin
      DestRect.Right := FThumbRect.Left + FThumbWidth div 2;
      SrcRect.Right := WidthOf(DestRect);
    end else
    begin
      DestRect.Left := FThumbRect.Right - FThumbWidth div 2;
      SrcRect.Left := DestRect.Left - BevelRect.Left;
    end;
  end;
  BitmapCanvas.CopyRect(DestRect, FBackImageNew.Canvas, SrcRect);
  PaintThumb;
  inherited Paint;
end;
procedure TVrSlider.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 soThumbOpaque in Options then Brush.Style := bsSolid
    else Brush.Style := bsClear;
    BrushCopy(FThumbRect, FThumbImage, SrcRect, TransColor);
  end;
end;
procedure TVrSlider.DrawVert(Canvas: TCanvas; Rect: TRect;
  Color: TColor);
var
  R: TRect;
  X, Y, W, I, Cnt: Integer;
  OffsetValue: Integer;
  Bm: TBitmap;
begin
  with Canvas do
  begin
    W := WidthOf(Rect);
    Cnt := (HeightOf(Rect) div (TickWidth + Spacing)) + 1;
    X := Rect.Left;
    if Style = ssBottomLeft then
    begin
      Y := Rect.Bottom - TickWidth;
      OffsetValue := -(TickWidth + Spacing);
    end else
    begin
      Y := Rect.Top;
      OffsetValue := TickWidth + Spacing;
    end;
    Brush.Color := Self.Color;
    FillRect(Rect);
    Bm := nil;
    if not SolidFill then
      Bm := CreateLCDImage(W, TickWidth, Color, Self.Color)
    else Brush.Color := Color;
    for I := 0 to Cnt do
    begin
      R := Bounds(X, Y, W, TickWidth);
      if SolidFill then FillRect(R)
      else CopyRect(R, Bm.Canvas, BitmapRect(Bm));
      Inc(Y, OffsetValue);
    end;
    if Bm <> nil then Bm.Free;
  end;
end;
procedure TVrSlider.DrawHorz(Canvas: TCanvas; Rect: TRect;
  Color: TColor);
var
  R: TRect;
  X, Y, I, H, Cnt: Integer;
  OffsetValue: Integer;
  Bm: TBitmap;
begin
  with Canvas do
  begin
    H := HeightOf(Rect);
    Cnt := (WidthOf(Rect) div (TickWidth + Spacing)) + 1;
    Y := Rect.Top;
    if FStyle = ssBottomLeft then
    begin
      X := Rect.Left;
      OffsetValue := (TickWidth + Spacing);
    end
    else
    begin
      X := Rect.Right - TickWidth;
      OffsetValue := -(TickWidth + Spacing);
    end;
    Brush.Color := Self.Color;
    FillRect(Rect);
    Bm := nil;
    if not SolidFill then
      Bm := CreateLCDImage(TickWidth, H, Color, Self.Color)
    else Brush.Color := Color;
    for I := 0 to Cnt do
    begin
      R := Bounds(X, Y, TickWidth, H);
      if SolidFill then FillRect(R)
      else CopyRect(R, Bm.Canvas, BitmapRect(Bm));
      Inc(X, OffsetValue);
    end;
    if Bm <> nil then Bm.Free;
  end;
end;
procedure TVrSlider.CreateBackImages;
var
  W, H: Integer;
  PaintRect: TRect;
begin
  PaintRect := GetSliderRect;
  InflateRect(PaintRect, ThumbIndent, ThumbIndent);
  Bevel.GetVisibleArea(PaintRect);
  W := WidthOf(PaintRect);
  H := HeightOf(PaintRect);
  with FBackImageOrg do
  begin
    Width := W;
    Height := H;
  end;
  with FBackImageNew do
  begin
    Width := W;
    Height := H;
  end;
  if Orientation = voVertical then
  begin
    DrawVert(FBackImageOrg.Canvas, BitmapRect(FBackImageOrg), Palette[0]);
    DrawVert(FBackImageNew.Canvas, BitmapRect(FBackImageNew), Palette[1]);
  end else
  begin
    DrawHorz(FBackImageOrg.Canvas, BitmapRect(FBackImageOrg), Palette[0]);
    DrawHorz(FBackImageNew.Canvas, BitmapRect(FBackImageNew), Palette[1]);
  end;
end;
procedure TVrSlider.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;
procedure TVrSlider.WMSize(var Message: TWMSize);
begin
  inherited;
  CreateBackImages;
  CenterThumb;
  UpdateControlCanvas;
end;
procedure TVrSlider.WMSetCursor(var Message: TWMSetCursor);
var
  P: TPoint;
begin
  GetCursorPos(P);
  if (not Designing) and PtInRect(FThumbRect, ScreenToClient(P)) then
  begin
    if (soHandPoint in Options) then
      Windows.SetCursor(Screen.Cursors[VrCursorHandPoint]);
  end else inherited;
end;
procedure TVrSlider.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 TVrSlider.WMGetDlgCode(var Msg: TWMGetDlgCode);
begin
  Msg.Result := DLGC_WANTARROWS;
end;
procedure TVrSlider.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  UpdateControlCanvas;
end;
procedure TVrSlider.CMColorChanged(var Message: TMessage);
begin
  inherited;
  if (HandleAllocated) then
  begin
    CreateBackImages;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.BevelChanged(Sender: TObject);
begin
  if not Loading then
    CreateBackImages;
  UpdateControlCanvas;
end;
procedure TVrSlider.SetBevel(Value: TVrBevel);
begin
  FBevel.Assign(Value);
end;
procedure TVrSlider.PaletteModified(Sender: TObject);
begin
  if not Loading then CreateBackImages;
  UpdateControlCanvas;
end;
procedure TVrSlider.SetPalette(Value: TVrPalette);
begin
  FPalette.Assign(Value);
end;
procedure TVrSlider.BitmapListChanged(Sender: TObject);
begin
  GetThumbImage;
  UpdateControlCanvas;
end;
procedure TVrSlider.SetThumbImageIndex(Value: Integer);
begin
  if FThumbImageIndex <> Value then
  begin
    FThumbImageIndex := Value;
    if not Loading then
      GetThumbImage;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetBitmapList(Value: TVrBitmapList);
begin
  if FBitmapList <> nil then
    FBitmapList.RemoveLink(FBitmapListLink);
  FBitmapList := Value;
  if FBitmapList <> nil then
    FBitmapList.InsertLink(FBitmapListLink);
  if not Loading then
  begin
    GetThumbImage;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetMinValue(Value: Integer);
begin
  if FMinValue <> Value then
  begin
    FMinValue := Value;
    if Position < FMinValue then
      Position := FMinValue
    else UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetMaxValue(Value: Integer);
begin
  if FMaxValue <> Value then
  begin
    FMaxValue := Value;
    if Position > FMaxValue then
      Position := FMaxValue
    else UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetPosition(Value: Integer);
begin
  if Value < FMinValue then Value := FMinValue;
  if Value > FMaxValue then Value := FMaxValue;
  if FPosition <> Value then
  begin
    FPosition := Value;
    UpdateControlCanvas;
    Changed;
  end;
end;
procedure TVrSlider.SetSpacing(Value: Integer);
begin
  if (FSpacing <> Value) and (Value > -1) then
  begin
    FSpacing := Value;
    if not Loading then
      CreateBackImages;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetTickWidth(Value: Integer);
begin
  if (FTickWidth <> Value) and (Value > 0) then
  begin
    FTickWidth := Value;
    if not Loading then
      CreateBackImages;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetSolidFill(Value: Boolean);
begin
  if FSolidFill <> Value then
  begin
    FSolidFill := Value;
    if not Loading then
      CreateBackImages;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetOrientation(Value: TVrOrientation);
begin
  if FOrientation <> Value then
  begin
    FOrientation := Value;
    if not Loading then
    begin
      BoundsRect := Bounds(Left, Top, Height, Width);
      if Height = Width then
        CreateBackImages;
      GetThumbImage;
    end;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetStyle(Value: TVrSliderStyle);
begin
  if FStyle <> Value then
  begin
    FStyle := Value;
    if not Loading then
      CreateBackImages;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetOptions(Value: TVrSliderOptions);
begin
  if FOptions <> Value then
  begin
    FOptions := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetBorderColor(Value: TColor);
begin
  if FBorderColor <> Value then
  begin
    FBorderColor := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetBorderWidth(Value: Integer);
begin
  if (FBorderWidth <> Value) and (Value >= 0) then
  begin
    FBorderWidth := Value;
    if not Loading then
      CreateBackImages;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetFocusColor(Value: TColor);
begin
  if FFocusColor <> Value then
  begin
    FFocusColor := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetThumbStates(Value: TVrNumGlyphs);
begin
  if FThumbStates <> Value then
  begin
    FThumbStates := Value;
    if not Loading then
      GetThumbImage;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.SetThumbIndent(Value: Integer);
begin
  if (FThumbIndent <> Value) and (Value >= 0) then
  begin
    FThumbIndent := Value;
    UpdateControlCanvas;
  end;
end;
procedure TVrSlider.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 (soMouseClip in Options) then
      begin
        R := Bounds(ClientOrigin.X, ClientOrigin.Y,
          ClientWidth, ClientHeight);
        ClipCursor(@R);
        FClipOn := True;
      end;
      UpdateControlCanvas;
    end
    else
    if (soActiveClick 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 TVrSlider.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 TVrSlider.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 TVrSlider.KeyDown(var Key: Word; Shift: TShiftState);
  function Adjust(Value: Integer): Integer;
  begin
    Result := Value;
    if Style = ssTopRight then Result := -Result;
  end;
begin
  if Shift = [] then
  begin
    if Key = VK_HOME then Position := MinValue
    else if Key = VK_END then Position := MaxValue;
    if Orientation = voHorizontal then
    begin
      if Key = VK_LEFT then Position := Position + Adjust(-FKeyIncrement)
      else if Key = VK_RIGHT then Position := Position + Adjust(FKeyIncrement);
    end
    else
    begin
      if Key = VK_UP then Position := Position + Adjust(FKeyIncrement)
      else if Key = VK_DOWN then Position := Position + Adjust(-FKeyIncrement);
    end;
  end;
  inherited KeyDown(Key, Shift);
end;
end.

						