unit Slider;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs;

type
  TSliderOrientation = (slHoriz, slVertical);
  TSlider = class(TCustomControl)
  private
    Thumb : TRect;
    MemDC : HDC;
    Bitmap : HBitmap;

    capture : boolean;
    capturePoint : TPoint;
    captureValue : Integer;

    fTrackWidth : Integer;
    fTrackColor : TColor;
    fOrientation : TSliderOrientation;
    fThumbHeight : Integer;
    fThumbColor : TColor;
    fMin : Integer;
    fMax : Integer;
    fValue : Integer;
    fValueChange : TNotifyEvent;
    fCtl3D : boolean;
    procedure SetTrackWidth (value : Integer);
    procedure SetTrackColor (value : TColor);
    procedure SetOrientation (value : TSliderOrientation);
    procedure SetThumbHeight (value : Integer);
    procedure SetThumbColor (value : TColor);
    procedure SetMin (v : Integer);
    procedure SetMax (v : Integer);
    procedure SetValue (value : Integer);
    procedure SetCtl3D (value : boolean);
  protected
    procedure Paint; override;
    procedure MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove (Shift: TShiftState; X, Y: Integer); override;
    procedure DrawThumb; virtual;
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
  published
    property TrackWidth : Integer read fTrackWidth write SetTrackWidth;
    property TrackColor : TColor read fTrackColor write SetTrackColor;
    property ThumbHeight : Integer read fThumbHeight write SetThumbHeight;
    property ThumbColor : TColor read fThumbColor write SetThumbColor;
    property Orientation : TSliderOrientation read fOrientation write SetOrientation;
    property Minimum : Integer read fMin write SetMin;
    property Maximum : Integer read fMax write SetMax;
    property Value : Integer read fValue write SetValue;
    property Ctl3D : boolean read fCtl3D write SetCtl3D;
    property OnValueChange : TNotifyEvent read fValueChange write fValueChange;

    property Color;
    property Enabled;
    property HelpContext;
    property Hint;
    property ParentShowHint;
    property ShowHint;
    property Tag;
    property Visible;

    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;

  end;

procedure Register;

implementation

constructor TSlider.Create (AOwner : TComponent);
begin
  inherited Create (AOwner);
  Width := 50;
  Height := 200;
  fTrackWidth := 10;
  fOrientation := slVertical;
  fTrackColor := clBtnFace;
  fThumbColor := clBtnFace;
  fMin := 0;
  fMax := 100;
  fValue := 0;
  fThumbHeight := 20;
  fValueChange := Nil;
  fCtl3D := True;
  capture := False;
  thumb.left := -1;
end;

destructor TSlider.Destroy;
begin
  if Bitmap <> 0 then DeleteObject (Bitmap);
  if MemDC <> 0 then DeleteDC (MemDC);
  inherited Destroy
end;

procedure TSlider.SetTrackWidth (value : Integer);
begin
  if fTrackWidth <> value then
  begin
    fTrackWidth := value;
    Invalidate
  end
end;

procedure TSlider.SetOrientation (value : TSliderOrientation);
begin
  if value <> fOrientation then
  begin
    fOrientation := value;
    Invalidate
  end
end;

procedure TSlider.SetTrackColor (value : TColor);
begin
  if value <> fTrackColor then
  begin
    fTrackColor := value;
    Invalidate
  end
end;

procedure TSlider.SetThumbHeight (value : Integer);
begin
  if value <> fThumbHeight then
  begin
    fThumbHeight := value;
    Invalidate
  end
end;

procedure TSlider.SetThumbColor (value : TColor);
begin
  if value <> fThumbColor then
  begin
    fThumbColor := value;
    Invalidate
  end
end;

procedure TSlider.SetMin (v : Integer);
begin
  if v <> fMin then
  begin
    fMin := V;
    if Value < fMin then Value := fMin;
    Invalidate
  end
end;

procedure TSlider.SetMax (v : Integer);
begin
  if v <> fMax then
  begin
    fMax := V;
    if Value > fMax then Value := fMax;
    Invalidate
  end
end;

procedure TSlider.SetValue (value : Integer);
begin
  if value < Minimum then value := Minimum
  else if value > Maximum then value := Maximum;

  if value <> fValue then
  begin
    fValue := Value;
    if Assigned (fValueChange) then OnValueChange (self);
    DrawThumb
  end
end;

procedure TSlider.SetCtl3D (value : boolean);
begin
  if value <> fCtl3D then
  begin
    fCtl3D := value;
    Invalidate
  end
end;
 

