Chip 2001 October/Chip_2001-10_cd1.bin/zkuste/delphi/kompon/d123456/CHEMPLOT.ZIP/Misc/Slidebar.pas

Pascal/Delphi Source File | 2001-05-02 | 30.4 KB | 971 lines

unit Slidebar;

interface

{$I Misc.inc}

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at

http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for the specific language governing rights and limitations under the License.

The Original Code is: Slidebar.pas, released 1 July 2000.

The Initial Developer of the Original Code is Mat Ballard.
Portions created by Mat Ballard are Copyright (C) 1999 Mat Ballard.
Portions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.
All Rights Reserved.

Contributor(s): Mat Ballard                 e-mail: [e-mail].

Last Modified: 11/09/2000
Current Version: 2.00

You may retrieve the latest version of this file from:

        http://Chemware.hypermart.net/

This work was created with the Project JEDI VCL guidelines:

        http://www.delphi-jedi.org/Jedi:VCLVCL

in mind.


Purpose:
This unit contains the TSlider sub-component: a look-alike for the TrackBar
win32 control, for portability across D1 through Kylix

Known Issues:
-----------------------------------------------------------------------------}

uses
  Classes, SysUtils,
{$IFDEF WINDOWS}
  WinTypes, WinProcs,
  Controls, ExtCtrls, Graphics
{$ENDIF}
{$IFDEF WIN32}
  Windows,
  Controls, ExtCtrls, Graphics
{$ENDIF}
{$IFDEF LINUX}
  QControls, QExtCtrls, QGraphics,
  Types
{$ENDIF}
  ;

type
  TSlideBar = class(TGraphicControl)
    private
      FAutoSlider: Boolean;
      FBevelInner: TPanelBevel;
      FBevelOuter: TPanelBevel;
      FBevelWidth: TBevelWidth;
      FBorderWidth: TBorderWidth;
      FColor: TColor;
      FMax: Integer;
      FMin: Integer;
      FSlideColor: TColor;
      FPageSize: Integer;
      FPosition: Integer;
      FShowText: Boolean;
      FShowUnits: Boolean;
      FSliderWidth: Byte;
      FSliderHeight: Byte;
      FTicks: Byte;

      FOnChange:      TnotifyEvent;
      FOnChanging:    TnotifyEvent;

      LeftGap, TopGap: Integer;
      StartX: Integer;
      SlideX: Integer;
      IsSliding: Boolean;

      function GetFont: TFont;
      function GetFrequency: Integer;
      function GetVertex(Index: Byte): TPoint;
      function GetInnerVertex(Index: Byte): TPoint;

    protected
      procedure DrawSlider;
{Draws the sliders}

      procedure SetAutoSlider(Value: Boolean);
      procedure SetBevelInner(Value: TPanelBevel);
      procedure SetBevelOuter(Value: TPanelBevel);
      procedure SetBevelWidth(Value: TBevelWidth);
      procedure SetBorderWidth(Value: TBorderWidth);
      procedure SetColor(Value: TColor);
      procedure SetFont(Value: TFont);
      procedure SetFrequency(Value: Integer);
      procedure SetMin(Value: Integer);
      procedure SetMax(Value: Integer);
      procedure SetPosition(Value: Integer);
      procedure SetTicks(Value: Byte);
      procedure SetShowUnits(Value: Boolean);
      procedure SetSlideColor(Value: TColor);
      procedure SetSlideHeight(Value: Byte);
      procedure SetSlideWidth(Value: Byte);
      procedure SetShowText(Value: Boolean);

      procedure DoGeometry(ACanvas: TCanvas);

      procedure DblClick; override;
      procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
      procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
      procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;

      procedure Paint; override;

      procedure DoChange; dynamic;
      procedure DoChanging; dynamic;

    public
      constructor   Create(AOwner: TComponent); override;
      destructor    Destroy; override;

    published
      property AutoSlider: Boolean read FAutoSlider write SetAutoSlider;
{Shall we scale everything automagically ?}
      property BevelInner: TPanelBevel read FBevelInner write SetBevelInner;
{Standard Delphi property, though not in the base class.}
      property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter;
{Standard Delphi property, though not in the base class.}
      property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth;
{Standard Delphi property, though not in the base class.}
      property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth;
{Standard Delphi property, though not in the base class.}
      property Color: TColor read FColor write SetColor;
{Standard Delphi property, though not in the base class.}
      property Font: TFont read GetFont write SetFont;
{Standard Delphi property, though not in the base class explicitly.}
{}
{Is there implicitly through the Canvas property.}
      property Frequency: Integer read GetFrequency write SetFrequency;
{The interval between ticks: same as TTrackBar.Frequency.}
      property Max: Integer read FMax write SetMax;
{The maximum value of Position, and hence of the slide.}
      property Min: Integer read FMin write SetMin;
{The minimum value of Position, and hence of the slide.}
      property PageSize: Integer read FPageSize write FPageSize;
{The major increment when right-clicked: similar to TTrackBar.Frequency.}
      property Position: Integer read FPosition write SetPosition;
{The value of the Slide: same as TTrackBar.Position.}
      property ShowText: Boolean read FShowText write SetShowText;
{Shall we annotate the Slide with values ?}
      property ShowUnits: Boolean read FShowUnits write SetShowUnits;
{Shall we display tick marks on the slide ?}
      property SliderWidth: Byte read FSliderWidth write SetSlideWidth;
{The size (Width) of the Slide moniker.}
      property SliderHeight: Byte read FSliderHeight write SetSlideHeight;
{The size (Height) of the Slide moniker.}
      property Ticks: Byte read FTicks write SetTicks;
{The number of divisions of the Slide.}
      property SlideColor: TColor read FSlideColor write SetSlideColor;
{The Color of the Slide moniker.}

      property OnChanging: TnotifyEvent read FOnChanging write FOnChanging;
{This event is triggered when the slide is slid.}
      property OnChange: TnotifyEvent read FOnChange write FOnChange;
{This event is triggered when the position is changed.}

      property Align;
      property Cursor;
      property Enabled;
      property Height;
      property Hint;
      property Left;
      property ParentShowHint;
      property ShowHint;
      property Top;
      property Visible;
      property Width;

