home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 26 / CD_ASCQ_26_1295.iso / vrac / psslider.zip / SLIDER.INT < prev    next >
Text File  |  1995-06-06  |  8KB  |  207 lines
  1. unit Slider;
  2.  
  3. {This is the source of the Slider component of the Perseus VCP. If you purchase
  4.  at least 2 copies of this component you'll receive it with your registered
  5.  version!
  6.  
  7.  Copyright ⌐ 1995: Sebastian Modersohn
  8.                    Softwaredevelopment
  9.                    Heinestrasse 20
  10.                    D 15370 Petershagen
  11.                    Phone: ++49 33439 7462
  12.                    CIS ID: 100340,1474
  13.  
  14.  Written by: Sebastian Modersohn
  15.  
  16.  The source is nearly undocumented, so if you have questions to details, just
  17.  contact us via CompuServe and we'll help you (if we can <g>).}
  18.  
  19. {$DEFINE UNREGISTERED}
  20.  
  21. interface
  22.  
  23. uses
  24.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  25.   Forms, Dialogs, Buttons,
  26.   Face, PSCCtl;
  27.  
  28. type
  29.   TFrame = (None, Raised, Lowered);
  30.   TOrientation = (Horizontal, Vertical);
  31.   TThumbStyle = (PointerUp, PointerDown, Rect, Square, OwnerDraw);
  32.   TScalePosition = (AboveOrLeft, BelowOrRight, Both);
  33.   TScaleOrig = (Inner, Outer);
  34.   TFocusAction = (faNone, faFocusRect, faFocusColor, faBoth);
  35.  
  36.   TThumbDrawEvent = procedure (Sender: TObject; Canvas: TCanvas) of object;
  37.  
  38.   TThumb = class(TGraphicControl)
  39.   private
  40.     RetainPos: Integer;
  41.     ScaleLength: Integer;
  42.     bPressed: Boolean;
  43.     constructor Create(AOwner: TComponent); override;
  44.   protected
  45.     procedure Paint; override;
  46.  
  47.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  48.       X, Y: Integer); override;
  49.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  50.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  51.       X, Y: Integer); override;
  52.  
  53.   end;
  54.  
  55.   TSlider = class(TPSCustomControl)
  56.   private
  57.     RetainValue: Integer;
  58.     bScrolling: Byte;{ 0=none; 1=up; 2=down}
  59.     ThumbPos: Integer;
  60.  
  61.     OThumb: TThumb;
  62.     FFocusAction: TFocusAction;
  63.     FFrame: TFrame;
  64.     FFrameStyle: TFaceStyle;
  65.     FFrameSize: Byte;
  66.     FOrientation: TOrientation;
  67.     FGroove: TFrame;
  68.     FGrooveStyle: TFaceStyle;
  69.     FGrooveSize: Byte;
  70.     FGrooveFill: Boolean;
  71.     FGrooveColor: TColor;
  72.     FThumb: TThumbStyle;
  73.     FThumbSize: Byte;
  74.     FThumbStyle: TFaceStyle;
  75.     FThumbFill: Boolean;
  76.     FThumbColor: TColor;
  77.     FMin, FMax, FStep, FCur: Integer;
  78.     FScale: Boolean;
  79.     FTicks: Byte;
  80.     FEnlarge: Byte;
  81.     FScaleHeight: Byte;
  82.     FConnect: Boolean;
  83.     FScaleOrig: TScaleOrig;
  84.     FScaleColor: TColor;
  85.     FScalePosition: TScalePosition;
  86.     FScaleDistance: Integer;
  87.     FDisabledColor: TColor;
  88.     FFocusColor: TColor;
  89.  
  90.     EOnSelect: TNotifyEvent;
  91.     EOnTrack: TNotifyEvent;
  92.     EOnDrawThumb: TThumbDrawEvent;
  93.   public
  94.     constructor Create(AOwner: TComponent); override;
  95.   protected
  96.     procedure Paint; override;
  97.     procedure DrawThumb;
  98.  
  99.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  100.       X, Y: Integer); override;
  101.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  102.       X, Y: Integer); override;
  103.  
  104.     procedure WMTimer(var Message: TWMTimer); message WM_Timer;
  105.     procedure WMGetDlgCode(var Message: TMessage); message WM_GetDlgCode;
  106.     procedure WMSetFocus(var Message: TWMSetFocus); message WM_SetFocus;
  107.     procedure WMKillFocus(var Message: TWMKillFocus); message WM_KillFocus;
  108.  
  109.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  110.   private
  111.     function CreateThumb: TThumb;
  112.     procedure AdjustThumbSize(var Thumb: TThumb);
  113.     procedure CalcThumbPos;
  114.     procedure SetThumbPos;
  115.     procedure SetThumbByTimer(Check: boolean);
  116.  
  117.     procedure CalcSize(var Message: TMessage); message wm_Size;
  118.  
  119.     procedure SetFocusAction(Value: TFocusAction);
  120.     procedure SetDisabledColor(Value: TColor);
  121.     procedure SetFocusColor(Value: TColor);
  122.     procedure SetFrame(Value: TFrame);
  123.     procedure SetFrameStyle(Value: TFaceStyle);
  124.     procedure SetFrameSize(Value: Byte);
  125.     procedure SetOrientation(Value: TOrientation);
  126.     procedure SetGroove(Value: TFrame);
  127.     procedure SetGrooveStyle(Value: TFaceStyle);
  128.     procedure SetGrooveSize(Value: Byte);
  129.     procedure SetGrooveFill(Value: Boolean);
  130.     procedure SetGrooveColor(Value: TColor);
  131.     procedure SetThumb(Value: TThumbStyle);
  132.     procedure SetThumbSize(Value: Byte);
  133.     procedure SetThumbStyle(Value: TFaceStyle);
  134.     procedure SetThumbFill(Value: Boolean);
  135.     procedure SetThumbColor(Value: TColor);
  136.     procedure SetMin(Value: Integer);
  137.     procedure SetMax(Value: Integer);
  138.     procedure SetStep(Value: Integer);
  139.     procedure SetCur(Value: Integer);
  140.     procedure SetScale(Value: Boolean);
  141.     procedure SetTicks(Value: Byte);
  142.     procedure SetEnlarge(Value: Byte);
  143.     procedure SetScaleHeight(Value: Byte);
  144.     procedure SetScaleConnect(Value: Boolean);
  145.     procedure SetScaleOrig(Value: TScaleOrig);
  146.     procedure SetScaleColor(Value: TColor);
  147.     procedure SetScalePosition(Value: TScalePosition);
  148.     procedure SetScaleDistance(Value: Integer);
  149.  
  150.   published
  151.     property ShowHint;
  152.     property ParentShowHint;
  153.     property Color;
  154.     property ParentColor default True;
  155.     property TabStop default True;
  156.     property DragCursor;
  157.     property DragMode;
  158.  
  159.     property FocusAction: TFocusAction read FFocusAction write SetFocusAction default faFocusRect;
  160.     property Frame: TFrame read FFrame write SetFrame default Lowered;
  161.     property FrameStyle: TFaceStyle read FFrameStyle write SetFrameStyle default fsWin95;
  162.     property FrameSize: Byte read FFrameSize write SetFrameSize default 5;
  163.     property Orientation: TOrientation read FOrientation write SetOrientation default Horizontal;
  164.     property Groove: TFrame read FGroove write SetGroove default Lowered;
  165.     property GrooveStyle: TFaceStyle read FGrooveStyle write SetGrooveStyle default fsWin95;
  166.     property GrooveSize: Byte read FGrooveSize write SetGrooveSize default 6;
  167.     property GrooveFill: Boolean read FGrooveFill write SetGrooveFill default True;
  168.     property GrooveColor: TColor read FGrooveColor write SetGrooveColor default clBtnFace;
  169.     property Thumb: TThumbStyle read FThumb write SetThumb default PointerDown;
  170.     property ThumbSize: Byte read FThumbSize write SetThumbSize default 25;
  171.     property ThumbStyle: TFaceStyle read FThumbStyle write SetThumbStyle default fsWin95;
  172.     property ThumbFill: Boolean read FThumbFill write SetThumbFill default True;
  173.     property ThumbColor: TColor read FThumbColor write SetThumbColor default clBtnFace;
  174.     property Position: Integer read FCur write SetCur default 0;
  175.     property PositionMin: Integer read FMin write SetMin default 0;
  176.     property PositionMax: Integer read FMax write SetMax default 100;
  177.     property PositionStep: Integer read FStep write SetStep default 1;
  178.     property Scale: Boolean read FScale write SetScale default True;
  179.     property ScaleTicks: Byte read FTicks write SetTicks default 10;
  180.     property ScaleTicksEnlargeEvery: Byte read FEnlarge write SetEnlarge default 5;
  181.     property ScaleHeight: Byte read FScaleHeight write SetScaleHeight default 7;
  182.     property ScaleConnect: Boolean read FConnect write SetScaleConnect default True;
  183.     property ScaleOrig: TScaleOrig read FScaleOrig write SetScaleOrig default Outer;
  184.     property ScaleColor: TColor read FScaleColor write SetScaleColor default clBlack;
  185.     property ScalePosition: TScalePosition read FScalePosition write SetScalePosition default BelowOrRight;
  186.     property ScaleDistance: Integer read FScaleDistance write SetScaleDistance default 10;
  187.     property DisabledColor: TColor read FDisabledColor write SetDisabledColor default clGrayText;
  188.     property FocusColor: TColor read FFocusColor write SetFocusColor default clActiveCaption;
  189.  
  190.     property OnMouseDown;
  191.     property OnMouseMove;
  192.     property OnMouseUp;
  193.     property OnDragDrop;
  194.     property OnDragOver;
  195.     property OnEndDrag;
  196.     property OnKeyDown;
  197.     property OnKeyPress;
  198.     property OnKeyUp;
  199.  
  200.     property OnSelect: TNotifyEvent read EOnSelect write EOnSelect;
  201.     property OnTrack: TNotifyEvent read EOnTrack write EOnTrack;
  202.     property OnDrawThumb: TThumbDrawEvent read EOnDrawThumb write EOnDrawThumb;
  203.   end;
  204.  
  205. procedure Register;
  206.  
  207. implementation