procedure TSlider.Paint;
var Rect : TRect;
begin
  with Canvas do
  begin
    if MemDC = 0 then MemDC := CreateCompatibleDC (Canvas.Handle);

    if fOrientation = slVertical then
    begin
      if Bitmap = 0 then
       Bitmap := CreateCompatibleBitmap (Canvas.Handle, Width, ThumbHeight);
      Rect.top := 0;
      Rect.bottom := Height;
      Rect.left := (Width - TrackWidth) div 2;
      Rect.Right := Rect.Left + TrackWidth
    end
    else
    begin
      if Bitmap = 0 then
       Bitmap := CreateCompatibleBitmap (Canvas.Handle, ThumbHeight, Height);
      Rect.top := (Height - TrackWidth) div 2;
      Rect.bottom := Rect.Top + TrackWidth;
      Rect.left := 0;
      Rect.Right := Width
    end;

    Brush.Color := TrackColor;
    if Ctl3D then
    begin
      Pen.Color := clBtnHighlight;
      with Rect do
      begin
        Rectangle (left, top, right, bottom);
        Pen.Color := clBtnShadow;
        MoveTo (left, top);
        LineTo (right, top);
        MoveTo (left, top);
        LineTo (left, bottom)
      end
    end
    else FillRect (Rect);
    DrawThumb;

  end
end;

procedure TSlider.DrawThumb;
var
  basePos : Integer;
  rc : bool;
  oldBmp : HBitmap;
  oldThumb : TRect;
begin
  if csLoading in ComponentState then Exit;
  oldBmp := SelectObject (MemDC, Bitmap);

  if Enabled then Canvas.Brush.Color := ThumbColor
  else Canvas.Brush.Color := clGray;
  if Ctl3D then Canvas.Pen.Color := clBtnHighlight
  else Canvas.Pen.Color := clBlack;
  oldThumb := Thumb;

  if Orientation = slVertical then
  begin
    basePos := (Height - ThumbHeight) * (Value - Minimum)
     div (Maximum - Minimum);
    Thumb.left := 0;
    Thumb.right := Width;
    Thumb.Bottom := Height - BasePos;
    Thumb.top := Thumb.Bottom - ThumbHeight;
    if oldThumb.left <> -1 then with oldThumb do
      BitBlt (Canvas.Handle, Left, Top, Width, ThumbHeight, MemDC, 0, 0, SRCCOPY);

    with Thumb do
      rc := BitBlt (MemDC, 0, 0, Width, ThumbHeight, Canvas.Handle, Left, Top, SRCCOPY);
  end
  else
  begin
    basePos := (Width - ThumbHeight) * (Value - Minimum) div (Maximum - Minimum);
    Thumb.left := basePos;
    Thumb.Right := Thumb.left + ThumbHeight;
    Thumb.Top := 0;
    Thumb.Bottom := Height;
    if oldThumb.left <> -1 then with oldThumb do
      BitBlt (Canvas.Handle, Left, Top, ThumbHeight, Height, MemDC, 0, 0, SRCCOPY);

    with Thumb do
      rc := BitBlt (MemDC, 0, 0, ThumbHeight, Height, Canvas.Handle, Left, Top, SRCCOPY);
  end;

  with Canvas do
  begin
    with Thumb do if Ctl3D then
    begin
      Rectangle (left, top, right-1, bottom-1);
      Pen.Color := clBtnShadow;
      MoveTo (Left + 1, Bottom - 3);
      LineTo (Left + 1, Top+1);
      LineTo (Right - 2, Top+1);
      MoveTo (Left, Bottom - 1);
      LineTo (Right-1, Bottom - 1);
      LineTo (Right-1, Top - 1)
    end
    else
      Rectangle (left, top, right, bottom);
  end;

  SelectObject (MemDC, OldBmp);
end;

procedure TSlider.MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseDown (Button, Shift, X, Y);
  if (Button = mbLeft) and PtInRect (Thumb, Point (X, Y)) then
  begin
    capture := True;
    capturePoint := Point (X, Y);
    captureValue := value;
  end;
end;

procedure TSlider.MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseUp (Button, Shift, X, Y);
  if (Button = mbLeft) then capture := False
end;

procedure TSlider.MouseMove (Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseMove (shift, X, Y);
  if capture then
    if Orientation = slVertical then
      value := captureValue + Minimum + (Maximum - Minimum) * (capturePoint.Y - Y) div (Height - ThumbHeight)
    else
      value := captureValue + Minimum + (Maximum - Minimum) * (X - capturePoint.X) div (Width - ThumbHeight);
end;

procedure Register;
begin
  RegisterComponents('Samples', [TSlider]);
end;

end.

TSlider Component Notes
-----------------

By Colin Wilson - woozle@cix.compulink.co.uk

The TSlider object is a representation of a Slider - as used in mixers, lighting
control units, etc.

It defines the following new public properties:

    property TrackWidth : Integer

      The width of the slider track.

    property TrackColor : TColor

      The slider track color.

    property ThumbHeight : Integer

      The height of the Thumb (the bit that slides).  The thumb is always as
      wide as the component - so can be controlled by the Width property.

    property ThumbColor : TColor

      The thumb colour.

    property Orientation : TSliderOrientation

      slHorizontal or slVertical.  Controls whether the slider slider left/right
      or up/down.

    property Minimum : Integer

      The minimum slider value.

    property Maximum : Integer

      The maximum slider value.

    property Value : Integer

      The current slider value.

The following new protected procedure is defined:

  procedure DrawThumb; virtual;

    Can be overriden to draw custom thumbs or thumbs with legends, bitmaps, etc.

The following new event is defined:

  property OnValueChange : TNotifyEvent;

    Called whenever the value changes