mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-08 17:52:41 +02:00
449 lines
11 KiB
ObjectPascal
449 lines
11 KiB
ObjectPascal
|
|
{**********************************************************************
|
|
extracted from Package pl_ExControls.pkg
|
|
From PilotLogic Software House
|
|
for CodeTyphon Project (http://www.pilotlogic.com/)
|
|
This unit is part of CodeTyphon Project
|
|
used by Lazarus for Industrial package
|
|
***********************************************************************}
|
|
|
|
unit indGnouMeter;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, Controls, Graphics, SysUtils, Messages, LMessages, Types, LCLType, LCLIntf;
|
|
|
|
type
|
|
TindGnouMeter = class(TGraphicControl)
|
|
private
|
|
fValue: Double;
|
|
fColorFore: TColor;
|
|
fColorBack: TColor;
|
|
fSignalUnit: ShortString;
|
|
fValueMax: Double;
|
|
fValueMin: Double;
|
|
fDigits: Byte;
|
|
fIncrement: Double;
|
|
fShowIncrements: Boolean;
|
|
fGapTop: Word;
|
|
fGapBottom: Word;
|
|
fBarThickness: Word;
|
|
fMarkerColor: TColor;
|
|
fShowMarker: Boolean;
|
|
//Variables used internally
|
|
TopTextHeight: Word;
|
|
LeftMeter: Word;
|
|
DisplayValue: String;
|
|
DrawStyle: integer;
|
|
TheRect: TRect;
|
|
//End of variables used internally
|
|
procedure SetValue(val: Double);
|
|
procedure SetColorBack(val: TColor);
|
|
procedure SetColorFore(val: TColor);
|
|
procedure SetSignalUnit(val: ShortString);
|
|
procedure SetValueMin(val: Double);
|
|
procedure SetValueMax(val: Double);
|
|
procedure SetDigits(val: Byte);
|
|
procedure SetTransparent(val: Boolean);
|
|
function GetTransparent: Boolean;
|
|
procedure SetIncrement(val: Double);
|
|
procedure SetShowIncrements(val: Boolean);
|
|
procedure SetGapTop(val: Word);
|
|
procedure SetGapBottom(val: Word);
|
|
procedure SetBarThickness(val: Word);
|
|
procedure SetMarkerColor(val: TColor);
|
|
procedure SetShowMarker(val: Boolean);
|
|
procedure DrawTopText;
|
|
procedure DrawMeterBar;
|
|
procedure DrawIncrements;
|
|
function ValueToPixels(val: Double): integer;
|
|
procedure DrawValueMax;
|
|
procedure DrawValueMin;
|
|
procedure DrawMarker;
|
|
protected
|
|
procedure Paint; override;
|
|
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
published
|
|
property Align;
|
|
property Caption;
|
|
property Visible;
|
|
property ShowHint;
|
|
property Value: Double read fValue write SetValue;
|
|
property Color;
|
|
property Font;
|
|
property ParentColor;
|
|
property ColorFore: Tcolor read fColorFore write SetColorFore;
|
|
property ColorBack: Tcolor read fColorBack write SetColorBack;
|
|
property SignalUnit: ShortString read fSignalUnit write SetSignalUnit;
|
|
property ValueMin: Double read fValueMin write SetValueMin;
|
|
property ValueMax: Double read fValueMax write SetValueMax;
|
|
property Digits: Byte read fDigits write SetDigits;
|
|
property Increment: Double read fIncrement write SetIncrement;
|
|
property ShowIncrements: Boolean read fShowIncrements write SetShowIncrements;
|
|
property Transparent: Boolean read GetTransparent write SetTransparent;
|
|
property GapTop: Word read fGapTop write SetGapTop;
|
|
property GapBottom: Word read fGapBottom write SetGapBottom;
|
|
property BarThickness: Word read fBarThickness write SetBarThickness;
|
|
property MarkerColor: TColor read fMarkerColor write SetMarkerColor;
|
|
property ShowMarker: Boolean read fShowMarker write SetShowMarker;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
constructor TindGnouMeter.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
ControlStyle := ControlStyle + [csReplicatable, csSetCaption];
|
|
Width := 100;
|
|
Height := 200;
|
|
fColorFore := clRed;
|
|
fColorBack := clBtnFace;
|
|
fMarkerColor := clBlue;
|
|
fValueMin := 0;
|
|
fValueMax := 100;
|
|
fIncrement := 10;
|
|
fShowIncrements := True;
|
|
fShowMarker := True;
|
|
fValue := 0;
|
|
fGapTop := 20;
|
|
fGapBottom := 10;
|
|
fBarThickness := 5;
|
|
fSignalUnit := 'Units';
|
|
end;
|
|
|
|
destructor TindGnouMeter.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TindGnouMeter.CMTextChanged(var Message: TMessage);
|
|
begin
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetValue(val: Double);
|
|
begin
|
|
if (val <> fValue) and (val >= fValueMin) and (val <= fValueMax) then
|
|
begin
|
|
fValue := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetColorFore(val: TColor);
|
|
begin
|
|
if val <> fColorFore then
|
|
begin
|
|
fColorFore := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetColorBack(val: TColor);
|
|
begin
|
|
if val <> fColorBack then
|
|
begin
|
|
fColorBack := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetSignalUnit(val: ShortString);
|
|
begin
|
|
if val <> fSignalUnit then
|
|
begin
|
|
fSignalUnit := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetValueMin(val: Double);
|
|
begin
|
|
if (val <> fValueMin) and (val <= fValue) then
|
|
begin
|
|
fValueMin := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetValueMax(val: Double);
|
|
begin
|
|
if (val <> fValueMax) and (val >= fValue) then
|
|
begin
|
|
fValueMax := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetDigits(val: Byte);
|
|
begin
|
|
if (val <> fDigits) then
|
|
begin
|
|
fDigits := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetIncrement(val: Double);
|
|
begin
|
|
if (val <> fIncrement) and (val > 0) then
|
|
begin
|
|
fIncrement := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetShowIncrements(val: Boolean);
|
|
begin
|
|
if (val <> fShowIncrements) then
|
|
begin
|
|
fShowIncrements := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
function TindGnouMeter.GetTransparent: Boolean;
|
|
begin
|
|
Result := not (csOpaque in ControlStyle);
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetTransparent(Val: Boolean);
|
|
begin
|
|
if Val <> Transparent then
|
|
begin
|
|
if Val then
|
|
ControlStyle := ControlStyle - [csOpaque]
|
|
else
|
|
ControlStyle := ControlStyle + [csOpaque];
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetGapTop(val: Word);
|
|
begin
|
|
if (val <> fGapTop) then
|
|
begin
|
|
fGapTop := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetGapBottom(val: Word);
|
|
begin
|
|
if (val <> fGapBottom) then
|
|
begin
|
|
fGapBottom := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetBarThickness(val: Word);
|
|
begin
|
|
if (val <> fBarThickness) and (val > 0) then
|
|
begin
|
|
fBarThickness := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetMarkerColor(val: TColor);
|
|
begin
|
|
if (val <> fMarkerColor) then
|
|
begin
|
|
fMarkerColor := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.SetShowMarker(val: Boolean);
|
|
begin
|
|
if (val <> fShowMarker) then
|
|
begin
|
|
fShowMarker := val;
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.DrawIncrements;
|
|
var
|
|
i: Double;
|
|
PosPixels: Word;
|
|
begin
|
|
if fShowIncrements then
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
i := fValueMin;
|
|
while i <= fValueMax do
|
|
begin
|
|
PosPixels := ValueToPixels(i);
|
|
pen.color := clGray;
|
|
MoveTo(LeftMeter + BarThickness + 3, PosPixels - 1);
|
|
LineTo(LeftMeter + BarThickness + 7, PosPixels - 1);
|
|
pen.color := clWhite;
|
|
MoveTo(LeftMeter + BarThickness + 3, PosPixels);
|
|
LineTo(LeftMeter + BarThickness + 7, PosPixels);
|
|
i := i + fIncrement;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.DrawMarker;
|
|
begin
|
|
if fShowMarker then
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
pen.color := clWhite;
|
|
Brush.Style := bsClear;
|
|
MoveTo(LeftMeter - 2, ValueToPixels(fValue));
|
|
LineTo(LeftMeter - 6, ValueToPixels(fValue) - 4);
|
|
LineTo(LeftMeter - 6, ValueToPixels(fValue) + 4);
|
|
pen.color := clGray;
|
|
LineTo(LeftMeter - 2, ValueToPixels(fValue));
|
|
|
|
pen.color := fMarkerColor;
|
|
Brush.color := fMarkerColor;
|
|
Brush.Style := bsSolid;
|
|
Polygon([Point(LeftMeter - 3, ValueToPixels(fValue)),
|
|
Point(LeftMeter - 5, ValueToPixels(fValue) - 2),
|
|
Point(LeftMeter - 5, ValueToPixels(fValue) + 2),
|
|
Point(LeftMeter - 3, ValueToPixels(fValue))]);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.DrawTopText;
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
DisplayValue := Caption;
|
|
Brush.Style := bsClear;
|
|
TheRect := ClientRect;
|
|
DrawStyle := DT_SINGLELINE + DT_NOPREFIX + DT_CENTER + DT_TOP;
|
|
Font.Style := [fsBold];
|
|
TopTextHeight := DrawText(Handle, PChar(DisplayValue),
|
|
Length(DisplayValue), TheRect, DrawStyle);
|
|
|
|
Font.Style := [];
|
|
TheRect.Top := TopTextHeight;
|
|
DisplayValue := FloatToStrF(Value, ffFixed, 8, fDigits) + ' ' + fSignalUnit;
|
|
TopTextHeight := TopTextHeight + DrawText(Handle, PChar(DisplayValue),
|
|
Length(DisplayValue), TheRect, DrawStyle);
|
|
TopTextHeight := TopTextHeight + fGapTop;
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.DrawValueMin;
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
TheRect := ClientRect;
|
|
TheRect.Left := LeftMeter + BarThickness + 10;
|
|
TheRect.Top := TopTextHeight;
|
|
TheRect.Bottom := Height - fGapBottom + 6;
|
|
Brush.Style := bsClear;
|
|
DrawStyle := DT_SINGLELINE + DT_NOPREFIX + DT_LEFT + DT_BOTTOM;
|
|
DisplayValue := FloatToStrF(ValueMin, ffFixed, 8, fDigits) + ' ' + fSignalUnit;
|
|
DrawText(Handle, PChar(DisplayValue), Length(DisplayValue),
|
|
TheRect, DrawStyle);
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.DrawValueMax;
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
TheRect := ClientRect;
|
|
TheRect.Left := LeftMeter + BarThickness + 10;
|
|
TheRect.Top := TopTextHeight - 6;
|
|
Brush.Style := bsClear;
|
|
DrawStyle := DT_SINGLELINE + DT_NOPREFIX + DT_LEFT + DT_TOP;
|
|
DisplayValue := FloatToStrF(ValueMax, ffFixed, 8, fDigits) + ' ' + fSignalUnit;
|
|
DrawText(Handle, PChar(DisplayValue), Length(DisplayValue),
|
|
TheRect, DrawStyle);
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.DrawMeterBar;
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
pen.Color := fColorBack;
|
|
Brush.Color := fColorBack;
|
|
Brush.Style := bsSolid;
|
|
Rectangle(LeftMeter, ValueToPixels(fValueMax), LeftMeter +
|
|
fBarThickness, ValueToPixels(fValueMin));
|
|
|
|
pen.Color := fColorFore;
|
|
Brush.Color := fColorFore;
|
|
Brush.Style := bsSolid;
|
|
Rectangle(LeftMeter + 1, ValueToPixels(fValue), LeftMeter +
|
|
fBarThickness, ValueToPixels(fValueMin));
|
|
|
|
pen.color := clWhite;
|
|
Brush.Style := bsClear;
|
|
MoveTo(LeftMeter + fBarThickness - 1, ValueToPixels(fValueMax));
|
|
LineTo(LeftMeter, ValueToPixels(fValueMax));
|
|
LineTo(LeftMeter, ValueToPixels(fValueMin) - 1);
|
|
|
|
pen.color := clGray;
|
|
LineTo(LeftMeter + fBarThickness, ValueToPixels(fValueMin) - 1);
|
|
LineTo(LeftMeter + fBarThickness, ValueToPixels(fValueMax));
|
|
|
|
if (fValue > fValueMin) and (fValue < fValueMax) then
|
|
begin
|
|
pen.color := clWhite;
|
|
MoveTo(LeftMeter + 1, ValueToPixels(fValue));
|
|
LineTo(LeftMeter + fBarThickness, ValueToPixels(fValue));
|
|
pen.color := clGray;
|
|
MoveTo(LeftMeter + 1, ValueToPixels(fValue) - 1);
|
|
LineTo(LeftMeter + fBarThickness, ValueToPixels(fValue) - 1);
|
|
end;
|
|
|
|
end;
|
|
end;
|
|
|
|
function TindGnouMeter.ValueToPixels(val: Double): integer;
|
|
var
|
|
factor: Double;
|
|
begin
|
|
Result := 0;
|
|
if fValueMax > fValueMin then
|
|
begin
|
|
Factor := (Height - fGapBottom - TopTextHeight) / (fValueMin - fValueMax);
|
|
Result := Round(Factor * val - Factor * fValueMax + TopTextHeight);
|
|
end;
|
|
end;
|
|
|
|
procedure TindGnouMeter.Paint;
|
|
begin
|
|
LeftMeter := (Width div 2) - 10 - fBarThickness;
|
|
with Canvas do
|
|
begin
|
|
if not Transparent then
|
|
begin
|
|
Brush.Color := Self.Color;
|
|
Brush.Style := bsSolid;
|
|
FillRect(ClientRect);
|
|
end;
|
|
Brush.Style := bsClear;
|
|
DrawTopText;
|
|
DrawValueMin;
|
|
DrawValueMax;
|
|
DrawMeterBar;
|
|
DrawMarker;
|
|
DrawIncrements;
|
|
end;
|
|
end;
|
|
|
|
end.
|