How to create a vertical progress bar and fill it from top to bottom

Problem/Question/Abstract:

Is it possible for the position parameter to fill a vertically orientated ProgressBar going down (rather than starting from its bottom and going up)? I want to indicate negative values. Ideal would be Min = -negative value and Max = +positive value with zero position in center and the fill would start from zero center and go either up or down depending on value.

Answer:

Here's one with that capability:

unit W95meter;

{This component is a Windows 95 style progress meter.  It is free and donated to
the public domain. I do claim copyright of this code and I hereby prohibit the sale of the source or compiled code to anyone for any amount.

Modified 11/29/00 by Eddie Shipman

1. Added Direction Property to allow reverse fills.

Modified 10/15/97 by Eddie Shipman

1. Added a Max Value so Values over 100 can be used

2. Fixed the Invalidation of the control after properties are changed.

Modified 12/22/95 by John Newlin

1. Caught by Larry E. Tanner 70242,27.  Decreasing the Value of the Percent property
    would fail to clear the higher segments. Fixed.

2. Setting the EdgeStyle propety to St95None would not eliminate painting the edge outline. Fixed.

by John Newlin CIS 71535,665}

interface

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

type
  StyleType = (st95None, st95Lowered, st95Raised);
  TDirection = (dirForward, dirReverse);
  TW95Meter = class(TGraphicControl)
  private
    FAlign: TAlign;
    FPercent: Integer;
    FBackColor: TColor;
    FSegColor: TColor;
    FSegWidth: Integer;
    FSegGap: Integer;
    FMax: Integer;
    FEdgeStyle: StyleType;
    FDirection: TDirection;
    procedure Initialize;
    procedure SetPercent(Value: Integer);
    procedure SetAlign(Value: TAlign);
    procedure SetBackColor(Value: TColor);
    procedure SetDirection(Value: TDirection);
    procedure SetSegColor(Value: TColor);
    procedure SetSegWidth(Value: Integer);
    procedure SetSegGap(Value: Integer);
    procedure SetMax(Value: Integer);
    procedure SetStyle(Value: StyleType);
  protected
    procedure UpdateProgress;
    procedure Paint; override;
    procedure AdjustSize; dynamic;
    procedure RequestAlign; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    property Canvas;
    function IntPercent(High, Low: Longint): Integer;
    function RealPercent(High, Low: real): Integer;
  published
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property Cursor;
    property Align: TAlign read FAlign write SetAlign default alNone;
    property Direction: TDirection read FDirection write SetDirection default dirForward;
    property EdgeStyle: StyleType read FEdgeStyle write SetStyle default st95Lowered;
    property SegmentGap: Integer read FSegGap write SetSegGap default 2;
    property SegmentWidth: Integer read FSegWidth write SetSegWidth default 8;
    property SegmentColor: TColor read FSegColor write SetSegColor default clActiveCaption;
    property BackGroundColor: TColor read FBackColor write SetBackColor default clBtnFace;
    property Percent: Integer read FPercent write SetPercent default 0;
    property Max: Integer read FMax write SetMax default 100;
    property Width default 100;
    property Height default 18;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Win32', [TW95Meter]);
end;

procedure TW95Meter.SetSegWidth(Value: Integer);
begin
  if (Value > 0) and (Value <> FSegWidth) then
  begin
    FSegWidth := Value;
    Invalidate;
  end;
end;

procedure TW95Meter.SetMax(Value: Integer);
begin
  if Value <> FMax then
  begin
    FMax := Value;
    Invalidate;
  end;
end;

procedure TW95Meter.SetSegGap(Value: Integer);
begin
  if (Value > 0) and (Value <> FSegGap) then
  begin
    FSegGap := Value;
    Invalidate;
  end;
end;

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

procedure TW95Meter.SetSegColor(Value: TColor);
begin
  if FSegColor <> Value then
  begin
    FSegColor := Value;
    Invalidate;
  end;
end;

procedure TW95Meter.SetPercent(Value: Integer);
var
  bRefresh: boolean;
begin
  if Value <> FPercent then
  begin
    if FPercent > Value then
      bRefresh := true
    else
      bRefresh := false;
    FPercent := Value;
    if (Fpercent = 0) or (bRefresh = true) or (csDesigning in ComponentState) then
      Invalidate;
    UpdateProgress;
  end;
end;

procedure TW95Meter.SetStyle(Value: StyleType);
begin
  if Value <> FEdgeStyle then
  begin
    FEdgeStyle := Value;
    Invalidate;
  end;
end;

procedure TW95Meter.Initialize;
begin
  Width := 100;
  Height := 18;
  FPercent := 0;
  FBackColor := clBtnFace;
  FSegColor := clActiveCaption;
  FSegWidth := 8;
  FSegGap := 2;
  FEdgeStyle := st95Lowered;
  FMax := 100;
  FDirection := dirForward;
end;

constructor TW95Meter.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Initialize;
end;