{$IFDEF DELPHI2_UP}
{$ENDIF}
{$IFDEF DELPHI3_UP}
{$ENDIF}
{$IFDEF DELPHI4_UP}
      property Anchors;
      property Constraints;
{$ENDIF}
{$IFDEF DELPHI5_UP}
{$ENDIF}
  end;

implementation

{------------------------------------------------------------------------------
    Procedure: TNEdit.Create
  Description: standard constructor
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets initial values
 Known Issues:
 ------------------------------------------------------------------------------}
constructor TSlideBar.Create;
begin
  inherited Create(AOwner);
  ControlStyle := [csCaptureMouse, csClickEvents, {csSetCaption,} csDoubleClicks];
  Font.Name  :=  'Arial';
  Font.Size  :=  6;
  Hint := 'Left-click ▒ 1, Right-click ▒ 10, Double-click to leap, or Click-n-Drag';

  FAutoSlider := TRUE;
  FBevelInner := bvNone;
  FBevelOuter := bvRaised;
  FBevelWidth := 1;
  FBorderWidth := 1;
  FColor := clBtnFace;
  FMax := 100;
  FMin := 0;
  FPageSize := 10;
  FPosition := 50;
  FShowText := TRUE;
  FShowUnits := TRUE;
  FSliderWidth := 6;
  FSliderHeight := 15;
  FTicks := 5;
  FSlideColor := clBtnFace;

  Width := 200;
  Height := 40;
end;

{------------------------------------------------------------------------------
    Procedure: TNEdit.Destroy
  Description: standard destructor
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: cleanup
 Known Issues:
 ------------------------------------------------------------------------------}
destructor TSlideBar.Destroy;
begin
  inherited Destroy;
end;

{Standard Get functions -------------------------------------------------------}
{------------------------------------------------------------------------------
     Function: TSlideBar.GetFont
  Description: standard property Get function
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: gets the Font Property
 Return Value: TFont
 Known Issues:
 ------------------------------------------------------------------------------}
function TSlideBar.GetFont: TFont;
begin
  Result := Canvas.Font;
end;

{------------------------------------------------------------------------------
     Function: TSlideBar.GetFrequency
  Description: standard property Get function
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: gets the value of the Frequency Property
 Return Value: Integer
 Known Issues: see also: Ticks property
 ------------------------------------------------------------------------------}
function  TSlideBar.GetFrequency: Integer;
begin
  GetFrequency := (FMax - FMin) div FTicks;
end;

