Mega Code Archive
Gauge with 3 levels
<![CDATA[
Title: Gauge with 3 levels
Question: How can I have a gauge with 3 levels
Answer:
unit RVGaugeLevel;
interface
uses
SysUtils, Classes, Controls, Graphics, Windows;
type
//Four different orientations
TOrientation = (goLeftToRight, goRightToLeft, goBottomToTop, goTopToBottom);
TRVGaugeLevel = class(TGraphicControl)
private
FColorLevel1: TColor; //Color for level 1
FColorLevel2: TColor; //Color for level 2
FColorLevel3: TColor; //Color for level 3
FProgress : Integer;
FOrientation: TOrientation;
FGap : Integer; //Space around bar
procedure SetColorLevel1(const Value: TColor);
procedure SetColorLevel2(const Value: TColor);
procedure SetColorLevel3(const Value: TColor);
procedure SetProgress(const Value: Integer);
procedure SetOrientation(const Value: TOrientation);
procedure SetGap(const Value: Integer);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
published
property Anchors;
property ColorLevel1: TColor read FColorLevel1 write SetColorLevel1;
property ColorLevel2: TColor read FColorLevel2 write SetColorLevel2;
property ColorLevel3: TColor read FColorLevel3 write SetColorLevel3;
property Gap: Integer read FGap write SetGap;
property Orientation: TOrientation read FOrientation write SetOrientation;
property Progress: Integer read FProgress write SetProgress;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Rendez-vous', [TRVGaugeLevel]);
end;
{ TRVGaugeLevel }
constructor TRVGaugeLevel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FColorLevel1 := clLime;
FColorLevel2 := clYellow;
FColorLevel3 := clRed;
FGap := 2;
FOrientation := goLeftToRight;
FProgress := 50;
end;
procedure TRVGaugeLevel.SetColorLevel1(const Value: TColor);
begin
if FColorLevel1 Value then
begin
FColorLevel1 := Value;
Invalidate;
end;
end;
procedure TRVGaugeLevel.SetColorLevel2(const Value: TColor);
begin
if FColorLevel2 Value then
begin
FColorLevel2 := Value;
Invalidate;
end;
end;
procedure TRVGaugeLevel.SetColorLevel3(const Value: TColor);
begin
if FColorLevel3 Value then
begin
FColorLevel3 := Value;
Invalidate;
end;
end;
procedure TRVGaugeLevel.SetOrientation(const Value: TOrientation);
begin
if FOrientation Value then
begin
FOrientation := Value;
Invalidate;
end;
end;
procedure TRVGaugeLevel.SetProgress(const Value: Integer);
begin
if FProgress Value then
begin
FProgress := Value;
if FProgress else if FProgress 100 then FProgress := 100;
Invalidate;
end;
end;
procedure TRVGaugeLevel.Paint;
var
R1 : TRect;
R2 : TRect;
CL1 : TColor;
CL2 : TColor;
CL3 : TColor;
R,G,B: Byte;
Wdt : Integer;
I : Integer;
Pct : Integer;
Spc : Integer;
begin
R1 := ClientRect;
//Calculate the background color for level 1
CL1 := ColorToRGB(FColorLevel1);
R := GetRValue(CL1);
G := GetGValue(CL1);
B := GetBValue(CL1);
if R 0 then R := R - 128;
if G 0 then G := G - 128;
if B 0 then B := B - 128;
CL1 := RGB(R, G, B);
//Calculate the background color for level 2
CL2 := ColorToRGB(FColorLevel2);
R := GetRValue(CL2);
G := GetGValue(CL2);
B := GetBValue(CL2);
if R 0 then R := R - 128;
if G 0 then G := G - 128;
if B 0 then B := B - 128;
CL2 := RGB(R, G, B);
//Calculate the background color for level 3
CL3 := ColorToRGB(FColorLevel3);
R := GetRValue(CL3);
G := GetGValue(CL3);
B := GetBValue(CL3);
if R 0 then R := R - 128;
if G 0 then G := G - 128;
if B 0 then B := B - 128;
CL3 := RGB(R, G, B);
//Draw the 3D frame
Canvas.Brush.Color := clBtnHighlight;
Canvas.FrameRect(R1);
Canvas.Pen.Color := clBtnShadow;
Canvas.MoveTo(R1.Left, R1.Bottom - 1);
Canvas.LineTo(R1.Left, R1.Top);
Canvas.LineTo(R1.Right - 1, R1.Top);
//Fill inside the 3D frame
InflateRect(R1, -1, -1);
Canvas.Brush.Color := clBlack;
Canvas.FillRect(R1);
//Ajust de drawing area
InflateRect(R1, FGap * -1, FGap * -1);
//Paint de gauge
if FOrientation = goLeftToRight then
begin
Spc := 0;
Wdt := (R1.Right - R1.Left) div (FGap * 2);
for I := 0 to Wdt do
begin
Pct := (I * 100) div Wdt;
if Pct in [000..050] then
begin
if (FProgress 0) and (Pct else Canvas.Brush.Color := CL1;
end
else if Pct in [051..075] then
begin
if Pct else Canvas.Brush.Color := CL2;
end
else if Pct in [076..100] then
begin
if Pct else Canvas.Brush.Color := CL3;
end;
R2.Top := R1.Top;
R2.Bottom := R1.Bottom;
R2.Left := R1.Left + Spc;
R2.Right := R1.Left + FGap + Spc;
Canvas.FillRect(R2);
Spc := Spc + (FGap * 2);
end;
end
else if FOrientation = goRightToleft then
begin
Spc := 0;
Wdt := (R1.Right - R1.Left) div (FGap * 2);
for I := Wdt downto 0 do
begin
Pct := (I * 100) div Wdt;
if Pct in [000..050] then
begin
if (FProgress 0) and (Pct else Canvas.Brush.Color := CL1;
end
else if Pct in [051..075] then
begin
if Pct else Canvas.Brush.Color := CL2;
end
else if Pct in [076..100] then
begin
if Pct else Canvas.Brush.Color := CL3;
end;
R2.Top := R1.Top;
R2.Bottom := R1.Bottom;
R2.Left := R1.Left + Spc;
R2.Right := R1.Left + FGap + Spc;
Canvas.FillRect(R2);
Spc := Spc + (FGap * 2);
end;
end
else if FOrientation = goTopToBottom then
begin
Spc := 0;
Wdt := (R1.Bottom - R1.Top) div (FGap * 2);
for I := 0 to Wdt do
begin
Pct := (I * 100) div Wdt;
if Pct in [000..050] then
begin
if (FProgress 0) and (Pct else Canvas.Brush.Color := CL1;
end
else if Pct in [051..075] then
begin
if Pct else Canvas.Brush.Color := CL2;
end
else if Pct in [076..100] then
begin
if Pct else Canvas.Brush.Color := CL3;
end;
R2.Top := R1.Top + Spc;
R2.Bottom := R1.Top + FGap + Spc;
R2.Left := R1.Left;
R2.Right := R1.Right;
Canvas.FillRect(R2);
Spc := Spc + (FGap * 2);
end;
end
else
begin
Spc := 0;
Wdt := (R1.Bottom - R1.Top) div (FGap * 2);
for I := Wdt downto 0 do
begin
Pct := (I * 100) div Wdt;
if Pct in [000..050] then
begin
if (FProgress 0) and (Pct else Canvas.Brush.Color := CL1;
end
else if Pct in [051..075] then
begin
if Pct else Canvas.Brush.Color := CL2;
end
else if Pct in [076..100] then
begin
if Pct else Canvas.Brush.Color := CL3;
end;
R2.Top := R1.Top + Spc;
R2.Bottom := R1.Top + FGap + Spc;
R2.Left := R1.Left;
R2.Right := R1.Right;
Canvas.FillRect(R2);
Spc := Spc + (FGap * 2);
end;
end;
end;
procedure TRVGaugeLevel.SetGap(const Value: Integer);
begin
if FGap Value then
begin
//Gap can't be if Value else FGap := Value;
Invalidate;
end;
end;
end.
]]>