PC World Komputer 1998 January/Pcwk0198.iso/Dcomplib/BONANZA.LZH/BONANZA.PAS

Pascal/Delphi Source File | 1995-10-17 | 15.0 KB | 492 lines

unit Bonanza;

interface

{
File:        Bonanza
Project:     Slartibartfrass
Version:     1.00
Author:      Sir Roger McMisteli
Date:        17. October 1995

Remarks:     This is a new slider component, which has two separate sliders
             which both can set manually.
             You cannot set the minimum slider at a higher position as the
             maximum slider.
             Please note that this is my first component! If it has bugs,
             well, that's possible. I tested it, but you never know.
             If you have improvements or when bugs occured, please send a mail to
               Roger Misteli
               Zentralstrasse 6
               8400 Winterthur
               Phone: intl - 52 - 212 28 91
               email: [e-mail]

             ***********************************************************
             * DON'T USE THIS COMPUSERVE ID, 'CAUSE ITS MY BUSINESS ID *
             * AND IT IT NOT LONGER VALID UNTIL 1. November 1995 !!!!! *
             ***********************************************************

Copyright:   The TBonanza component was written by Sir Roger McMisteli
             for a student project. It is absolutely free to the public domain.
             If you want to modify the component, do so. But please mention
             my name in your release as the original author.
}

uses
  SysUtils,
  WinTypes,
  WinProcs,
  Messages,
  Classes,
  Graphics,
  Forms,
  Controls,
  Dialogs,
  StdCtrls,
  ExtCtrls,
  DsgnIntf;

type
  TSlider      = (esNoChange, esMinimumSlider, esMaximumSlider);
  TOnChange    = procedure (Sender: TObject; var lPosition: Longint; tWhichSlider: TSlider) of object;
  TOnMinMax    = procedure (Sender: TObject; var lPosition: Longint) of object;
  TOnChanging  = procedure (Sender: TObject; var lMinPos, lMaxPos: Longint; tWhichSlider: TSlider) of object;

type
  TBonanza = class(TGraphicControl)
    private
      lMaxValue:    Longint;                          {max position of both sliders}
      lMinValue:    Longint;                          {min position ...}
      tMinColor:    TColor;                           {min slider color}
      tMaxColor:    TColor;
      lMinPos:      Longint;                          {min slider position}
      lMaxPos:      Longint;
      bUnits:       Byte;                             {count of units to be drawn}
      fIsLoaded:    Boolean;                          {only for testing...}
      bWUnit:       Byte;                             {internal: width of slider}
      bHUnit:       Byte;
      fShowUnits:   Boolean;                          {draw the unit lines?}
      fAutoSlider:  Boolean;                          {automatic slider dimensions?}
      FOnChange:    TOnChange;
      FOnChanging:  TOnChanging;
      FOnMinChanged:TOnMinMax;
      FOnMaxChanged:TOnMinMax;
      fMinPressed:  Boolean;                          {internal: min slider has been activated}
      fMaxPressed:  Boolean;
      fShowText:    Boolean;
      fShowPanel:   Boolean;
      function      GetMinX: Word;                    {returns min slider position}
      function      GetMaxX: Word;
      procedure     DrawUnits(Canvas: TCanvas);       {draws the unit lines}
      procedure     DrawSliders(Canvas: TCanvas);     {draws the sliders}
      procedure     CreateProcedure; dynamic;
      function      GetPosition(X: Integer): Longint; {internal: returns position (from pixels to units)}
    protected
      procedure     SetMinValue(lValue: Longint);
      procedure     SetMaxValue(lValue: Longint);
      procedure     SetMinColor(tValue: TColor);
      procedure     SetMaxColor(tValue: TColor);
      procedure     SetMaxPos(lValue: Longint);
      procedure     SetMinPos(lValue: Longint);
      procedure     SetUnits(bValue: Byte);
      procedure     SetWUnit(bValue: Byte);
      procedure     SetHUnit(bValue: Byte);
      procedure     SetShowUnits(fValue: Boolean);
      procedure     SetAutoSlider(fValue: Boolean);
      procedure     SetShowText(fValue: Boolean);
      procedure     SetShowPanel(fValue: Boolean);

      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     SetSlider; dynamic;
    public
      constructor   Create(AOwner: TComponent); override;
      procedure     ForcePaint;
      destructor    Destroy; override;
    published
      property      OnChanging: TOnChanging read FOnChanging write FOnChanging;
      property      OnChange: TOnChange read FOnChange write FOnChange;
      property      OnMinChanged: TOnMinMax read FOnMinChanged write FOnMinChanged;
      property      OnMaxChanged: TOnMinMax read FOnMaxChanged write FOnMaxChanged;

      property      ShowText: Boolean read fShowText write SetShowText default True;
      property      ShowPanel: Boolean read fShowPanel write SetShowPanel default True;
      property      Height default 30;
      property      Width  default 250;
      property      Top    default 10;
      property      Left   default 10;
      property      Hint;
      property      Font;
      property      Enabled;
      property      Visible;
      property      ShowUnits: Boolean read fShowUnits write SetShowUnits default True;
      property      AutoSlider: Boolean read fAutoSlider write SetAutoSlider default False;
      property      SliderWidth: Byte read bWUnit write SetWUnit default 8;
      property      SliderHeight: Byte read bHUnit write SetHUnit default 15;
      property      Units: Byte read bUnits write SetUnits default 10;
      property      SliderMinColor: TColor read tMinColor write SetMinColor default clRed;
      property      SliderMaxColor: TColor read tMaxColor write SetMaxColor default clBlue;
      property      SliderMaxPos: Longint read lMaxPos write SetMaxPos default 100;
      property      SliderMinPos: Longint read lMinPos write SetMinPos default 0;
      property      MaxValue: Longint read lMaxValue write SetMaxValue default 100;
      property      MinValue: Longint read lMinValue write SetMinValue default 0;
  end;