{Standard Set procedures ------------------------------------------------------}
{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetAutoSlider
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the AutoSlider Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetAutoSlider(Value: Boolean);
begin
  FAutoSlider := Value;
  InValidate;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetBevelInner
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the BevelInner Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetBevelInner(Value: TPanelBevel);
begin
  FBevelInner := Value;
  Invalidate;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetBevelOuter
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the BevelOuter Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetBevelOuter(Value: TPanelBevel);
begin
  FBevelOuter := Value;
  Invalidate;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetBevelWidth
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the BevelWidth Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetBevelWidth(Value: TBevelWidth);
begin
  FBevelWidth := Value;
  Invalidate;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetBorderWidth
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the BorderWidth Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetBorderWidth(Value: TBorderWidth);
begin
  FBorderWidth := Value;
  Invalidate;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetColor
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the Color Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetColor(Value: TColor);
begin
  FColor := Value;
  InValidate;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetFont
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the Font Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetFont(Value: TFont);
begin
  Canvas.Font.Assign(Value);
  Invalidate;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetFrequency
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the Frequency Property
 Known Issues: see also: Ticks property
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetFrequency(Value: Integer);
begin
  if ((Value > 0) and
      (Value < (FMax - FMin))) then
  begin
    FTicks := (FMax - FMin) div Value;
    Invalidate;
  end;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetMin
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the Min Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetMin(Value: Integer);
begin
  if (Value < FMax) then
  begin
    FMin := Value;
    if (FPosition < Value) then
      FPosition := Value;
    InValidate;
  end;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetMax
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the Max Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetMax(Value: Integer);
begin
  if (Value > FMin) then
  begin
    FMax := Value;
    if (FPosition > Value) then
      FPosition := Value;
    InValidate;
  end;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetPosition
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the Position Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetPosition(Value: Integer);
begin
  if (Value < FMin) then Value := FMin;
  if (Value > FMax) then Value := FMax;
  FPosition := Value;
  DoChange;
  InValidate;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetShowText
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the ShowText Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure  TSlideBar.SetShowText(Value: Boolean);
begin
  FShowText := Value;
  InValidate;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetShowUnits
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the ShowUnits Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetShowUnits(Value: Boolean);
begin
  FShowUnits := Value;
  InValidate;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetSlideColor
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the SlideColor Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetSlideColor(Value: TColor);
begin
  FSlideColor := Value;
  InValidate;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetSlideHeight
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the SlideHeight Property
 Known Issues: limit the height a bit
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetSlideHeight(Value: Byte);
begin
  if (Value > Height div 2) then
    FSliderHeight := Height div 2
  else
    FSliderHeight := Value;
  SetAutoSlider(False);
  Invalidate;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetSlideWidth
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the SlideWidth Property
 Known Issues: limits the slider width
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetSlideWidth(Value: Byte);
begin
  if (Value > Width div 4) then
    FSliderWidth := Width div 2
  else
    FSliderWidth := Value;
  SetAutoSlider(False);
  Invalidate
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.SetTicks
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: sets the Ticks Property
 Known Issues: see also: Frequency property
 ------------------------------------------------------------------------------}
procedure TSlideBar.SetTicks(Value: Byte);
begin
  if (Value > 0) then
  begin
    FTicks := Value;
    InValidate;
  end;
end;

{Mouse madness ----------------------------------------------------------------}
{------------------------------------------------------------------------------
    Procedure: TNEdit.MouseDown
  Description: standard MouseDown event handler
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: examines Button, determines IsSliding: was the Slider clicked ?
 Known Issues:
 ------------------------------------------------------------------------------}
procedure  TSlideBar.MouseDown(
  Button: TMouseButton;
  Shift: TShiftState;
  X, Y: Integer);
begin
  StartX := X;
  IsSliding := FALSE;
  if (mbLeft = Button) then
  begin
    if (Y < TopGap + FSliderHeight) then
      if (SlideX - FSliderWidth div 2 <= X) then
        if (X <= SlideX + FSliderWidth div 2) then
    begin
{need the left button on the slider image for visual sliding}
      IsSliding := TRUE;
    end
  end;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.MouseMove
  Description: standard MouseMove event handler
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: Are we sliding the Slider ?
 Known Issues:
 ------------------------------------------------------------------------------}
procedure  TSlideBar.MouseMove(
  Shift: TShiftState;
  X, Y: Integer);
var
  NewX: Single;
begin
  if (IsSliding) then
  begin
    NewX := FMin +
      (FMax-FMin) *
      (X - LeftGap) / (Width - 2*LeftGap);
    SetPosition(Round(NewX));
    DoChanging;
  end;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.MouseUp
  Description: standard MouseUp event handler
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: How far will we move ?
 Known Issues:
 ------------------------------------------------------------------------------}