procedure TW95Meter.UpdateProgress;
var
  x1, y1, x2, y2, max: Integer;
  bg: TColor;

  procedure DoHorizontalF;
  var
    i: Integer;
  begin
    x1 := 4;
    x2 := x1 + FSegWidth;
    y1 := 4;
    y2 := Height - 4;
    max := Width div (FSegWidth + FSegGap);
    Max := round(max * (FPerCent / FMax));
    for i := 1 to Max do
    begin
      with canvas do
      begin
        if x2 <= width - 4 then
          Rectangle(x1, y1, x2, y2);
        x1 := x1 + FSegWidth + FSegGap;
        x2 := x1 + FSegWidth;
      end;
    end;
  end;

  procedure DoVerticalF;
  var
    i, h: Integer;
  begin
    h := height;
    x1 := 4;
    x2 := Width - 4;
    y1 := Height - (FSegWidth + 4);
    y2 := Height - 4;
    max := Height div (FSegWidth + FSegGap);
    max := round(max * (FPercent / FMax));
    for i := 1 to max do
    begin
      with canvas do
      begin
        if y1 >= 4 then
          Rectangle(x1, y1, x2, y2);
        y1 := y1 - (FSegWidth + FSegGap);
        y2 := y1 + FsegWidth;
      end;
    end;
  end;

  procedure DoHorizontalR;
  var
    i: Integer;
  begin
    x1 := Width - 4;
    x2 := x1 - FSegWidth;
    y1 := 4;
    y2 := Height - 4;
    max := Width div (FSegWidth + FSegGap);
    Max := round(max * (FPerCent / FMax));
    for i := 1 to Max do
    begin
      with canvas do
      begin
        if x2 <= width - 4 then
          Rectangle(x1, y1, x2, y2);
        x1 := x1 - FSegWidth - FSegGap;
        x2 := x1 - FSegWidth;
      end;
    end;
  end;

  procedure DoVerticalR;
  var
    i: Integer;
  begin
    x1 := 4;
    x2 := Width - 4;
    y1 := 4;
    y2 := 4 + FSegWidth;
    max := Height div (FSegWidth + FSegGap);
    max := round(max * (FPercent / FMax));
    for i := 1 to max do
    begin
      with canvas do
      begin
        if y1 >= 4 then
          Rectangle(x1, y1, x2, y2);
        y1 := y1 + (FSegWidth + FSegGap);
        y2 := y1 + FSegWidth;
      end;
    end;
  end;

begin
  canvas.pen.color := FSegColor;
  canvas.brush.color := FsegColor;
  case FDirection of
    dirForward:
      begin
        if Width > Height then
          DoHorizontalF
        else
          DoVerticalF;
      end;
    dirReverse:
      begin
        if Width > Height then
          DoHorizontalR
        else
          DoVerticalR;
      end;
  end;
end;

procedure TW95Meter.Paint;
begin
  with Canvas do
  begin
    Brush.Color := FBackColor;
    if FEdgeStyle = st95none then
    begin
      Pen.Width := 0;
      Pen.Color := FBackColor;
      Rectangle(0, 0, width, height);
      if FPercent > 0 then
        UpdateProgress;
      exit;
    end;
    pen.Width := 2;
    if FEdgeStyle = st95Lowered then
      pen.color := clgray
    else
      pen.color := clWhite;
    moveto(0, height);
    lineto(0, 0);
    lineto(width - 1, 0);
    if FEdgeStyle = st95Lowered then
      pen.color := clWhite
    else
      pen.color := clGray;
    lineto(width - 1, height - 1);
    lineto(0, height - 1);
    Pen.Width := 0;
    Brush.Color := FBackColor;
    Pen.Color := FBackColor;
    Rectangle(1, 1, Width - 1, Height - 1);
    if FPercent > 0 then
      UpdateProgress;
  end;
end;

function TW95Meter.RealPercent(High, Low: Real): Integer;
begin
  result := 0;
  if High = 0.0 then
    exit;
  Result := Round((Low / High) * FMax);
end;

function TW95Meter.IntPercent(High, Low: Longint): Integer;
begin
  result := 0;
  if High = 0 then
    exit;
  Result := Round((low / high) * FMax);
end;

procedure TW95Meter.SetAlign(Value: TAlign);
var
  OldAlign: TAlign;
begin
  if FAlign <> Value then
  begin
    OldAlign := FAlign;
    FAlign := Value;
    if not (csLoading in ComponentState) and (not (csDesigning in ComponentState) or
      (Parent <> nil)) then
      if ((OldAlign in [alTop, alBottom]) = (Value in [alRight, alLeft])) and
        not (OldAlign in [alNone, alClient]) and not (Value in [alNone, alClient]) then
        SetBounds(Left, Top, Height, Width)
      else
        AdjustSize;
  end;
end;

procedure TW95Meter.AdjustSize;
begin
  if not (csLoading in ComponentState) then
    SetBounds(Left, Top, Width, Height);
end;

procedure TW95Meter.RequestAlign;
begin
  { if Parent <> nil then Parent.AlignControl(Self); }
end;

procedure TW95Meter.SetDirection(Value: TDirection);
begin
  if Value <> FDirection then
  begin
    FDirection := Value;
    Invalidate;
  end;
end;

end.