admeter.pas

Async Professional 4.04

{*********************************************************}
{*                   ADMETER.PAS 4.04                    *}
{*      Copyright (C) TurboPower Software 1996-2002      *}
{*                 All rights reserved.                  *}
{*********************************************************}

{Global defines potentially affecting this unit}
{$I AWDEFINE.INC}

{Options required for this unit}
{$G+,X+,F+}

unit AdMeter;
  {-General purpose progress meter component}

interface

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

const
  admDefBarColor = clHighlight;
  admDefBevelColor1 = clBtnHighlight;
  admDefBevelColor2 = clBtnShadow;
  admDefMeterHeight = 16;
  admDefMax = 100;
  admDefMin = 0;
  admDefStep = 8;
  admDefMeterWidth = 150;

type
  TBevelStyle = (bsLowered, bsRaised, bsNone);

  TApdMeter = class(TApdBaseGraphicControl)
  private
    FBarColor : TColor;
    FBevelColor1 : TColor;
    FBevelColor2 : TColor;
    FBevelStyle : TBevelStyle;
    FMax : LongInt;
    FMin : LongInt;
    FOnPosChange : TNotifyEvent;
    FPosition : LongInt;
    FSegments : LongInt;
    FStep : LongInt;
    NeedPartial : Boolean;
    PartialSize : LongInt;
    procedure SetBarColor(Value : TColor);
    procedure SetBevelStyle(Value : TBevelStyle);
    procedure SetBevelColor1(Value : TColor);
    procedure SetBevelColor2(Value : TColor);
    procedure SetPosition(Value : LongInt);
    procedure SetStep(Value : LongInt);
  protected
    procedure DoOnPosChange; dynamic;
    procedure Paint; override;
    procedure UpdatePosition(Force : Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  published
    { Color of the progress bar }
    property BarColor : TColor
      read FBarColor
      write SetBarColor
      default admDefBarColor;

    { Color of the bevel }
    property BevelColor1 : TColor
      read FBevelColor1
      write SetBevelColor1
      default admDefBevelColor1;

    { Color of the bevel }
    property BevelColor2 : TColor
      read FBevelColor2
      write SetBevelColor2
      default admDefBevelColor2;

    { Style of border bevel }
    property BevelStyle : TBevelStyle
      read FBevelStyle
      write SetBevelStyle
      default bsLowered;

    { Value for maximum deflection of progress bar }
    property Max : LongInt
      read FMax
      write FMax
      default admDefMax;

    { Value for minimum deflection of progress bar }
    property Min : LongInt
      read FMin
      write FMin
      default admDefMin;

    { Current level of progress, relative to Min and Max }
    property Position : LongInt
      read FPosition
      write SetPosition;

    { Width in pixels of each block on the progress bar }
    property Step : LongInt
      read FStep
      write SetStep
      default admDefStep;

    { Fires when the bar position changes }
    property OnPosChange : TNotifyEvent
      read FOnPosChange
      write FOnPosChange;

    { Inherited properties }
    property Align;
    property DragCursor;
    property DragMode;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;

    { Inherited Events }
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    {$IFDEF WIN32}
    property OnStartDrag;
    {$ENDIF}
  end;

implementation

{$IFDEF TRIALRUN}
  {$I TRIAL07.INC}
  {$I TRIAL03.INC}
  {$I TRIAL01.INC}
{$ENDIF}

constructor TApdMeter.Create(AOwner: TComponent);
{$IFDEF TRIALRUN}
  {$I TRIAL04.INC}
{$ENDIF}
begin
  inherited Create(AOwner);
  FBarColor := admDefBarColor;
  FBevelColor1 := admDefBevelColor1;
  FBevelColor2 := admDefBevelColor2;
  FBevelStyle := bsLowered;
  FMax := admDefMax;
  FMin := admDefMin;
  FStep := admDefStep;
  NeedPartial := False;
  Height := admDefMeterHeight;
  Width := admDefMeterWidth;
{$IFDEF TRIALRUN}
  TC;
{$ENDIF}
end;

procedure TApdMeter.SetBarColor(Value: TColor);
begin
  if Value <> FBarColor then begin
    FBarColor := Value;
    Invalidate;
  end;
end;

procedure TApdMeter.SetBevelColor1(Value: TColor);
begin
  if Value <> FBevelColor1 then begin
    FBevelColor1 := Value;
    Invalidate;
  end;
end;

procedure TApdMeter.SetBevelColor2(Value: TColor);
begin
  if Value <> FBevelColor2 then begin
    FBevelColor2 := Value;
    Invalidate;
  end;
end;

procedure TApdMeter.SetBevelStyle(Value: TBevelStyle);
begin
  if Value <> FBevelStyle then begin
    FBevelStyle := Value;
    Invalidate;
  end;
end;

procedure TApdMeter.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  UpdatePosition(True);
end;

procedure TApdMeter.SetPosition(Value: LongInt);
begin
  if Value <> FPosition then begin
    FPosition := Value;
    UpdatePosition(False);
  end;
end;

procedure TApdMeter.SetStep(Value: LongInt);
begin
  if Value <> FStep then begin
    FStep := Value;
    UpdatePosition(True);
  end;
end;

procedure TApdMeter.DoOnPosChange;
begin
  if Assigned(FOnPosChange) then
    FOnPosChange(Self);
end;

procedure TApdMeter.Paint;
var
  BR : TRect;
  I : Integer;

  procedure BevelRect(const R : TRect; const C1, C2 : TColor);
  begin
    with Canvas do begin
      Pen.Color := C1;
      PolyLine([Point(R.Left, R.Bottom), Point(R.Left, R.Top),
        Point(R.Right, R.Top)]);
      Pen.Color := C2;
      PolyLine([Point(R.Right, R.Top), Point(R.Right, R.Bottom),
        Point(R.Left, R.Bottom)]);
    end;
  end;

  procedure BevelLine(C : TColor; X1, Y1, X2, Y2 : Integer);
  begin
    with Canvas do begin
      Pen.Color := C;
      MoveTo(X1, Y1);
      LineTo(X2, Y2);
    end;
  end;

  procedure BarRect(const R : TRect);
  begin
    with Canvas do begin
      Brush.Style := bsSolid;
      Brush.Color := FBarColor;
      FillRect(R);
    end;
  end;

begin
  with Canvas do begin
    Pen.Width := 1;
    BR := Rect(0, 0, Width - 1, Height - 1);
    { Draw the bevel }
    case FBevelStyle of
      bsLowered : BevelRect(BR, FBevelColor2, FBevelColor1);
      bsRaised : BevelRect(BR, FBevelColor1, FBevelColor2);
      bsNone : ;
    end;
    { Draw the full segments }
    for I := 1 to FSegments do begin
      BR.Top := 2;
      BR.Bottom := Height - 2;
      BR.Left := (Pred(I) * FStep) + 2;
      BR.Right := BR.Left + (FStep - 2);
      BarRect(BR);
    end;
    { Draw partial segment if needed }
    if NeedPartial then begin
      BR.Top := 2;
      BR.Bottom := Height - 2;
      BR.Left := BR.Left + FStep;
      BR.Right := BR.Left + PartialSize;
      BarRect(BR);
    end;
  end;
end;

procedure TApdMeter.UpdatePosition(Force : Boolean);
var
  OldSegments : LongInt;
  OldNeedPartial : Boolean;
begin
  OldSegments := FSegments;
  OldNeedPartial := NeedPartial;
  if FPosition <= FMin then
    FSegments := 0
  else
    FSegments := Succ(((Width - 3) div FStep) * (FPosition - FMin) div (FMax - FMin));
  if (FSegments * FStep) > (Width - 4) then begin
    NeedPartial := True;
    FSegments := (Width - 4) div FStep;
    PartialSize := (Width - 4) mod FStep;
  end else begin
    NeedPartial := False;
  end;
  if (OldSegments <> FSegments) or (OldNeedPartial <> NeedPartial) then begin
    Invalidate;
    DoOnPosChange;
  end else begin
    if Force then Invalidate;
  end;
end;

end.