procedure  TSlideBar.MouseUp(
  Button: TMouseButton;
  Shift: TShiftState;
  X, Y: Integer);
begin
  if (IsSliding) then
    IsSliding := FALSE
  else
  begin
    if (mbLeft = Button) then
    begin
      if (X < SlideX) then
        SetPosition(FPosition - 1)
      else if  (X > SlideX) then
        SetPosition(FPosition + 1);
    end
    else if (mbRight = Button) then
    begin
      if (X < SlideX) then
        SetPosition(FPosition - FPageSize)
      else if  (X > SlideX) then
        SetPosition(FPosition + FPageSize);
    end;
    Invalidate;
  end;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.DblClick
  Description: standard DblClick event handler
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: Leap to the double-click position
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.DblClick;
var
  NewX: Single;
begin
  NewX := FMin +
    (FMax-FMin) *
    (StartX - LeftGap) / (Width - 2*LeftGap);
  SetPosition(Round(NewX));
end;

{Geometry functions and procedures --------------------------------------------}
{------------------------------------------------------------------------------
    Procedure: TSlideBar.DoGeometry
  Description: manages the geometry of the control
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: flower arranging
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.DoGeometry(ACanvas: TCanvas);
begin
  if FAutoSlider then begin
    FSliderHeight := 2*Height div 5;
    FSliderWidth := FSliderHeight div 3;
    if ((FSliderWidth mod 2) > 0) then
      Inc(FSliderWidth);
    Font.Height := Height div 3;
  end;

  LeftGap := FSliderWidth +
    ACanvas.TextWidth(IntToStr(FMin)+IntToStr(FMax)) div 2;
  TopGap := 4;
  if BevelOuter <> bvNone then
  begin
    Inc(LeftGap, BevelWidth);
    Inc(TopGap, BevelWidth);
  end;
  if BevelInner <> bvNone then
  begin
    Inc(LeftGap, BevelWidth);
    Inc(TopGap, BevelWidth);
  end;
  SlideX := Round(LeftGap +
    (Width-2*LeftGap)*
    (FPosition-FMin)/(FMax - FMin));
end;

{------------------------------------------------------------------------------
     Function: TSlideBar.GetInnerVertex
  Description: gets the position just inside a Vertex of the Slider
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: geometry management
 Return Value: TPoint
 Known Issues: see GetVertex
 ------------------------------------------------------------------------------}
function TSlideBar.GetInnerVertex(Index: Byte): TPoint;
var
  SlideTop: Integer;
begin
  SlideTop := TopGap - 2;
  case Index of
    1:
      begin
        Result.x := SlideX - FSliderWidth div 2 + 1;
        Result.y := SlideTop + 1;
      end;
    2:
      begin
        Result.x := SlideX - FSliderWidth div 2 + 1;
        Result.y := SlideTop + FSliderHeight - FSliderWidth div 2;
      end;
    3:
      begin
        Result.x := SlideX;
        Result.y := SlideTop + FSliderHeight - 1;
      end;
    4:
      begin
        Result.x := SlideX + FSliderWidth div 2 - 1;
        Result.y := SlideTop + FSliderHeight - FSliderWidth div 2;
      end;
    5:
      begin
        Result.x := SlideX + FSliderWidth div 2 - 1;
        Result.y := SlideTop + 1;
      end;
  end;
end;

{------------------------------------------------------------------------------
     Function: TSlideBar.GetVertex
  Description: gets the position of a Vertex of the Slider
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: geometry management
 Return Value: TPoint
 Known Issues: see GetInnerVertex
 ------------------------------------------------------------------------------}
function TSlideBar.GetVertex(Index: Byte): TPoint;
var
  SlideTop: Integer;
begin
{    1---------5
     |         |
     |         |
     2         4
      \       /
       \     /
        \   /
          3        }
  SlideTop := TopGap - 2;
  case Index of
    1:
      begin
        Result.x := SlideX - FSliderWidth div 2;
        Result.y := SlideTop;
      end;
    2:
      begin
        Result.x := SlideX - FSliderWidth div 2;
        Result.y := SlideTop + FSliderHeight - FSliderWidth div 2;
      end;
    3:
      begin
        Result.x := SlideX;
        Result.y := SlideTop + FSliderHeight;
      end;
    4:
      begin
        Result.x := SlideX + FSliderWidth div 2;
        Result.y := SlideTop + FSliderHeight - FSliderWidth div 2;
      end;
    5:
      begin
        Result.x := SlideX + FSliderWidth div 2;
        Result.y := SlideTop;
      end;
  end;
end;

{Screen operations ------------------------------------------------------------}
{------------------------------------------------------------------------------
    Procedure: TSlideBar.Paint
  Description: standard Paint procedure
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: Screen drawing
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.Paint;
var
  TheRect: TRect;
  TopColor, BottomColor: TColor;
  i,
  iX,
  iY, iYY,
  SlideWidth: Integer;
  TheFrame  : TRect;
  TheString: String;

  procedure AdjustColors(Bevel: TPanelBevel);
  begin
    TopColor := clBtnHighlight;
    if Bevel = bvLowered then TopColor := clBtnShadow;
    BottomColor := clBtnShadow;
    if Bevel = bvLowered then BottomColor := clBtnHighlight;
  end;

begin
  TheRect := GetClientRect;

  DoGeometry(Canvas);

  Canvas.Brush.Color := FColor;
  Canvas.FillRect(TheRect);

{Draw the bevels, if needed, using Borland's standard method:}
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, TheRect, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, TheRect, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, TheRect, TopColor, BottomColor, BevelWidth);
  end;

  SlideWidth := Width - 2*LeftGap;
  iX := LeftGap;
  iY := TopGap;

{draw the open rectangle:}
  TheFrame := Rect(iX-2, iY-2, iX+SlideWidth+2, iY+FSliderWidth+2);
  Frame3D(Canvas, TheFrame , clBtnShadow, clWhite, 1);
  TheFrame := Rect(iX-1, iY-1, iX+SlideWidth+1, iY+FSliderWidth+1);
  Frame3D(Canvas, TheFrame , clBlack, clBtnFace, 1);
  Canvas.Brush.Color := clWhite;
  TheFrame := Rect(iX, iY, iX+SlideWidth, iY+FSliderWidth);
  Canvas.FillRect(TheFrame);
  Canvas.Brush.Color := FColor;

  iY := iY + FSliderWidth + 4;
  iYY := TopGap - 2 + FSliderHeight;
  if FShowUnits then
  begin
    for i := 0 to FTicks do
    begin
      iX := LeftGap + i*SlideWidth div FTicks;
      Canvas.Pen.Color := clBtnShadow;
      Canvas.MoveTo(iX, iY);
      Canvas.LineTo(iX, iYY);
      Canvas.Pen.Color := clBtnHighLight;
      Canvas.MoveTo(iX+1, iY);
      Canvas.LineTo(iX+1, iYY);
    end;
  end;

  if FShowText then
  begin
    for i := 0 to FTicks do
    begin
      iX := LeftGap + i*SlideWidth div FTicks + 1;
      iY := FMin + i*((FMax-FMin) div FTicks);
      TheString := IntToStr(iY);
      Canvas.TextOut(iX - Canvas.TextWidth(TheString) div 2, iYY, TheString);
    end;
  end;

  DrawSlider;
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.DrawSlider
  Description: draws the Slider
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: Screen drawing
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.DrawSlider;
begin
  With Canvas do
    begin
      Pen.Color := clBlack;
      Pen.Width := 1;
      Brush.Color := FSlideColor;
      PolyGon([GetVertex(1),
               GetVertex(2),
               GetVertex(3),
               GetVertex(4),
               GetVertex(5)]);

      Pen.Color := clBtnHighLight;
      PolyLine([GetInnerVertex(5),
                GetInnerVertex(1),
                GetInnerVertex(2),
                GetInnerVertex(3)]);

      Pen.Color := clBtnShadow;
      PolyLine([GetInnerVertex(3),
                GetInnerVertex(4),
                GetInnerVertex(5)]);
  end;
end;

{Event handlers ---------------------------------------------------------------}
{------------------------------------------------------------------------------
    Procedure: TSlideBar.DoChange
  Description: standard event handler
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: informs user of when Position changes
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.DoChange;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

{------------------------------------------------------------------------------
    Procedure: TSlideBar.DoChanging
  Description: standard event handler
       Author: Mat Ballard
 Date created: 11/09/2000
Date modified: 11/09/2000 by Mat Ballard
      Purpose: informs user of when Slider is slid
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TSlideBar.DoChanging;
begin
  if Assigned(FOnChanging) then FOnChanging(Self);
end;

end.