acemeter.pas

suite component ace report

unit AceMeter;

{ ----------------------------------------------------------------
  Ace Reporter
  Copyright 1995-1998 SCT Associates, Inc.
  Written by Kevin Maher, Steve Tyrakowski
  ---------------------------------------------------------------- }

interface
{$I ace.inc}
uses
  {$IFDEF WIN32}
    windows,
  {$ELSE}
    winprocs,wintypes,
  {$ENDIF}
  SysUtils, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls;

type
  TAceMeterStyle = (msHorizontal);

  TAceMeter = class(TPaintBox)
  private
    FMeterColor: TColor;
    FBackGroundColor: TColor;
    FBorderStyle: TBorderStyle;
    FStyle: TAceMeterStyle;
    FMax: Integer;
    FMin: Integer;
    FProgress: Integer;
    FShowText: Boolean;
  protected
    procedure SetProgress( Value: Integer );

    procedure SetMeterColor( c: TColor );
    procedure SetBackgroundColor( c: TColor );
    procedure SetBorderStyle( st: TBorderStyle );
    procedure SetStyle( st: TAceMeterStyle );
    procedure SetMin( m: Integer );
    procedure SetMax( m: Integer );
    procedure SetShowText( st: Boolean );

    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;

  published
    property MeterColor: TColor read FMeterColor write SetMeterColor;
    property BackGroundColor: TColor read FBackGroundColor write SetBackGroundColor;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle;
    property Style: TAceMeterStyle read FStyle write SetStyle;
    property Min: Integer read FMin write SetMin;
    property Max: Integer read FMax write SetMax;
    property Progress: Integer read FProgress write SetProgress;
    property ShowText: Boolean read FShowText write SetShowText;
  end;


implementation

constructor TAceMeter.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FMeterColor := clRed;
  FBackgroundColor := clWhite;
  FBorderStyle := bsSingle;
  FStyle := msHorizontal;
  FMax := 100;
  FMin := 0;
  FProgress := 0;
  FShowText := True;
end;

procedure TAceMeter.SetProgress( Value: Integer );
begin
  if Value <> FProgress then
  begin
    FProgress := Value;
    Invalidate;
  end;
end;

procedure TAceMeter.Paint;
var
  percent: Single;
  x,y: Integer;
begin
  inherited Paint;

  if (FProgress > FMin) And (FMax > FMin) then
  begin
    if FProgress >= FMax then percent := 1
    else if (FMax - FProgress) > 0 then percent := ((FMax-Min)-(FMax-FProgress)) / (FMax - FMin)
    else percent := 0;
  end else percent := 0;

  Canvas.Font := font;

  with Canvas do
  begin
    Brush.Color := FBackgroundColor;
    Brush.Style := bsSolid;

    if BorderStyle = bsSingle then Rectangle(0,0,Width,Height)
    else FillRect( Self.ClientRect );

    if FProgress >  FMin then
    begin
      if FStyle = msHorizontal then
      begin
        Brush.Color := FMeterColor;
        FillRect( Rect(1,1, Round(Width * percent) - 1, Height - 1) );
      end;
    end;

    if FShowText then
    begin
      SetTextAlign(handle, TA_CENTER);
      Brush.style := bsClear;
      font := self.font;
      x := Width div 2;
      y := (height + font.height) div 2;
      TextOut(x,y, FloatToStrF( percent * 100, ffNumber, 3,1) + '%');
    end;

  end;
end;


procedure TAceMeter.SetMeterColor( c: TColor );
begin
  if FMeterColor <> c then
  begin
    FMeterColor := c;
    Invalidate;
  end;
end;
procedure TAceMeter.SetBackgroundColor( c: TColor );
begin
  if FBackgroundColor <> c then
  begin
    FBackgroundColor := c;
    Invalidate;
  end;
end;
procedure TAceMeter.SetBorderStyle( st: TBorderStyle );
begin
  if FBorderStyle <> st then
  begin
    FBorderStyle := st;
    Invalidate;
  end;
end;
procedure TAceMeter.SetStyle( st: TAceMeterStyle );
begin
  if FStyle <> st then
  begin
    FStyle := st;
    Invalidate;
  end;
end;
procedure TAceMeter.SetMin( m: Integer );
begin
  if FMin <> m then
  begin
    FMin := m;
    Invalidate;
  end;
end;
procedure TAceMeter.SetMax( m: Integer );
begin
  if FMax <> m then
  begin
    FMax := m;
    Invalidate;
  end;
end;
procedure TAceMeter.SetShowText( st: Boolean );
begin
  if FShowText <> st then
  begin
    FShowText := st;
    Invalidate;
  end;
end;


end.