home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / kompon / d123456 / CHEMPLOT.ZIP / Misc / Slidebar.pas < prev    next >
Pascal/Delphi Source File  |  2001-05-02  |  31KB  |  971 lines
  1. unit Slidebar;
  2.  
  3. interface
  4.  
  5. {$I Misc.inc}
  6.  
  7. {-----------------------------------------------------------------------------
  8. 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
  9.  
  10. http://www.mozilla.org/MPL/MPL-1.1.html
  11.  
  12. 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.
  13.  
  14. The Original Code is: Slidebar.pas, released 1 July 2000.
  15.  
  16. The Initial Developer of the Original Code is Mat Ballard.
  17. Portions created by Mat Ballard are Copyright (C) 1999 Mat Ballard.
  18. Portions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.
  19. All Rights Reserved.
  20.  
  21. Contributor(s): Mat Ballard                 e-mail: mat.ballard@chemware.hypermart.net.
  22.  
  23. Last Modified: 11/09/2000
  24. Current Version: 2.00
  25.  
  26. You may retrieve the latest version of this file from:
  27.  
  28.         http://Chemware.hypermart.net/
  29.  
  30. This work was created with the Project JEDI VCL guidelines:
  31.  
  32.         http://www.delphi-jedi.org/Jedi:VCLVCL
  33.  
  34. in mind. 
  35.  
  36.  
  37. Purpose:
  38. This unit contains the TSlider sub-component: a look-alike for the TrackBar
  39. win32 control, for portability across D1 through Kylix
  40.  
  41. Known Issues:
  42. -----------------------------------------------------------------------------}
  43.  
  44. uses
  45.   Classes, SysUtils,
  46. {$IFDEF WINDOWS}
  47.   WinTypes, WinProcs,
  48.   Controls, ExtCtrls, Graphics
  49. {$ENDIF}
  50. {$IFDEF WIN32}
  51.   Windows,
  52.   Controls, ExtCtrls, Graphics
  53. {$ENDIF}
  54. {$IFDEF LINUX}
  55.   QControls, QExtCtrls, QGraphics,
  56.   Types
  57. {$ENDIF}
  58.   ;
  59.  
  60. type
  61.   TSlideBar = class(TGraphicControl)
  62.     private
  63.       FAutoSlider: Boolean;
  64.       FBevelInner: TPanelBevel;
  65.       FBevelOuter: TPanelBevel;
  66.       FBevelWidth: TBevelWidth;
  67.       FBorderWidth: TBorderWidth;
  68.       FColor: TColor;
  69.       FMax: Integer;
  70.       FMin: Integer;
  71.       FSlideColor: TColor;
  72.       FPageSize: Integer;
  73.       FPosition: Integer;
  74.       FShowText: Boolean;
  75.       FShowUnits: Boolean;
  76.       FSliderWidth: Byte;
  77.       FSliderHeight: Byte;
  78.       FTicks: Byte;
  79.  
  80.       FOnChange:      TnotifyEvent;
  81.       FOnChanging:    TnotifyEvent;
  82.  
  83.       LeftGap, TopGap: Integer;
  84.       StartX: Integer;
  85.       SlideX: Integer;
  86.       IsSliding: Boolean;
  87.  
  88.       function GetFont: TFont;
  89.       function GetFrequency: Integer;
  90.       function GetVertex(Index: Byte): TPoint;
  91.       function GetInnerVertex(Index: Byte): TPoint;
  92.       
  93.     protected
  94.       procedure DrawSlider;
  95. {Draws the sliders}
  96.  
  97.       procedure SetAutoSlider(Value: Boolean);
  98.       procedure SetBevelInner(Value: TPanelBevel);
  99.       procedure SetBevelOuter(Value: TPanelBevel);
  100.       procedure SetBevelWidth(Value: TBevelWidth);
  101.       procedure SetBorderWidth(Value: TBorderWidth);
  102.       procedure SetColor(Value: TColor);
  103.       procedure SetFont(Value: TFont);
  104.       procedure SetFrequency(Value: Integer);
  105.       procedure SetMin(Value: Integer);
  106.       procedure SetMax(Value: Integer);
  107.       procedure SetPosition(Value: Integer);
  108.       procedure SetTicks(Value: Byte);
  109.       procedure SetShowUnits(Value: Boolean);
  110.       procedure SetSlideColor(Value: TColor);
  111.       procedure SetSlideHeight(Value: Byte);
  112.       procedure SetSlideWidth(Value: Byte);
  113.       procedure SetShowText(Value: Boolean);
  114.  
  115.       procedure DoGeometry(ACanvas: TCanvas);
  116.  
  117.       procedure DblClick; override;
  118.       procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  119.       procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  120.       procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  121.  
  122.       procedure Paint; override;
  123.  
  124.       procedure DoChange; dynamic;
  125.       procedure DoChanging; dynamic;
  126.  
  127.     public
  128.       constructor   Create(AOwner: TComponent); override;
  129.       destructor    Destroy; override;
  130.  
  131.     published
  132.       property AutoSlider: Boolean read FAutoSlider write SetAutoSlider;
  133. {Shall we scale everything automagically ?}
  134.       property BevelInner: TPanelBevel read FBevelInner write SetBevelInner;
  135. {Standard Delphi property, though not in the base class.}
  136.       property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter;
  137. {Standard Delphi property, though not in the base class.}
  138.       property BevelWidth: TBevelWidth read FBevelWidth write SetBevelWidth;
  139. {Standard Delphi property, though not in the base class.}
  140.       property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth;
  141. {Standard Delphi property, though not in the base class.}
  142.       property Color: TColor read FColor write SetColor;
  143. {Standard Delphi property, though not in the base class.}
  144.       property Font: TFont read GetFont write SetFont;
  145. {Standard Delphi property, though not in the base class explicitly.}
  146. {}
  147. {Is there implicitly through the Canvas property.}
  148.       property Frequency: Integer read GetFrequency write SetFrequency;
  149. {The interval between ticks: same as TTrackBar.Frequency.}
  150.       property Max: Integer read FMax write SetMax;
  151. {The maximum value of Position, and hence of the slide.}
  152.       property Min: Integer read FMin write SetMin;
  153. {The minimum value of Position, and hence of the slide.}
  154.       property PageSize: Integer read FPageSize write FPageSize;
  155. {The major increment when right-clicked: similar to TTrackBar.Frequency.}
  156.       property Position: Integer read FPosition write SetPosition;
  157. {The value of the Slide: same as TTrackBar.Position.}
  158.       property ShowText: Boolean read FShowText write SetShowText;
  159. {Shall we annotate the Slide with values ?}
  160.       property ShowUnits: Boolean read FShowUnits write SetShowUnits;
  161. {Shall we display tick marks on the slide ?}
  162.       property SliderWidth: Byte read FSliderWidth write SetSlideWidth;
  163. {The size (Width) of the Slide moniker.}
  164.       property SliderHeight: Byte read FSliderHeight write SetSlideHeight;
  165. {The size (Height) of the Slide moniker.}
  166.       property Ticks: Byte read FTicks write SetTicks;
  167. {The number of divisions of the Slide.}
  168.       property SlideColor: TColor read FSlideColor write SetSlideColor;
  169. {The Color of the Slide moniker.}
  170.  
  171.       property OnChanging: TnotifyEvent read FOnChanging write FOnChanging;
  172. {This event is triggered when the slide is slid.}
  173.       property OnChange: TnotifyEvent read FOnChange write FOnChange;
  174. {This event is triggered when the position is changed.}
  175.  
  176.       property Align;
  177.       property Cursor;
  178.       property Enabled;
  179.       property Height;
  180.       property Hint;
  181.       property Left;
  182.       property ParentShowHint;
  183.       property ShowHint;
  184.       property Top;
  185.       property Visible;
  186.       property Width;
  187.  
  188. {$IFDEF DELPHI2_UP}
  189. {$ENDIF}
  190. {$IFDEF DELPHI3_UP}
  191. {$ENDIF}
  192. {$IFDEF DELPHI4_UP}
  193.       property Anchors;
  194.       property Constraints;
  195. {$ENDIF}
  196. {$IFDEF DELPHI5_UP}
  197. {$ENDIF}
  198.   end;
  199.  
  200. implementation
  201.  
  202. {------------------------------------------------------------------------------
  203.     Procedure: TNEdit.Create
  204.   Description: standard constructor
  205.        Author: Mat Ballard
  206.  Date created: 11/09/2000
  207. Date modified: 11/09/2000 by Mat Ballard
  208.       Purpose: sets initial values
  209.  Known Issues:
  210.  ------------------------------------------------------------------------------}
  211. constructor TSlideBar.Create;
  212. begin
  213.   inherited Create(AOwner);
  214.   ControlStyle := [csCaptureMouse, csClickEvents, {csSetCaption,} csDoubleClicks];
  215.   Font.Name  :=  'Arial';
  216.   Font.Size  :=  6;
  217.   Hint := 'Left-click ▒ 1, Right-click ▒ 10, Double-click to leap, or Click-n-Drag';
  218.  
  219.   FAutoSlider := TRUE;
  220.   FBevelInner := bvNone;
  221.   FBevelOuter := bvRaised;
  222.   FBevelWidth := 1;
  223.   FBorderWidth := 1;
  224.   FColor := clBtnFace;
  225.   FMax := 100;
  226.   FMin := 0;
  227.   FPageSize := 10;
  228.   FPosition := 50;
  229.   FShowText := TRUE;
  230.   FShowUnits := TRUE;
  231.   FSliderWidth := 6;
  232.   FSliderHeight := 15;
  233.   FTicks := 5;
  234.   FSlideColor := clBtnFace;
  235.  
  236.   Width := 200;
  237.   Height := 40;
  238. end;
  239.  
  240. {------------------------------------------------------------------------------
  241.     Procedure: TNEdit.Destroy
  242.   Description: standard destructor
  243.        Author: Mat Ballard
  244.  Date created: 11/09/2000
  245. Date modified: 11/09/2000 by Mat Ballard
  246.       Purpose: cleanup
  247.  Known Issues:
  248.  ------------------------------------------------------------------------------}
  249. destructor TSlideBar.Destroy;
  250. begin
  251.   inherited Destroy;
  252. end;
  253.  
  254. {Standard Get functions -------------------------------------------------------}
  255. {------------------------------------------------------------------------------
  256.      Function: TSlideBar.GetFont
  257.   Description: standard property Get function
  258.        Author: Mat Ballard
  259.  Date created: 11/09/2000
  260. Date modified: 11/09/2000 by Mat Ballard
  261.       Purpose: gets the Font Property
  262.  Return Value: TFont
  263.  Known Issues:
  264.  ------------------------------------------------------------------------------}
  265. function TSlideBar.GetFont: TFont;
  266. begin
  267.   Result := Canvas.Font;
  268. end;
  269.  
  270. {------------------------------------------------------------------------------
  271.      Function: TSlideBar.GetFrequency
  272.   Description: standard property Get function
  273.        Author: Mat Ballard
  274.  Date created: 11/09/2000
  275. Date modified: 11/09/2000 by Mat Ballard
  276.       Purpose: gets the value of the Frequency Property
  277.  Return Value: Integer
  278.  Known Issues: see also: Ticks property
  279.  ------------------------------------------------------------------------------}
  280. function  TSlideBar.GetFrequency: Integer;
  281. begin
  282.   GetFrequency := (FMax - FMin) div FTicks;
  283. end;
  284.  
  285. {Standard Set procedures ------------------------------------------------------}
  286. {------------------------------------------------------------------------------
  287.     Procedure: TSlideBar.SetAutoSlider
  288.   Description: standard property Set procedure
  289.        Author: Mat Ballard
  290.  Date created: 11/09/2000
  291. Date modified: 11/09/2000 by Mat Ballard
  292.       Purpose: sets the AutoSlider Property
  293.  Known Issues:
  294.  ------------------------------------------------------------------------------}
  295. procedure TSlideBar.SetAutoSlider(Value: Boolean);
  296. begin
  297.   FAutoSlider := Value;
  298.   InValidate;
  299. end;
  300.  
  301. {------------------------------------------------------------------------------
  302.     Procedure: TSlideBar.SetBevelInner
  303.   Description: standard property Set procedure
  304.        Author: Mat Ballard
  305.  Date created: 11/09/2000
  306. Date modified: 11/09/2000 by Mat Ballard
  307.       Purpose: sets the BevelInner Property
  308.  Known Issues:
  309.  ------------------------------------------------------------------------------}
  310. procedure TSlideBar.SetBevelInner(Value: TPanelBevel);
  311. begin
  312.   FBevelInner := Value;
  313.   Invalidate;
  314. end;
  315.  
  316. {------------------------------------------------------------------------------
  317.     Procedure: TSlideBar.SetBevelOuter
  318.   Description: standard property Set procedure
  319.        Author: Mat Ballard
  320.  Date created: 11/09/2000
  321. Date modified: 11/09/2000 by Mat Ballard
  322.       Purpose: sets the BevelOuter Property
  323.  Known Issues:
  324.  ------------------------------------------------------------------------------}
  325. procedure TSlideBar.SetBevelOuter(Value: TPanelBevel);
  326. begin
  327.   FBevelOuter := Value;
  328.   Invalidate;
  329. end;
  330.  
  331. {------------------------------------------------------------------------------
  332.     Procedure: TSlideBar.SetBevelWidth
  333.   Description: standard property Set procedure
  334.        Author: Mat Ballard
  335.  Date created: 11/09/2000
  336. Date modified: 11/09/2000 by Mat Ballard
  337.       Purpose: sets the BevelWidth Property
  338.  Known Issues:
  339.  ------------------------------------------------------------------------------}
  340. procedure TSlideBar.SetBevelWidth(Value: TBevelWidth);
  341. begin
  342.   FBevelWidth := Value;
  343.   Invalidate;
  344. end;
  345.  
  346. {------------------------------------------------------------------------------
  347.     Procedure: TSlideBar.SetBorderWidth
  348.   Description: standard property Set procedure
  349.        Author: Mat Ballard
  350.  Date created: 11/09/2000
  351. Date modified: 11/09/2000 by Mat Ballard
  352.       Purpose: sets the BorderWidth Property
  353.  Known Issues:
  354.  ------------------------------------------------------------------------------}
  355. procedure TSlideBar.SetBorderWidth(Value: TBorderWidth);
  356. begin
  357.   FBorderWidth := Value;
  358.   Invalidate;
  359. end;
  360.  
  361. {------------------------------------------------------------------------------
  362.     Procedure: TSlideBar.SetColor
  363.   Description: standard property Set procedure
  364.        Author: Mat Ballard
  365.  Date created: 11/09/2000
  366. Date modified: 11/09/2000 by Mat Ballard
  367.       Purpose: sets the Color Property
  368.  Known Issues:
  369.  ------------------------------------------------------------------------------}
  370. procedure TSlideBar.SetColor(Value: TColor);
  371. begin
  372.   FColor := Value;
  373.   InValidate;
  374. end;
  375.  
  376. {------------------------------------------------------------------------------
  377.     Procedure: TSlideBar.SetFont
  378.   Description: standard property Set procedure
  379.        Author: Mat Ballard
  380.  Date created: 11/09/2000
  381. Date modified: 11/09/2000 by Mat Ballard
  382.       Purpose: sets the Font Property
  383.  Known Issues:
  384.  ------------------------------------------------------------------------------}
  385. procedure TSlideBar.SetFont(Value: TFont);
  386. begin
  387.   Canvas.Font.Assign(Value);
  388.   Invalidate;
  389. end;
  390.  
  391. {------------------------------------------------------------------------------
  392.     Procedure: TSlideBar.SetFrequency
  393.   Description: standard property Set procedure
  394.        Author: Mat Ballard
  395.  Date created: 11/09/2000
  396. Date modified: 11/09/2000 by Mat Ballard
  397.       Purpose: sets the Frequency Property
  398.  Known Issues: see also: Ticks property
  399.  ------------------------------------------------------------------------------}
  400. procedure TSlideBar.SetFrequency(Value: Integer);
  401. begin
  402.   if ((Value > 0) and
  403.       (Value < (FMax - FMin))) then
  404.   begin
  405.     FTicks := (FMax - FMin) div Value;
  406.     Invalidate;
  407.   end;
  408. end;
  409.  
  410. {------------------------------------------------------------------------------
  411.     Procedure: TSlideBar.SetMin
  412.   Description: standard property Set procedure
  413.        Author: Mat Ballard
  414.  Date created: 11/09/2000
  415. Date modified: 11/09/2000 by Mat Ballard
  416.       Purpose: sets the Min Property
  417.  Known Issues:
  418.  ------------------------------------------------------------------------------}
  419. procedure TSlideBar.SetMin(Value: Integer);
  420. begin
  421.   if (Value < FMax) then
  422.   begin
  423.     FMin := Value;
  424.     if (FPosition < Value) then
  425.       FPosition := Value;
  426.     InValidate;
  427.   end;
  428. end;
  429.  
  430. {------------------------------------------------------------------------------
  431.     Procedure: TSlideBar.SetMax
  432.   Description: standard property Set procedure
  433.        Author: Mat Ballard
  434.  Date created: 11/09/2000
  435. Date modified: 11/09/2000 by Mat Ballard
  436.       Purpose: sets the Max Property
  437.  Known Issues:
  438.  ------------------------------------------------------------------------------}
  439. procedure TSlideBar.SetMax(Value: Integer);
  440. begin
  441.   if (Value > FMin) then
  442.   begin
  443.     FMax := Value;
  444.     if (FPosition > Value) then
  445.       FPosition := Value;
  446.     InValidate;
  447.   end;
  448. end;
  449.  
  450. {------------------------------------------------------------------------------
  451.     Procedure: TSlideBar.SetPosition
  452.   Description: standard property Set procedure
  453.        Author: Mat Ballard
  454.  Date created: 11/09/2000
  455. Date modified: 11/09/2000 by Mat Ballard
  456.       Purpose: sets the Position Property
  457.  Known Issues:
  458.  ------------------------------------------------------------------------------}
  459. procedure TSlideBar.SetPosition(Value: Integer);
  460. begin
  461.   if (Value < FMin) then Value := FMin;
  462.   if (Value > FMax) then Value := FMax;
  463.   FPosition := Value;
  464.   DoChange;
  465.   InValidate;
  466. end;
  467.  
  468. {------------------------------------------------------------------------------
  469.     Procedure: TSlideBar.SetShowText
  470.   Description: standard property Set procedure
  471.        Author: Mat Ballard
  472.  Date created: 11/09/2000
  473. Date modified: 11/09/2000 by Mat Ballard
  474.       Purpose: sets the ShowText Property
  475.  Known Issues:
  476.  ------------------------------------------------------------------------------}
  477. procedure  TSlideBar.SetShowText(Value: Boolean);
  478. begin
  479.   FShowText := Value;
  480.   InValidate;
  481. end;
  482.  
  483. {------------------------------------------------------------------------------
  484.     Procedure: TSlideBar.SetShowUnits
  485.   Description: standard property Set procedure
  486.        Author: Mat Ballard
  487.  Date created: 11/09/2000
  488. Date modified: 11/09/2000 by Mat Ballard
  489.       Purpose: sets the ShowUnits Property
  490.  Known Issues:
  491.  ------------------------------------------------------------------------------}
  492. procedure TSlideBar.SetShowUnits(Value: Boolean);
  493. begin
  494.   FShowUnits := Value;
  495.   InValidate;
  496. end;
  497.  
  498. {------------------------------------------------------------------------------
  499.     Procedure: TSlideBar.SetSlideColor
  500.   Description: standard property Set procedure
  501.        Author: Mat Ballard
  502.  Date created: 11/09/2000
  503. Date modified: 11/09/2000 by Mat Ballard
  504.       Purpose: sets the SlideColor Property
  505.  Known Issues:
  506.  ------------------------------------------------------------------------------}
  507. procedure TSlideBar.SetSlideColor(Value: TColor);
  508. begin
  509.   FSlideColor := Value;
  510.   InValidate;
  511. end;
  512.  
  513. {------------------------------------------------------------------------------
  514.     Procedure: TSlideBar.SetSlideHeight
  515.   Description: standard property Set procedure
  516.        Author: Mat Ballard
  517.  Date created: 11/09/2000
  518. Date modified: 11/09/2000 by Mat Ballard
  519.       Purpose: sets the SlideHeight Property
  520.  Known Issues: limit the height a bit
  521.  ------------------------------------------------------------------------------}
  522. procedure TSlideBar.SetSlideHeight(Value: Byte);
  523. begin
  524.   if (Value > Height div 2) then
  525.     FSliderHeight := Height div 2
  526.   else
  527.     FSliderHeight := Value;
  528.   SetAutoSlider(False);
  529.   Invalidate;
  530. end;
  531.  
  532. {------------------------------------------------------------------------------
  533.     Procedure: TSlideBar.SetSlideWidth
  534.   Description: standard property Set procedure
  535.        Author: Mat Ballard
  536.  Date created: 11/09/2000
  537. Date modified: 11/09/2000 by Mat Ballard
  538.       Purpose: sets the SlideWidth Property
  539.  Known Issues: limits the slider width
  540.  ------------------------------------------------------------------------------}
  541. procedure TSlideBar.SetSlideWidth(Value: Byte);
  542. begin
  543.   if (Value > Width div 4) then
  544.     FSliderWidth := Width div 2
  545.   else
  546.     FSliderWidth := Value;
  547.   SetAutoSlider(False);
  548.   Invalidate
  549. end;
  550.  
  551. {------------------------------------------------------------------------------
  552.     Procedure: TSlideBar.SetTicks
  553.   Description: standard property Set procedure
  554.        Author: Mat Ballard
  555.  Date created: 11/09/2000
  556. Date modified: 11/09/2000 by Mat Ballard
  557.       Purpose: sets the Ticks Property
  558.  Known Issues: see also: Frequency property
  559.  ------------------------------------------------------------------------------}
  560. procedure TSlideBar.SetTicks(Value: Byte);
  561. begin
  562.   if (Value > 0) then
  563.   begin
  564.     FTicks := Value;
  565.     InValidate;
  566.   end;
  567. end;
  568.  
  569. {Mouse madness ----------------------------------------------------------------}
  570. {------------------------------------------------------------------------------
  571.     Procedure: TNEdit.MouseDown
  572.   Description: standard MouseDown event handler
  573.        Author: Mat Ballard
  574.  Date created: 11/09/2000
  575. Date modified: 11/09/2000 by Mat Ballard
  576.       Purpose: examines Button, determines IsSliding: was the Slider clicked ?
  577.  Known Issues:
  578.  ------------------------------------------------------------------------------}
  579. procedure  TSlideBar.MouseDown(
  580.   Button: TMouseButton;
  581.   Shift: TShiftState;
  582.   X, Y: Integer);
  583. begin
  584.   StartX := X;
  585.   IsSliding := FALSE;
  586.   if (mbLeft = Button) then
  587.   begin
  588.     if (Y < TopGap + FSliderHeight) then
  589.       if (SlideX - FSliderWidth div 2 <= X) then
  590.         if (X <= SlideX + FSliderWidth div 2) then
  591.     begin
  592. {need the left button on the slider image for visual sliding}
  593.       IsSliding := TRUE;
  594.     end
  595.   end;
  596. end;
  597.  
  598. {------------------------------------------------------------------------------
  599.     Procedure: TSlideBar.MouseMove
  600.   Description: standard MouseMove event handler
  601.        Author: Mat Ballard
  602.  Date created: 11/09/2000
  603. Date modified: 11/09/2000 by Mat Ballard
  604.       Purpose: Are we sliding the Slider ?
  605.  Known Issues:
  606.  ------------------------------------------------------------------------------}
  607. procedure  TSlideBar.MouseMove(
  608.   Shift: TShiftState;
  609.   X, Y: Integer);
  610. var
  611.   NewX: Single;
  612. begin
  613.   if (IsSliding) then
  614.   begin
  615.     NewX := FMin +
  616.       (FMax-FMin) *
  617.       (X - LeftGap) / (Width - 2*LeftGap);
  618.     SetPosition(Round(NewX));
  619.     DoChanging;
  620.   end;
  621. end;
  622.  
  623. {------------------------------------------------------------------------------
  624.     Procedure: TSlideBar.MouseUp
  625.   Description: standard MouseUp event handler
  626.        Author: Mat Ballard
  627.  Date created: 11/09/2000
  628. Date modified: 11/09/2000 by Mat Ballard
  629.       Purpose: How far will we move ?
  630.  Known Issues:
  631.  ------------------------------------------------------------------------------}
  632. procedure  TSlideBar.MouseUp(
  633.   Button: TMouseButton;
  634.   Shift: TShiftState;
  635.   X, Y: Integer);
  636. begin
  637.   if (IsSliding) then
  638.     IsSliding := FALSE
  639.   else
  640.   begin
  641.     if (mbLeft = Button) then
  642.     begin
  643.       if (X < SlideX) then
  644.         SetPosition(FPosition - 1)
  645.       else if  (X > SlideX) then
  646.         SetPosition(FPosition + 1);
  647.     end
  648.     else if (mbRight = Button) then
  649.     begin
  650.       if (X < SlideX) then
  651.         SetPosition(FPosition - FPageSize)
  652.       else if  (X > SlideX) then
  653.         SetPosition(FPosition + FPageSize);
  654.     end;
  655.     Invalidate;
  656.   end;
  657. end;
  658.  
  659. {------------------------------------------------------------------------------
  660.     Procedure: TSlideBar.DblClick
  661.   Description: standard DblClick event handler
  662.        Author: Mat Ballard
  663.  Date created: 11/09/2000
  664. Date modified: 11/09/2000 by Mat Ballard
  665.       Purpose: Leap to the double-click position
  666.  Known Issues:
  667.  ------------------------------------------------------------------------------}
  668. procedure TSlideBar.DblClick;
  669. var
  670.   NewX: Single;
  671. begin
  672.   NewX := FMin +
  673.     (FMax-FMin) *
  674.     (StartX - LeftGap) / (Width - 2*LeftGap);
  675.   SetPosition(Round(NewX));
  676. end;
  677.  
  678. {Geometry functions and procedures --------------------------------------------}
  679. {------------------------------------------------------------------------------
  680.     Procedure: TSlideBar.DoGeometry
  681.   Description: manages the geometry of the control
  682.        Author: Mat Ballard
  683.  Date created: 11/09/2000
  684. Date modified: 11/09/2000 by Mat Ballard
  685.       Purpose: flower arranging
  686.  Known Issues:
  687.  ------------------------------------------------------------------------------}
  688. procedure TSlideBar.DoGeometry(ACanvas: TCanvas);
  689. begin
  690.   if FAutoSlider then begin
  691.     FSliderHeight := 2*Height div 5;
  692.     FSliderWidth := FSliderHeight div 3;
  693.     if ((FSliderWidth mod 2) > 0) then
  694.       Inc(FSliderWidth);
  695.     Font.Height := Height div 3;
  696.   end;
  697.  
  698.   LeftGap := FSliderWidth +
  699.     ACanvas.TextWidth(IntToStr(FMin)+IntToStr(FMax)) div 2;
  700.   TopGap := 4;
  701.   if BevelOuter <> bvNone then
  702.   begin
  703.     Inc(LeftGap, BevelWidth);
  704.     Inc(TopGap, BevelWidth);
  705.   end;
  706.   if BevelInner <> bvNone then
  707.   begin
  708.     Inc(LeftGap, BevelWidth);
  709.     Inc(TopGap, BevelWidth);
  710.   end;
  711.   SlideX := Round(LeftGap +
  712.     (Width-2*LeftGap)*
  713.     (FPosition-FMin)/(FMax - FMin));
  714. end;
  715.  
  716. {------------------------------------------------------------------------------
  717.      Function: TSlideBar.GetInnerVertex
  718.   Description: gets the position just inside a Vertex of the Slider
  719.        Author: Mat Ballard
  720.  Date created: 11/09/2000
  721. Date modified: 11/09/2000 by Mat Ballard
  722.       Purpose: geometry management
  723.  Return Value: TPoint
  724.  Known Issues: see GetVertex
  725.  ------------------------------------------------------------------------------}
  726. function TSlideBar.GetInnerVertex(Index: Byte): TPoint;
  727. var
  728.   SlideTop: Integer;
  729. begin
  730.   SlideTop := TopGap - 2;
  731.   case Index of
  732.     1:
  733.       begin
  734.         Result.x := SlideX - FSliderWidth div 2 + 1;
  735.         Result.y := SlideTop + 1;
  736.       end;
  737.     2:
  738.       begin
  739.         Result.x := SlideX - FSliderWidth div 2 + 1;
  740.         Result.y := SlideTop + FSliderHeight - FSliderWidth div 2;
  741.       end;
  742.     3:
  743.       begin
  744.         Result.x := SlideX;
  745.         Result.y := SlideTop + FSliderHeight - 1;
  746.       end;
  747.     4:
  748.       begin
  749.         Result.x := SlideX + FSliderWidth div 2 - 1;
  750.         Result.y := SlideTop + FSliderHeight - FSliderWidth div 2;
  751.       end;
  752.     5:
  753.       begin
  754.         Result.x := SlideX + FSliderWidth div 2 - 1;
  755.         Result.y := SlideTop + 1;
  756.       end;
  757.   end;
  758. end;
  759.  
  760. {------------------------------------------------------------------------------
  761.      Function: TSlideBar.GetVertex
  762.   Description: gets the position of a Vertex of the Slider
  763.        Author: Mat Ballard
  764.  Date created: 11/09/2000
  765. Date modified: 11/09/2000 by Mat Ballard
  766.       Purpose: geometry management
  767.  Return Value: TPoint
  768.  Known Issues: see GetInnerVertex
  769.  ------------------------------------------------------------------------------}
  770. function TSlideBar.GetVertex(Index: Byte): TPoint;
  771. var
  772.   SlideTop: Integer;
  773. begin
  774. {    1---------5
  775.      |         |
  776.      |         |
  777.      2         4
  778.       \       /
  779.        \     /
  780.         \   /
  781.           3        }
  782.   SlideTop := TopGap - 2;
  783.   case Index of
  784.     1:
  785.       begin
  786.         Result.x := SlideX - FSliderWidth div 2;
  787.         Result.y := SlideTop;
  788.       end;
  789.     2:
  790.       begin
  791.         Result.x := SlideX - FSliderWidth div 2;
  792.         Result.y := SlideTop + FSliderHeight - FSliderWidth div 2;
  793.       end;
  794.     3:
  795.       begin
  796.         Result.x := SlideX;
  797.         Result.y := SlideTop + FSliderHeight;
  798.       end;
  799.     4:
  800.       begin
  801.         Result.x := SlideX + FSliderWidth div 2;
  802.         Result.y := SlideTop + FSliderHeight - FSliderWidth div 2;
  803.       end;
  804.     5:
  805.       begin
  806.         Result.x := SlideX + FSliderWidth div 2;
  807.         Result.y := SlideTop;
  808.       end;
  809.   end;
  810. end;
  811.  
  812. {Screen operations ------------------------------------------------------------}
  813. {------------------------------------------------------------------------------
  814.     Procedure: TSlideBar.Paint
  815.   Description: standard Paint procedure
  816.        Author: Mat Ballard
  817.  Date created: 11/09/2000
  818. Date modified: 11/09/2000 by Mat Ballard
  819.       Purpose: Screen drawing
  820.  Known Issues:
  821.  ------------------------------------------------------------------------------}
  822. procedure TSlideBar.Paint;
  823. var
  824.   TheRect: TRect;
  825.   TopColor, BottomColor: TColor;
  826.   i,
  827.   iX,
  828.   iY, iYY,
  829.   SlideWidth: Integer;
  830.   TheFrame  : TRect;
  831.   TheString: String;
  832.  
  833.   procedure AdjustColors(Bevel: TPanelBevel);
  834.   begin
  835.     TopColor := clBtnHighlight;
  836.     if Bevel = bvLowered then TopColor := clBtnShadow;
  837.     BottomColor := clBtnShadow;
  838.     if Bevel = bvLowered then BottomColor := clBtnHighlight;
  839.   end;
  840.  
  841. begin
  842.   TheRect := GetClientRect;
  843.  
  844.   DoGeometry(Canvas);
  845.  
  846.   Canvas.Brush.Color := FColor;
  847.   Canvas.FillRect(TheRect);
  848.  
  849. {Draw the bevels, if needed, using Borland's standard method:}
  850.   if BevelOuter <> bvNone then
  851.   begin
  852.     AdjustColors(BevelOuter);
  853.     Frame3D(Canvas, TheRect, TopColor, BottomColor, BevelWidth);
  854.   end;
  855.   Frame3D(Canvas, TheRect, Color, Color, BorderWidth);
  856.   if BevelInner <> bvNone then
  857.   begin
  858.     AdjustColors(BevelInner);
  859.     Frame3D(Canvas, TheRect, TopColor, BottomColor, BevelWidth);
  860.   end;
  861.  
  862.   SlideWidth := Width - 2*LeftGap;
  863.   iX := LeftGap;
  864.   iY := TopGap;
  865.  
  866. {draw the open rectangle:}
  867.   TheFrame := Rect(iX-2, iY-2, iX+SlideWidth+2, iY+FSliderWidth+2);
  868.   Frame3D(Canvas, TheFrame , clBtnShadow, clWhite, 1);
  869.   TheFrame := Rect(iX-1, iY-1, iX+SlideWidth+1, iY+FSliderWidth+1);
  870.   Frame3D(Canvas, TheFrame , clBlack, clBtnFace, 1);
  871.   Canvas.Brush.Color := clWhite;
  872.   TheFrame := Rect(iX, iY, iX+SlideWidth, iY+FSliderWidth);
  873.   Canvas.FillRect(TheFrame);
  874.   Canvas.Brush.Color := FColor;
  875.  
  876.   iY := iY + FSliderWidth + 4;
  877.   iYY := TopGap - 2 + FSliderHeight;
  878.   if FShowUnits then
  879.   begin
  880.     for i := 0 to FTicks do
  881.     begin
  882.       iX := LeftGap + i*SlideWidth div FTicks;
  883.       Canvas.Pen.Color := clBtnShadow;
  884.       Canvas.MoveTo(iX, iY);
  885.       Canvas.LineTo(iX, iYY);
  886.       Canvas.Pen.Color := clBtnHighLight;
  887.       Canvas.MoveTo(iX+1, iY);
  888.       Canvas.LineTo(iX+1, iYY);
  889.     end;
  890.   end;
  891.  
  892.   if FShowText then
  893.   begin
  894.     for i := 0 to FTicks do
  895.     begin
  896.       iX := LeftGap + i*SlideWidth div FTicks + 1;
  897.       iY := FMin + i*((FMax-FMin) div FTicks);
  898.       TheString := IntToStr(iY);
  899.       Canvas.TextOut(iX - Canvas.TextWidth(TheString) div 2, iYY, TheString);
  900.     end;
  901.   end;
  902.  
  903.   DrawSlider;
  904. end;
  905.  
  906. {------------------------------------------------------------------------------
  907.     Procedure: TSlideBar.DrawSlider
  908.   Description: draws the Slider
  909.        Author: Mat Ballard
  910.  Date created: 11/09/2000
  911. Date modified: 11/09/2000 by Mat Ballard
  912.       Purpose: Screen drawing
  913.  Known Issues:
  914.  ------------------------------------------------------------------------------}
  915. procedure TSlideBar.DrawSlider;
  916. begin
  917.   With Canvas do
  918.     begin
  919.       Pen.Color := clBlack;
  920.       Pen.Width := 1;
  921.       Brush.Color := FSlideColor;
  922.       PolyGon([GetVertex(1),
  923.                GetVertex(2),
  924.                GetVertex(3),
  925.                GetVertex(4),
  926.                GetVertex(5)]);
  927.  
  928.       Pen.Color := clBtnHighLight;
  929.       PolyLine([GetInnerVertex(5),
  930.                 GetInnerVertex(1),
  931.                 GetInnerVertex(2),
  932.                 GetInnerVertex(3)]);
  933.  
  934.       Pen.Color := clBtnShadow;
  935.       PolyLine([GetInnerVertex(3),
  936.                 GetInnerVertex(4),
  937.                 GetInnerVertex(5)]);
  938.   end;
  939. end;
  940.  
  941. {Event handlers ---------------------------------------------------------------}
  942. {------------------------------------------------------------------------------
  943.     Procedure: TSlideBar.DoChange
  944.   Description: standard event handler
  945.        Author: Mat Ballard
  946.  Date created: 11/09/2000
  947. Date modified: 11/09/2000 by Mat Ballard
  948.       Purpose: informs user of when Position changes
  949.  Known Issues:
  950.  ------------------------------------------------------------------------------}
  951. procedure TSlideBar.DoChange;
  952. begin
  953.   if Assigned(FOnChange) then FOnChange(Self);
  954. end;
  955.  
  956. {------------------------------------------------------------------------------
  957.     Procedure: TSlideBar.DoChanging
  958.   Description: standard event handler
  959.        Author: Mat Ballard
  960.  Date created: 11/09/2000
  961. Date modified: 11/09/2000 by Mat Ballard
  962.       Purpose: informs user of when Slider is slid
  963.  Known Issues:
  964.  ------------------------------------------------------------------------------}
  965. procedure TSlideBar.DoChanging;
  966. begin
  967.   if Assigned(FOnChanging) then FOnChanging(Self);
  968. end;
  969.  
  970. end.
  971.