procedure Register;

implementation

constructor TBonanza.Create;
begin
  inherited Create(AOwner);
  fIsLoaded:=True;
  CreateProcedure;
end;

procedure  TBonanza.ForcePaint;
begin
  Paint;
end;

procedure  TBonanza.SetShowPanel;
begin
  fShowPanel:=fValue;
  InValidate;
end;

function   TBonanza.GetPosition;
begin
  GetPosition:=(Abs(lMaxValue)+Abs(lMinValue)) * X div Width;
end;

procedure  TBonanza.SetSlider;
begin
  If lMinPos>lMaxPos then
    lMinPos:=lMaxPos-1;
  If lMaxPos<lMinPos Then
    lMaxPos:=lMinPos+1;
  If lMinPos<lMinValue Then
    lMinPos:=lMinValue;
  If lMinPos>lMaxValue Then
    lMinPos:=lMaxValue;
  If lMaxPos<lMinValue Then
    lMaxPos:=lMinValue;
  If lMaxPos>lMaxValue Then
    lMaxPos:=lMaxValue;
end;

procedure  TBonanza.SetShowText;
begin
  fShowText:=fValue;
  InValidate;
end;

procedure  TBonanza.MouseMove;
var        TChanged : TSlider;
           fChanged : Boolean;
begin
  TChanged:=esNoChange;
  fChanged:=False;
  If fMinPressed then begin
    lMinPos:=GetPosition(X)+lMinValue;
    TChanged:=esMinimumSlider;
    If lMinPos>lMaxPos then
      lMinPos:=lMaxPos-1;
    fChanged:=True;
  end;
  If fMaxPressed then begin
    lMaxPos:=GetPosition(X)+lMinValue;
    TChanged:=esMaximumSlider;
    If lMaxPos<lMinPos Then
      lMaxPos:=lMinPos+1;
    fChanged:=True;
  end;
  If Assigned(FOnChanging) Then
    FOnChanging(Self, lMinPos, lMaxPos, TChanged);
  {referenced values, -> update if neccessary}
  SetSlider;
  If fChanged then
    Paint;  {update if neccessary...}
end;

procedure  TBonanza.MouseUp;
var        lPos    : Longint;
           tChanged: TSlider;
begin
  If fMinPressed then
    tChanged:=esMinimumSlider;
  If fMaxPressed then
    tChanged:=esMaximumSlider;
  If Assigned(FOnChange) Then
    FOnChange(Self, lPos, tChanged);
  If fMinPressed and Assigned(FOnMaxChanged) Then
    FOnMaxChanged(Self, lMaxPos);
  If fMaxPressed and Assigned(FOnMinChanged) Then
    FOnMinChanged(Self, lMinPos);
  {referenced values, -> update if neccessary}
  SetSlider;
  fMinPressed:=False;
  fMaxPressed:=False;
end;

