PC Open 19/pcopen19.iso/Win31/Calmira/SOURCE.ZIP/VCL/BARGAUGE.PAS

Pascal/Delphi Source File | 1998-02-20 | 8.9 KB | 352 lines

{*********************************************************}
{                                                         }
{    Calmira Visual Component Library 2.1                 }
{    by Li-Hsin Huang,                                    }
{    released into the public domain January 1998         }
{                                                         }
{*********************************************************}

unit BarGauge;

{ TBarGauge }

{ TBarGauge is a simplified version of Borland's sample TGauge, but is around
  10 times faster at drawing, because it doesn't bother to draw the
  clever "inverse" text effect.  Use it for speed critical stuff.

  Note: Calmira 2.1 uses the newer TWin95Bar instead of TBarGauge.
}

interface

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

type
  TBarKind = (bkHorizontal, bkVertical);

  TAbstractBar = class(TGraphicControl)
  private
    FKind : TBarKind;
    FForeColor: TColor;
    FBackColor: TColor;
    procedure SetMinValue(Value: Longint);
    procedure SetMaxValue(Value: Longint);
    procedure SetKind(Value: TBarKind);
    procedure SetForeColor(Value: TColor);
    procedure SetBackColor(Value: TColor);
  protected
    FMinValue: Longint;
    FMaxValue: Longint;
    FCurValue: Longint;
    procedure SetProgress(Value: Longint); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    procedure AddProgress(Value: Longint);
    function GetPercentDone: Integer;
  published
    property PercentDone: Integer read GetPercentDone;
    property Kind : TBarKind read FKind write SetKind default bkHorizontal;
    property MinValue: Longint read FMinValue write SetMinValue default 0;
    property MaxValue: Longint read FMaxValue write SetMaxValue default 100;
    property ForeColor: TColor read FForeColor write SetForeColor default clBlack;
    property BackColor: TColor read FBackColor write SetBackColor default clWhite;
    property Align;
    property Progress: Longint read FCurValue write SetProgress;
    property ParentShowHint;
    property ShowHint;
    property Enabled;
    property Visible;
  end;

  TBarGauge = class(TAbstractBar)
  private
    { Private declarations }
    FShowText: Boolean;
    FBorderStyle: TBorderStyle;
    FCtl3D : Boolean;
    procedure SetShowText(Value: Boolean);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetCtl3D(Value: Boolean);
  protected
    { Protected declarations }
    procedure Paint; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
    { Published declarations }
    property Ctl3D : Boolean read FCtl3D write SetCtl3D default True;
    property ShowText: Boolean read FShowText write SetShowText default True;
    property Font;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property ParentFont;
  end;

  TWin95Gauge = class(TAbstractBar)
  protected
    procedure Paint; override;
    procedure SetProgress(Value: Longint); override;
    function GetSegments : Integer;
  public
    procedure Setbounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  end;

procedure Register;

implementation

uses ExtCtrls;


{ TAbstractBar}

constructor TAbstractBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  FMinValue := 0;
  FMaxValue := 100;
  FCurValue := 0;
  FForeColor := clNavy;
  FBackColor := clSilver;
  Width := 100;
  Height := 100;
end;


function TAbstractBar.GetPercentDone: Integer;
begin
  if (FMaxValue = FMinValue) or (FCurValue = FMinValue) then Result := 0
  else Result := Trunc((FCurValue - FMinValue) / (FMaxValue - FMinValue) * 100);
end;



procedure TAbstractBar.SetMinValue(Value: Longint);
begin
  if Value <> FMinValue then begin
    FMinValue := Value;
    Repaint;
  end;
end;

procedure TAbstractBar.SetMaxValue(Value: Longint);
begin
  if Value <> FMaxValue then begin
    FMaxValue := Value;
    Repaint;
  end;
end;


procedure TAbstractBar.SetProgress(Value: Longint);
var PrevPercent : Integer;
begin
  if (FCurValue <> Value) and (Value >= FMinValue) and (Value <= FMaxValue) then begin
    PrevPercent := GetPercentDone;
    FCurValue := Value;
    if GetPercentDone <> PrevPercent then Repaint;
  end;
end;


procedure TAbstractBar.SetKind(Value: TBarKind);
begin
  if Value <> FKind then begin
    FKind := Value;
    Repaint;
  end;
end;

procedure TAbstractBar.AddProgress(Value: Longint);
begin
  Progress := FCurValue + Value;
end;


procedure TAbstractBar.SetForeColor(Value: TColor);
begin
  if Value <> FForeColor then begin
    FForeColor := Value;
    Repaint;
  end;
end;

