How to create a vertical progress bar and fill it from top to bottom (Views: 29)
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. |