home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 January / Pcwk0198.iso / Dcomplib / BONANZA.LZH / BONANZA.PAS < prev    next >
Pascal/Delphi Source File  |  1995-10-17  |  15KB  |  492 lines
  1. unit Bonanza;
  2.  
  3. interface
  4.  
  5. {
  6. File:        Bonanza
  7. Project:     Slartibartfrass
  8. Version:     1.00
  9. Author:      Sir Roger McMisteli
  10. Date:        17. October 1995
  11.  
  12. Remarks:     This is a new slider component, which has two separate sliders
  13.              which both can set manually.
  14.              You cannot set the minimum slider at a higher position as the
  15.              maximum slider.
  16.              Please note that this is my first component! If it has bugs,
  17.              well, that's possible. I tested it, but you never know.
  18.              If you have improvements or when bugs occured, please send a mail to
  19.                Roger Misteli
  20.                Zentralstrasse 6
  21.                8400 Winterthur
  22.                Phone: intl - 52 - 212 28 91
  23.                email: archie@ezinfo.vmsmail.ethz.ch
  24.  
  25.              ***********************************************************
  26.              * DON'T USE THIS COMPUSERVE ID, 'CAUSE ITS MY BUSINESS ID *
  27.              * AND IT IT NOT LONGER VALID UNTIL 1. November 1995 !!!!! *
  28.              ***********************************************************
  29.  
  30. Copyright:   The TBonanza component was written by Sir Roger McMisteli
  31.              for a student project. It is absolutely free to the public domain.
  32.              If you want to modify the component, do so. But please mention
  33.              my name in your release as the original author.
  34. }
  35.  
  36. uses
  37.   SysUtils,
  38.   WinTypes,
  39.   WinProcs,
  40.   Messages,
  41.   Classes,
  42.   Graphics,
  43.   Forms,
  44.   Controls,
  45.   Dialogs,
  46.   StdCtrls,
  47.   ExtCtrls,
  48.   DsgnIntf;
  49.  
  50. type
  51.   TSlider      = (esNoChange, esMinimumSlider, esMaximumSlider);
  52.   TOnChange    = procedure (Sender: TObject; var lPosition: Longint; tWhichSlider: TSlider) of object;
  53.   TOnMinMax    = procedure (Sender: TObject; var lPosition: Longint) of object;
  54.   TOnChanging  = procedure (Sender: TObject; var lMinPos, lMaxPos: Longint; tWhichSlider: TSlider) of object;
  55.  
  56. type
  57.   TBonanza = class(TGraphicControl)
  58.     private
  59.       lMaxValue:    Longint;                          {max position of both sliders}
  60.       lMinValue:    Longint;                          {min position ...}
  61.       tMinColor:    TColor;                           {min slider color}
  62.       tMaxColor:    TColor;
  63.       lMinPos:      Longint;                          {min slider position}
  64.       lMaxPos:      Longint;
  65.       bUnits:       Byte;                             {count of units to be drawn}
  66.       fIsLoaded:    Boolean;                          {only for testing...}
  67.       bWUnit:       Byte;                             {internal: width of slider}
  68.       bHUnit:       Byte;
  69.       fShowUnits:   Boolean;                          {draw the unit lines?}
  70.       fAutoSlider:  Boolean;                          {automatic slider dimensions?}
  71.       FOnChange:    TOnChange;
  72.       FOnChanging:  TOnChanging;
  73.       FOnMinChanged:TOnMinMax;
  74.       FOnMaxChanged:TOnMinMax;
  75.       fMinPressed:  Boolean;                          {internal: min slider has been activated}
  76.       fMaxPressed:  Boolean;
  77.       fShowText:    Boolean;
  78.       fShowPanel:   Boolean;
  79.       function      GetMinX: Word;                    {returns min slider position}
  80.       function      GetMaxX: Word;
  81.       procedure     DrawUnits(Canvas: TCanvas);       {draws the unit lines}
  82.       procedure     DrawSliders(Canvas: TCanvas);     {draws the sliders}
  83.       procedure     CreateProcedure; dynamic;
  84.       function      GetPosition(X: Integer): Longint; {internal: returns position (from pixels to units)}
  85.     protected
  86.       procedure     SetMinValue(lValue: Longint);
  87.       procedure     SetMaxValue(lValue: Longint);
  88.       procedure     SetMinColor(tValue: TColor);
  89.       procedure     SetMaxColor(tValue: TColor);
  90.       procedure     SetMaxPos(lValue: Longint);
  91.       procedure     SetMinPos(lValue: Longint);
  92.       procedure     SetUnits(bValue: Byte);
  93.       procedure     SetWUnit(bValue: Byte);
  94.       procedure     SetHUnit(bValue: Byte);
  95.       procedure     SetShowUnits(fValue: Boolean);
  96.       procedure     SetAutoSlider(fValue: Boolean);
  97.       procedure     SetShowText(fValue: Boolean);
  98.       procedure     SetShowPanel(fValue: Boolean);
  99.  
  100.       procedure     MouseMove(Shift: TShiftState; X, Y: Integer); override;
  101.       procedure     MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  102.       procedure     MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  103.       procedure     Paint; override;
  104.       procedure     SetSlider; dynamic;
  105.     public
  106.       constructor   Create(AOwner: TComponent); override;
  107.       procedure     ForcePaint;
  108.       destructor    Destroy; override;
  109.     published
  110.       property      OnChanging: TOnChanging read FOnChanging write FOnChanging;
  111.       property      OnChange: TOnChange read FOnChange write FOnChange;
  112.       property      OnMinChanged: TOnMinMax read FOnMinChanged write FOnMinChanged;
  113.       property      OnMaxChanged: TOnMinMax read FOnMaxChanged write FOnMaxChanged;
  114.  
  115.       property      ShowText: Boolean read fShowText write SetShowText default True;
  116.       property      ShowPanel: Boolean read fShowPanel write SetShowPanel default True;
  117.       property      Height default 30;
  118.       property      Width  default 250;
  119.       property      Top    default 10;
  120.       property      Left   default 10;
  121.       property      Hint;
  122.       property      Font;
  123.       property      Enabled;
  124.       property      Visible;
  125.       property      ShowUnits: Boolean read fShowUnits write SetShowUnits default True;
  126.       property      AutoSlider: Boolean read fAutoSlider write SetAutoSlider default False;
  127.       property      SliderWidth: Byte read bWUnit write SetWUnit default 8;
  128.       property      SliderHeight: Byte read bHUnit write SetHUnit default 15;
  129.       property      Units: Byte read bUnits write SetUnits default 10;
  130.       property      SliderMinColor: TColor read tMinColor write SetMinColor default clRed;
  131.       property      SliderMaxColor: TColor read tMaxColor write SetMaxColor default clBlue;
  132.       property      SliderMaxPos: Longint read lMaxPos write SetMaxPos default 100;
  133.       property      SliderMinPos: Longint read lMinPos write SetMinPos default 0;
  134.       property      MaxValue: Longint read lMaxValue write SetMaxValue default 100;
  135.       property      MinValue: Longint read lMinValue write SetMinValue default 0;
  136.   end;
  137.  
  138. procedure Register;
  139.  
  140. implementation
  141.  
  142. constructor TBonanza.Create;
  143. begin
  144.   inherited Create(AOwner);
  145.   fIsLoaded:=True;
  146.   CreateProcedure;
  147. end;
  148.  
  149. procedure  TBonanza.ForcePaint;
  150. begin
  151.   Paint;
  152. end;
  153.  
  154. procedure  TBonanza.SetShowPanel;
  155. begin
  156.   fShowPanel:=fValue;
  157.   InValidate;
  158. end;
  159.  
  160. function   TBonanza.GetPosition;
  161. begin
  162.   GetPosition:=(Abs(lMaxValue)+Abs(lMinValue)) * X div Width;
  163. end;
  164.  
  165. procedure  TBonanza.SetSlider;
  166. begin
  167.   If lMinPos>lMaxPos then
  168.     lMinPos:=lMaxPos-1;
  169.   If lMaxPos<lMinPos Then
  170.     lMaxPos:=lMinPos+1;
  171.   If lMinPos<lMinValue Then
  172.     lMinPos:=lMinValue;
  173.   If lMinPos>lMaxValue Then
  174.     lMinPos:=lMaxValue;
  175.   If lMaxPos<lMinValue Then
  176.     lMaxPos:=lMinValue;
  177.   If lMaxPos>lMaxValue Then
  178.     lMaxPos:=lMaxValue;
  179. end;
  180.  
  181. procedure  TBonanza.SetShowText;
  182. begin
  183.   fShowText:=fValue;
  184.   InValidate;
  185. end;
  186.  
  187. procedure  TBonanza.MouseMove;
  188. var        TChanged : TSlider;
  189.            fChanged : Boolean;
  190. begin
  191.   TChanged:=esNoChange;
  192.   fChanged:=False;
  193.   If fMinPressed then begin
  194.     lMinPos:=GetPosition(X)+lMinValue;
  195.     TChanged:=esMinimumSlider;
  196.     If lMinPos>lMaxPos then
  197.       lMinPos:=lMaxPos-1;
  198.     fChanged:=True;
  199.   end;
  200.   If fMaxPressed then begin
  201.     lMaxPos:=GetPosition(X)+lMinValue;
  202.     TChanged:=esMaximumSlider;
  203.     If lMaxPos<lMinPos Then
  204.       lMaxPos:=lMinPos+1;
  205.     fChanged:=True;
  206.   end;
  207.   If Assigned(FOnChanging) Then
  208.     FOnChanging(Self, lMinPos, lMaxPos, TChanged);
  209.   {referenced values, -> update if neccessary}
  210.   SetSlider;
  211.   If fChanged then
  212.     Paint;  {update if neccessary...}
  213. end;
  214.  
  215. procedure  TBonanza.MouseUp;
  216. var        lPos    : Longint;
  217.            tChanged: TSlider;
  218. begin
  219.   If fMinPressed then
  220.     tChanged:=esMinimumSlider;
  221.   If fMaxPressed then
  222.     tChanged:=esMaximumSlider;
  223.   If Assigned(FOnChange) Then
  224.     FOnChange(Self, lPos, tChanged);
  225.   If fMinPressed and Assigned(FOnMaxChanged) Then
  226.     FOnMaxChanged(Self, lMaxPos);
  227.   If fMaxPressed and Assigned(FOnMinChanged) Then
  228.     FOnMinChanged(Self, lMinPos);
  229.   {referenced values, -> update if neccessary}
  230.   SetSlider;
  231.   fMinPressed:=False;
  232.   fMaxPressed:=False;
  233. end;
  234.  
  235. procedure  TBonanza.MouseDown;
  236. begin
  237.   If Not fMaxPressed Then
  238.     If (Y>=Height-bHUnit-bHUnit div 5) And (Y<=Height-1) And (X>=GetMinX) And (X<=GetMinX+bWUnit) Then begin
  239.       {min slider pressed...}
  240.       fMinPressed:=True;
  241.     end;
  242.   If Not fMinPressed Then
  243.     If (Y>=Height-bHUnit-bHUnit div 5) And (Y<=Height-1) And (X>=GetMaxX) And (X<=GetMaxX+bWUnit) Then begin
  244.       {max slider pressed...}
  245.       fMaxPressed:=True;
  246.     end;
  247. end;
  248.  
  249. procedure  TBonanza.CreateProcedure;
  250. begin
  251.   ControlStyle:=[csClickEvents, csCaptureMouse];
  252.   Width:=250;
  253.   Height:=30;
  254.   tMinColor:=clRed;
  255.   tMaxColor:=clBlue;
  256.   lMinPos:=0;
  257.   lMaxPos:=100;
  258.   lMinValue:=0;
  259.   lMaxValue:=100;
  260.   bWUnit:=8;
  261.   bHUnit:=15;
  262.   bUnits:=10;
  263.   fShowUnits:=True;
  264.   fAutoSlider:=False;
  265.   fShowText:=True;
  266. end;
  267.  
  268. destructor TBonanza.Destroy;
  269. begin
  270.   inherited Destroy;
  271. end;
  272.  
  273. procedure TBonanza.SetShowUnits;
  274. begin
  275.   fShowUnits:=fValue;
  276.   InValidate;
  277. end;
  278.  
  279. procedure TBonanza.SetAutoSlider;
  280. begin
  281.   fAutoSlider:=fValue;
  282.   if fAutoSlider then begin
  283.     bWUnit:=Width div 10;
  284.     bHUnit:=Height div 5;
  285.     InValidate;
  286.   end;
  287. end;
  288.  
  289. procedure TBonanza.SetWUnit;
  290. begin
  291.   If bValue>Width div 2 then
  292.     bWUnit:=Width div 2
  293.   else
  294.     bWUnit:=bValue;
  295.   SetAutoSlider(False);
  296. end;
  297.  
  298. procedure TBonanza.SetHUnit;
  299. begin
  300.   If bValue>Height div 2 then
  301.     bHUnit:=Height div 2
  302.   else
  303.     bHUnit:=bValue;
  304.   SetAutoSlider(False);
  305. end;
  306.  
  307. procedure TBonanza.SetUnits;
  308. begin
  309.   If bValue>0 then
  310.     bUnits:=bValue
  311.   else
  312.     Application.MessageBox('Sorry - At least one unit is necessary! Use ShowUnits() '+
  313.                            'to disable units','Error',MB_ICONSTOP+MB_OK); {crashes instead...}
  314.   InValidate;
  315. end;
  316.  
  317. procedure TBonanza.SetMaxPos;
  318. begin
  319.   If (lValue<=lMaxValue) and (lValue>=lMinValue) Then begin
  320.     lMaxPos:=lValue;
  321.     InValidate;
  322.   End;
  323. end;
  324.  
  325. procedure TBonanza.SetMinPos;
  326. begin
  327.   If (lValue<=lMaxValue) and (lValue>=lMinValue) Then begin
  328.     lMinPos:=lValue;
  329.     InValidate;
  330.   End;
  331. end;
  332.  
  333. function  TBonanza.GetMinX;
  334. begin
  335.   If Abs(lMaxValue)+Abs(lMinValue)>0 then
  336.     GetMinX:=(Width-bWUnit-2) * (lMinPos-lMinValue) div (Abs(lMaxValue)+Abs(lMinValue))+1
  337.   else
  338.     GetMinX:=1;
  339. end;
  340.  
  341. function  TBonanza.GetMaxX;
  342. begin
  343.   If Abs(lMaxValue)+Abs(lMinValue)>0 then
  344.     GetMaxX:=(Width-bWUnit-2) * (lMaxPos-lMinValue) div (Abs(lMaxValue)+Abs(lMinValue))+1
  345.   else
  346.     GetMaxX:=1;
  347. end;
  348.  
  349. procedure TBonanza.DrawUnits;
  350. var       bCounter: Byte;
  351.           bStrich : Byte;
  352.           pc      : PChar;
  353.           uiLeft  : Word;
  354.           uiTop   : Word;
  355.           uiRight : Word;
  356.           uiBottom: Word;
  357.           uiTW    : Word;
  358.           uiTH    : Word;
  359. begin
  360.   bStrich:=Height div 5;
  361.   Canvas.Font:=Font;
  362.   With Canvas do begin
  363.     {draws the unit lines...}
  364.     for bCounter:=0 to bUnits do begin
  365.       if fShowUnits then begin
  366.         Pen.Color:=clBtnShadow;
  367.         MoveTo(Word(bCounter)*(Width-bWUnit-2) div (bUnits)+bWUnit div 2,bStrich);
  368.         LineTo(Word(bCounter)*(Width-bWUnit-2) div (bUnits)+bWUnit div 2,2*bStrich);
  369.         Pen.Color:=clBtnHighLight;
  370.         MoveTo(Word(bCounter)*(Width-bWUnit-2) div (bUnits)+bWUnit div 2+1,bStrich);
  371.         LineTo(Word(bCounter)*(Width-bWUnit-2) div (bUnits)+bWUnit div 2+1,2*bStrich);
  372.       end;
  373.       If fShowText Then Begin
  374.         GetMem(pc,30);
  375.         try
  376.           StrPCopy(pc,IntToStr(((Abs(lMinValue)+Abs(lMaxValue)) * (bCounter) div bUnits)+lMinValue));
  377.           uiTW:=TextWidth(StrPas(pc));
  378.           uiTH:=TextHeight(StrPas(pc));
  379.           If ((Longint(bCounter)*(Width-bWUnit-2) div (bUnits)+bWUnit div 2)-TextWidth(StrPas(pc)) div 2)>0 then
  380.             uiLeft:=(Longint(bCounter)*(Width-bWUnit-2) div (bUnits)+bWUnit div 2)-TextWidth(StrPas(pc)) div 2
  381.           else
  382.             uiLeft:=0;
  383.           uiTop:=2*bStrich+1;
  384.           uiRight:=uiLeft+TextWidth(StrPas(pc));
  385.           uiBottom:=uiTop+TextHeight(StrPas(pc));
  386.           DrawText(Handle,pc,-1,Rect(uiLeft,uiTop,uiRight,uiBottom),
  387.                    DT_CENTER or DT_NOPREFIX or DT_SINGLELINE);
  388.         finally
  389.           FreeMem(pc,30);
  390.         end;
  391.       end;
  392.     end;
  393.   end;
  394. end;
  395.  
  396. procedure TBonanza.DrawSliders;
  397. begin
  398.   With Canvas do begin
  399.     {draws the minimum slider...}
  400.     Pen.Color:=clBtnHighLight;
  401.     PolyLine([Point(GetMinX,Height-1),Point(GetMinX,Height-bHUnit),Point(GetMinX+bWUnit div 2,Height-bHUnit-bHUnit div 5)]);
  402.     Pen.Color:=clBtnShadow;
  403.     PolyLine([Point(GetMinX+bWUnit div 2,Height-bHUnit-bHUnit div 5),Point(GetMinX+bWUnit,Height-bHUnit),
  404.               Point(GetMinx+bWUnit,Height-1),Point(GetMinX,Height-1)]);
  405.     Brush.Color:=tMinColor;
  406.     FloodFill(GetMinX+1,Height-2,Pixels[GetMinX+1,Height-2],fsSurface);
  407.     {draws the maximum slider}
  408.     Pen.Color:=clBtnHighLight;
  409.     PolyLine([Point(GetMaxX,Height-1),Point(GetMaxX,Height-bHUnit),Point(GetMaxX+bWUnit div 2,Height-bHUnit-bHUnit div 5)]);
  410.     Pen.Color:=clBtnShadow;
  411.     PolyLine([Point(GetMaxX+bWUnit div 2,Height-bHUnit-bHUnit div 5),Point(GetMaxX+bWUnit,Height-bHUnit),
  412.               Point(GetMaxx+bWUnit,Height-1),Point(GetMaxX,Height-1)]);
  413.     Brush.Color:=tMaxColor;
  414.     FloodFill(GetMaxX+1,Height-2,Pixels[GetMaxX+1,Height-2],fsSurface);
  415.   end;
  416. end;
  417.  
  418. procedure TBonanza.Paint;
  419. var       bCounter: Byte;
  420.           tBuffer : TBitMap;
  421.           tFrame  : TRect;
  422. begin
  423.   If fAutoSlider then begin
  424.     bWUnit:=Width div 10;
  425.     bHUnit:=Height div 5;
  426.   end;
  427.   If Height<30 Then
  428.     Height:=30;
  429.   If Width<20 Then
  430.     Width:=20;
  431.   If Not fIsLoaded Then
  432.     CreateProcedure;
  433.   tBuffer:=TBitmap.Create;
  434.   try
  435.     tBuffer.Width:=Width;
  436.     tBuffer.Height:=Height;
  437.     With tBuffer do begin
  438.       Canvas.Brush.Color:=clBtnFace;
  439.       Canvas.FillRect(Rect(0,0,Width,Height));
  440.       DrawUnits(Canvas);
  441.       DrawSliders(Canvas);
  442.       tFrame:=Rect(0,0,Width,Height);
  443.       If fShowPanel then
  444.         Frame3D(Canvas,tFrame,clBtnHighLight,clBtnShadow,1);
  445.     end;
  446.     Canvas.Draw(0,0,tBuffer);
  447.   finally
  448.     tBuffer.Destroy;
  449.   end;
  450. end;
  451.  
  452. procedure TBonanza.SetMinValue;
  453. begin
  454.   lMinValue:=lValue;
  455.   If (lMinPos<lValue) Then
  456.     lMinPos:=lValue;
  457.   if (lMaxPos<lValue) Then
  458.     lMaxPos:=lValue;
  459.   InValidate;
  460. end;
  461.  
  462. procedure TBonanza.SetMaxValue;
  463. begin
  464.   lMaxValue:=lValue;
  465.   If (lMinPos>lValue) Then
  466.     lMinPos:=lValue;
  467.   if (lMaxPos>lValue) Then
  468.     lMaxPos:=lValue;
  469.   InValidate;
  470. end;
  471.  
  472. procedure TBonanza.SetMinColor;
  473. begin
  474.   tMinColor:=tValue;
  475.   InValidate;
  476. end;
  477.  
  478. procedure TBonanza.SetMaxColor;
  479. begin
  480.   tMaxColor:=tValue;
  481.   InValidate;
  482. end;
  483.  
  484. procedure Register;
  485. begin
  486.   {use your own location for registering instead!!'}
  487.   RegisterComponents('Slarti', [TBonanza]);
  488. end;
  489.  
  490. begin
  491. end.
  492.