procedure TAbstractBar.SetBackColor(Value: TColor);
begin
  if Value <> FBackColor then begin
    FBackColor := Value;
    Repaint;
  end;
end;


{ TBarGauge }

constructor TBarGauge.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csFramed];
  { default values }
  FShowText := True;
  FBorderStyle := bsSingle;
  FForeColor := clBlack;
  FBackColor := clWhite;
  FCtl3D := True;
end;


procedure TBarGauge.SetShowText(Value: Boolean);
begin
  if Value <> FShowText then begin
    FShowText := Value;
    Repaint;
  end;
end;

procedure TBarGauge.SetBorderStyle(Value: TBorderStyle);
begin
  if Value <> FBorderStyle then begin
    FBorderStyle := Value;
    Repaint;
  end;
end;


procedure TBarGauge.SetCtl3D(Value: Boolean);
begin
  if Value <> FCtl3D then begin
    FCtl3D := Value;
    Repaint;
  end;
end;



procedure TBarGauge.Paint;
var
  r: TRect;
  x, y: Integer;
  s: string[4];
begin
  r := ClientRect;

  with Canvas do begin

    if BorderStyle = bsSingle then begin
      if Ctl3D then Frame3D(Canvas, r, clBtnShadow, clBtnHighlight, 1);
      Frame3D(Canvas, r, clBlack, clBlack, 1);
    end;

    if Kind = bkHorizontal then begin
      x := MulDiv(r.Right - r.Left, PercentDone, 100);
      Brush.Color := ForeColor;
      FillRect(Rect(r.Left, r.Top, r.Left + x, r.Bottom));
      Brush.Color := BackColor;
      FillRect(Rect(r.Left + x, r.Top, r.Right, r.Bottom));
    end
    else begin
      y := MulDiv(r.Bottom - r.Top, PercentDone, 100);
      Brush.Color := ForeColor;
      FillRect(Rect(r.Left, r.Bottom - y, r.Right, r.Bottom));
      Brush.Color := BackColor;
      FillRect(Rect(r.Left, r.Top, r.Right, r.Bottom - y));
    end;

    if ShowText then begin
      s := Format('%d%%', [PercentDone]);
      Brush.Style := bsClear;
      Font.Assign(Self.Font);
      with r do begin
        x := (Width + 1 - TextWidth(s)) div 2;
        y := (Height + 1 - TextHeight(s)) div 2;
      end;
      TextRect(r, x, y, S);
    end;
  end;
end;

{ TWin95Gauge}

procedure TWin95Gauge.Paint;
var
  r: TRect;
  i: Integer;
begin
  r := ClientRect;
  Frame3D(Canvas, r, clBtnShadow, clBtnHighlight, 1);

  { Set r to the boundaries of the first segment }
  InflateRect(r, -1, -1);
  if Kind = bkHorizontal then r.Right := R.Left + 8
  else r.Bottom := r.Top + 8;

  with Canvas do begin
    Brush.Color := ForeColor;

    if Kind = bkHorizontal then
      for i := 1 to GetSegments do begin
        FillRect(r);
        OffsetRect(r, 10, 0);
      end
    else
      for i := 0 to GetSegments do begin
        FillRect(r);
        OffsetRect(r, 0, 10);
      end;

    { It is assumed that the background is the same colour as the
      component's parent, usually clBtnFace, otherwise this painting
      method doesn't work properly.  To prevent flickering, only
      the portion of the gauge without segments is filled with the
      background colour -- the gaps in between segments are not
      painted at all.

      This code can be fixed by drawing on a temporary bitmap. }

    r.Right := Width - 3;
    Brush.Color := BackColor;
    FillRect(r);
  end;
end;

function TWin95Gauge.GetSegments: Integer;
begin
  Result := Trunc(Round((GetPercentDone / 100) * ((Width - 3) div 10)));
end;


procedure TWin95Gauge.SetProgress(Value: Longint);
var PrevSegments : Integer;
begin
  if (FCurValue <> Value) and (Value >= FMinValue) and (Value <= FMaxValue) then begin
    PrevSegments := GetSegments;
    FCurValue := Value;
    if GetSegments <> PrevSegments then Repaint;
  end;
end;


procedure TWin95Gauge.Setbounds(ALeft, ATop, AWidth, AHeight: Integer);

procedure CheckDimension(var X: Integer);
begin
  if (X - 3) mod 10 <> 0 then X := (((X - 3) div 10) * 10) + 3;
end;

begin
  if Kind = bkHorizontal then CheckDimension(AWidth)
  else CheckDimension(AHeight);
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;


procedure Register;
begin
  RegisterComponents('Samples', [TBarGauge, TWin95Gauge]);
end;

end.