procedure  TBonanza.MouseDown;
begin
  If Not fMaxPressed Then
    If (Y>=Height-bHUnit-bHUnit div 5) And (Y<=Height-1) And (X>=GetMinX) And (X<=GetMinX+bWUnit) Then begin
      {min slider pressed...}
      fMinPressed:=True;
    end;
  If Not fMinPressed Then
    If (Y>=Height-bHUnit-bHUnit div 5) And (Y<=Height-1) And (X>=GetMaxX) And (X<=GetMaxX+bWUnit) Then begin
      {max slider pressed...}
      fMaxPressed:=True;
    end;
end;

procedure  TBonanza.CreateProcedure;
begin
  ControlStyle:=[csClickEvents, csCaptureMouse];
  Width:=250;
  Height:=30;
  tMinColor:=clRed;
  tMaxColor:=clBlue;
  lMinPos:=0;
  lMaxPos:=100;
  lMinValue:=0;
  lMaxValue:=100;
  bWUnit:=8;
  bHUnit:=15;
  bUnits:=10;
  fShowUnits:=True;
  fAutoSlider:=False;
  fShowText:=True;
end;

destructor TBonanza.Destroy;
begin
  inherited Destroy;
end;

procedure TBonanza.SetShowUnits;
begin
  fShowUnits:=fValue;
  InValidate;
end;

procedure TBonanza.SetAutoSlider;
begin
  fAutoSlider:=fValue;
  if fAutoSlider then begin
    bWUnit:=Width div 10;
    bHUnit:=Height div 5;
    InValidate;
  end;
end;

procedure TBonanza.SetWUnit;
begin
  If bValue>Width div 2 then
    bWUnit:=Width div 2
  else
    bWUnit:=bValue;
  SetAutoSlider(False);
end;

procedure TBonanza.SetHUnit;
begin
  If bValue>Height div 2 then
    bHUnit:=Height div 2
  else
    bHUnit:=bValue;
  SetAutoSlider(False);
end;

procedure TBonanza.SetUnits;
begin
  If bValue>0 then
    bUnits:=bValue
  else
    Application.MessageBox('Sorry - At least one unit is necessary! Use ShowUnits() '+
                           'to disable units','Error',MB_ICONSTOP+MB_OK); {crashes instead...}
  InValidate;
end;

procedure TBonanza.SetMaxPos;
begin
  If (lValue<=lMaxValue) and (lValue>=lMinValue) Then begin
    lMaxPos:=lValue;
    InValidate;
  End;
end;

procedure TBonanza.SetMinPos;
begin
  If (lValue<=lMaxValue) and (lValue>=lMinValue) Then begin
    lMinPos:=lValue;
    InValidate;
  End;
end;

function  TBonanza.GetMinX;
begin
  If Abs(lMaxValue)+Abs(lMinValue)>0 then
    GetMinX:=(Width-bWUnit-2) * (lMinPos-lMinValue) div (Abs(lMaxValue)+Abs(lMinValue))+1
  else
    GetMinX:=1;
end;

function  TBonanza.GetMaxX;
begin
  If Abs(lMaxValue)+Abs(lMinValue)>0 then
    GetMaxX:=(Width-bWUnit-2) * (lMaxPos-lMinValue) div (Abs(lMaxValue)+Abs(lMinValue))+1
  else
    GetMaxX:=1;
end;

procedure TBonanza.DrawUnits;
var       bCounter: Byte;
          bStrich : Byte;
          pc      : PChar;
          uiLeft  : Word;
          uiTop   : Word;
          uiRight : Word;
          uiBottom: Word;
          uiTW    : Word;
          uiTH    : Word;
begin
  bStrich:=Height div 5;
  Canvas.Font:=Font;
  With Canvas do begin
    {draws the unit lines...}
    for bCounter:=0 to bUnits do begin
      if fShowUnits then begin
        Pen.Color:=clBtnShadow;
        MoveTo(Word(bCounter)*(Width-bWUnit-2) div (bUnits)+bWUnit div 2,bStrich);
        LineTo(Word(bCounter)*(Width-bWUnit-2) div (bUnits)+bWUnit div 2,2*bStrich);
        Pen.Color:=clBtnHighLight;
        MoveTo(Word(bCounter)*(Width-bWUnit-2) div (bUnits)+bWUnit div 2+1,bStrich);
        LineTo(Word(bCounter)*(Width-bWUnit-2) div (bUnits)+bWUnit div 2+1,2*bStrich);
      end;
      If fShowText Then Begin
        GetMem(pc,30);
        try
          StrPCopy(pc,IntToStr(((Abs(lMinValue)+Abs(lMaxValue)) * (bCounter) div bUnits)+lMinValue));
          uiTW:=TextWidth(StrPas(pc));
          uiTH:=TextHeight(StrPas(pc));
          If ((Longint(bCounter)*(Width-bWUnit-2) div (bUnits)+bWUnit div 2)-TextWidth(StrPas(pc)) div 2)>0 then
            uiLeft:=(Longint(bCounter)*(Width-bWUnit-2) div (bUnits)+bWUnit div 2)-TextWidth(StrPas(pc)) div 2
          else
            uiLeft:=0;
          uiTop:=2*bStrich+1;
          uiRight:=uiLeft+TextWidth(StrPas(pc));
          uiBottom:=uiTop+TextHeight(StrPas(pc));
          DrawText(Handle,pc,-1,Rect(uiLeft,uiTop,uiRight,uiBottom),
                   DT_CENTER or DT_NOPREFIX or DT_SINGLELINE);
        finally
          FreeMem(pc,30);
        end;
      end;
    end;
  end;
