Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/slider1/slider.pas

Pascal/Delphi Source File | 1995-12-22 | 20.2 KB | 493 lines

(*-----------------------------------------------------------------------*
 | Slider component for Borland Delphi.                                  |
 |                                                                       |
 | Programmed by Colin Wilson - [e-mail]               |
 *-----------------------------------------------------------------------*)

unit Slider;

interface

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

type
  TSliderOrientation = (slHoriz, slVertical);
  TSlider = class(TCustomControl)
  private
    Thumb : TRect;               { Current thumb position             }
    MemDC : HDC;                 { DC for saving area under the thumb }
    Bitmap : HBitmap;            { Bitmap handle for saved area.      }

    capture : boolean;           { Whether it's currently being moved }
    capturePoint : TPoint;       { Position at start of capture.      }
    captureValue : Integer;      { Value at start of capture.         }

                                 { Property values...                 }
    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);                                    |
 |                                                                         |
 | Create the slider and set initial property values.                      |
 |                                                                         |
 | parameters:                                                             |
 |   AOwner : TComponent              The owner                            |
 *-------------------------------------------------------------------------*)
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                                              |
 |                                                                         |
 | Destroy the slider component.                                           |
 *-------------------------------------------------------------------------*)
destructor TSlider.Destroy;
begin
  if Bitmap <> 0 then DeleteObject (Bitmap);
  if MemDC <> 0 then DeleteDC (MemDC);
  inherited Destroy
end;

(*-------------------------------------------------------------------------*
 | procedure TSlider.SetTrackWidth (value)                                 |
 |                                                                         |
 | Write procedure for TrackWidth property.  Sets the track width (the bit |
 | the thumb slides up and down.                                           |
 |                                                                         |
 | parameters:                                                             |
 |   value : Integer        The new track width value                      |
 *-------------------------------------------------------------------------*)
procedure TSlider.SetTrackWidth (value : Integer);
begin
  if fTrackWidth <> value then
  begin
    fTrackWidth := value;
    Invalidate
  end
end;

(*-------------------------------------------------------------------------*
 | procedure TSlider.SetOrientation (value)                                |
 |                                                                         |
 | Write procedure for Orientation property.  Sets the slider orientation: |
 | slHorizontal or slVertical.                                             |
 |                                                                         |
 | parameters:                                                             |
 |   value : TSliderOrientation The new orientation                        |
 *-------------------------------------------------------------------------*)
procedure TSlider.SetOrientation (value : TSliderOrientation);
begin
  if value <> fOrientation then
  begin
    fOrientation := value;
    Invalidate
  end
end;

(*-------------------------------------------------------------------------*
 | procedure TSlider.SetTrackColor (value)                                 |
 |                                                                         |
 | Write procedure for TrackColor property.  Sets the track colour.        |
 |                                                                         |
 | parameters:                                                             |
 |   value : TColor       The new track colour                             |
 *-------------------------------------------------------------------------*)
procedure TSlider.SetTrackColor (value : TColor);
begin
  if value <> fTrackColor then
  begin
    fTrackColor := value;
    Invalidate
  end
end;

(*-------------------------------------------------------------------------*
 | procedure TSlider.SetThumbHeight (value)                                |
 |                                                                         |
 | Write procedure for ThumbHeight property.  Sets the thumb height (or    |
 | width for horizontal sliders).  nb the thumb is always as wide as the   |
 | component itself.                                                       |
 |                                                                         |
 | parameters:                                                             |
 |   value : Integer       The new thumb height                            |
 *-------------------------------------------------------------------------*)
procedure TSlider.SetThumbHeight (value : Integer);
begin
  if value <> fThumbHeight then
  begin
    fThumbHeight := value;
    Invalidate
  end
end;

(*-------------------------------------------------------------------------*
 | procedure TSlider.SetThumbColor (value)                                 |
 |                                                                         |
 | Write procedure for ThumbColor property.  Sets the thumb colour         |
 |                                                                         |
 | parameters:                                                             |
 |   value : TColor     The new thumb colour                               |
 *-------------------------------------------------------------------------*)
procedure TSlider.SetThumbColor (value : TColor);
begin
  if value <> fThumbColor then
  begin
    fThumbColor := value;
    Invalidate
  end
end;

(*-------------------------------------------------------------------------*
 | procedure TSlider.SetMin (value)                                        |
 |                                                                         |
 | Write procedure for Minimum property.  Sets the minimum value.          |
 |                                                                         |
 | parameters:                                                             |
 |   value : Integer  The new minimum                                      |
 *-------------------------------------------------------------------------*)
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 (value)                                        |
 |                                                                         |
 | Write procedure for Maximum property.  Sets the maximum value.          |
 |                                                                         |
 | parameters:                                                             |
 |   value : Integer  The new maximum                                      |
 *-------------------------------------------------------------------------*)
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)                                      |
 |                                                                         |
 | Write procedure for Value property.  Sets the value, updates the thumb, |
 | and generates an OnValueChange event                                    |
 |                                                                         |
 | parameters:                                                             |
 |   value : Integer  The new value                                        |
 *-------------------------------------------------------------------------*)
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)                                      |
 |                                                                         |
 | Write procedure for Ctl3D property.  Setting this property gives both   |
 | th thumb and the track a 3D look.                                       |
 |                                                                         |
 | parameters:                                                             |
 |   value : Boolean    The new ctl3D value                                |
 *-------------------------------------------------------------------------*)
procedure TSlider.SetCtl3D (value : boolean);
begin
  if value <> fCtl3D then
  begin
    fCtl3D := value;
    Invalidate
  end
end;

(*-------------------------------------------------------------------------*
 | procedure TSlider.Paint                                                 |
 |                                                                         |
 | Paint the entire slider control.                                        |
 *-------------------------------------------------------------------------*)
procedure TSlider.Paint;
var Rect : TRect;
begin
  with Canvas do
  begin                             { Create memory DC for save bitmap }
    if MemDC = 0 then MemDC := CreateCompatibleDC (Canvas.Handle);

                                    { Create thumb & bitmap for vertical slider }
    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
                                    { Create thumb & bitmap for horiz slider }
      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;
                                     { Draw track.                            }
    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);            { Not Ctl3D - do a simple rectangle      }

    DrawThumb;                       { Now draw the thumb.                    }

  end
end;

(*-------------------------------------------------------------------------*
 | procedure TSlider.DrawThumb                                             |
 |                                                                         |
 | Draw the thumb at the correct position for the current value.           |
 *-------------------------------------------------------------------------*)
procedure TSlider.DrawThumb;
var
  basePos : Integer;
  rc : bool;
  oldBmp : HBitmap;
  oldThumb : TRect;
begin
  if csLoading in ComponentState then Exit;

  oldBmp := SelectObject (MemDC, Bitmap);

  { Set thumb color & border color }
  if Enabled then Canvas.Brush.Color := ThumbColor else Canvas.Brush.Color := clGray;
  if Ctl3D then Canvas.Pen.Color := clBtnHighlight else Canvas.Pen.Color := clBlack;

  { Save current thum rectangle }
  oldThumb := Thumb;

  if Orientation = slVertical then
  begin

  { Calculate new thumb rectangle }
    basePos := LongInt (Height - ThumbHeight) * LongInt (Value - Minimum) div (Maximum - Minimum);
    Thumb.left := 0;
    Thumb.right := Width;
    Thumb.Bottom := Height - BasePos;
    Thumb.top := Thumb.Bottom - ThumbHeight;

  { Rub out old thumb             }
    if oldThumb.left <> -1 then with oldThumb do
      BitBlt (Canvas.Handle, Left, Top, Width, ThumbHeight, MemDC, 0, 0, SRCCOPY);

  { Save what's underneath         }
    with Thumb do
      rc := BitBlt (MemDC, 0, 0, Width, ThumbHeight, Canvas.Handle, Left, Top, SRCCOPY);
  end
  else
  begin
  { Calculate new thumb rectangle for horiz slider}
    basePos := LongInt (Width - ThumbHeight) * LongInt(Value - Minimum) div (Maximum - Minimum);
    Thumb.left := basePos;
    Thumb.Right := Thumb.left + ThumbHeight;
    Thumb.Top := 0;
    Thumb.Bottom := Height;

  { Rub out old thumb             }
    if oldThumb.left <> -1 then with oldThumb do
      BitBlt (Canvas.Handle, Left, Top, ThumbHeight, Height, MemDC, 0, 0, SRCCOPY);

  { Save what's underneath         }
    with Thumb do
      rc := BitBlt (MemDC, 0, 0, ThumbHeight, Height, Canvas.Handle, Left, Top, SRCCOPY);
  end;

  { Draw the thumb                 }
  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, Shift, X, Y)                       |
 |                                                                         |
 | Respond to 'MouseDown' events.  Record the position of press for use in |
 | the MouseMove event handler.                                            |
 |                                                                         |
 | Parameters:                                                             |
 |   button : TMouseButton         Set of mouse buttons currently pressed. |
 |   Shift  : TShiftState          Set of shift, ctrl, alt keys            |
 |   X, Y   : Integer              Mouse position relative to top of slider|
 *-------------------------------------------------------------------------*)
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, Shift, X, Y)                         |
 |                                                                         |
 | Respond to 'MouseUp' events                                             |
 |                                                                         |
 | Parameters:                                                             |
 |   button : TMouseButton         Set of mouse buttons currently pressed. |
 |   Shift  : TShiftState          Set of shift, ctrl, alt keys            |
 |   X, Y   : Integer              Mouse position relative to top of slider|
 *-------------------------------------------------------------------------*)
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, X, Y)                               |
 |                                                                         |
 | Respond to 'MouseMove' events                                           |
 |                                                                         |
 | Parameters:                                                             |
 |   Shift  : TShiftState          Set of shift, ctrl, alt keys            |
 |   X, Y   : Integer              Mouse position relative to top of slider|
 *-------------------------------------------------------------------------*)
procedure TSlider.MouseMove (Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseMove (shift, X, Y);
  if capture then
    if Orientation = slVertical then
      value := captureValue + Minimum + LongInt (Maximum - Minimum) * LongInt (capturePoint.Y - Y) div (Height - ThumbHeight)
    else
      value := captureValue + Minimum + LongInt (Maximum - Minimum) * LongInt (X - capturePoint.X) div (Width - ThumbHeight);
end;

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

end.