end;

procedure TBonanza.DrawSliders;
begin
  With Canvas do begin
    {draws the minimum slider...}
    Pen.Color:=clBtnHighLight;
    PolyLine([Point(GetMinX,Height-1),Point(GetMinX,Height-bHUnit),Point(GetMinX+bWUnit div 2,Height-bHUnit-bHUnit div 5)]);
    Pen.Color:=clBtnShadow;
    PolyLine([Point(GetMinX+bWUnit div 2,Height-bHUnit-bHUnit div 5),Point(GetMinX+bWUnit,Height-bHUnit),
              Point(GetMinx+bWUnit,Height-1),Point(GetMinX,Height-1)]);
    Brush.Color:=tMinColor;
    FloodFill(GetMinX+1,Height-2,Pixels[GetMinX+1,Height-2],fsSurface);
    {draws the maximum slider}
    Pen.Color:=clBtnHighLight;
    PolyLine([Point(GetMaxX,Height-1),Point(GetMaxX,Height-bHUnit),Point(GetMaxX+bWUnit div 2,Height-bHUnit-bHUnit div 5)]);
    Pen.Color:=clBtnShadow;
    PolyLine([Point(GetMaxX+bWUnit div 2,Height-bHUnit-bHUnit div 5),Point(GetMaxX+bWUnit,Height-bHUnit),
              Point(GetMaxx+bWUnit,Height-1),Point(GetMaxX,Height-1)]);
    Brush.Color:=tMaxColor;
    FloodFill(GetMaxX+1,Height-2,Pixels[GetMaxX+1,Height-2],fsSurface);
  end;
end;

procedure TBonanza.Paint;
var       bCounter: Byte;
          tBuffer : TBitMap;
          tFrame  : TRect;
begin
  If fAutoSlider then begin
    bWUnit:=Width div 10;
    bHUnit:=Height div 5;
  end;
  If Height<30 Then
    Height:=30;
  If Width<20 Then
    Width:=20;
  If Not fIsLoaded Then
    CreateProcedure;
  tBuffer:=TBitmap.Create;
  try
    tBuffer.Width:=Width;
    tBuffer.Height:=Height;
    With tBuffer do begin
      Canvas.Brush.Color:=clBtnFace;
      Canvas.FillRect(Rect(0,0,Width,Height));
      DrawUnits(Canvas);
      DrawSliders(Canvas);
      tFrame:=Rect(0,0,Width,Height);
      If fShowPanel then
        Frame3D(Canvas,tFrame,clBtnHighLight,clBtnShadow,1);
    end;
    Canvas.Draw(0,0,tBuffer);
  finally
    tBuffer.Destroy;
  end;
end;

procedure TBonanza.SetMinValue;
begin
  lMinValue:=lValue;
  If (lMinPos<lValue) Then
    lMinPos:=lValue;
  if (lMaxPos<lValue) Then
    lMaxPos:=lValue;
  InValidate;
end;

procedure TBonanza.SetMaxValue;
begin
  lMaxValue:=lValue;
  If (lMinPos>lValue) Then
    lMinPos:=lValue;
  if (lMaxPos>lValue) Then
    lMaxPos:=lValue;
  InValidate;
end;

procedure TBonanza.SetMinColor;
begin
  tMinColor:=tValue;
  InValidate;
end;

procedure TBonanza.SetMaxColor;
begin
  tMaxColor:=tValue;
  InValidate;
end;

procedure Register;
begin
  {use your own location for registering instead!!'}
  RegisterComponents('Slarti', [TBonanza]);
end;

begin
end.