pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

Industrial: Make TA3nalogGauge and TLEDNumber high-dpi aware.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6857 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2019-04-22 16:12:52 +00:00
parent 950e85af8f
commit 19acc480ad
5 changed files with 116 additions and 56 deletions
Download Patch File Download Diff File Expand all files Collapse all files

14
components/industrialstuff/Example/u_industrial.lfm
View File

@ -94,22 +94,16 @@ object Form1: TForm1
Width = 120
Caption = 'Voltage'
Value = 50
Color = clPurple
ParentColor = False
ColorFore = clRed
ColorBack = clInactiveCaption
SignalUnit = 'mV'
ValueMin = 0
ValueMax = 100
Digits = 0
Increment = 10
ShowIncrements = True
Transparent = True
GapTop = 10
GapBottom = 5
BarThickness = 6
MarkerColor = clBlue
ShowMarker = True
end
object Arrow1: TArrow
Left = 48
@ -150,12 +144,14 @@ object Form1: TForm1
Height = 35
Top = 180
Width = 504
ColorBetween = 16481536
ColorThumb = 10768896
ColorAbove = clRed
ColorBelow = clYellow
ColorBetween = clGreen
ColorThumb = clBlack
MaxPosition = 75
MinPosition = 25
SliderMode = smMinValueMax
ThumbStyle = tsTriangle
ThumbStyle = tsTriangleOtherSide
OnPositionChange = MultiSlider1PositionChange
end
object ComboBox1: TComboBox

106
components/industrialstuff/source/a3naloggauge.pas
View File

@ -32,6 +32,11 @@ const
foShowMainTicks, foShowSubTicks, foShowIndicatorMax,
foShowValues, foShowCenter, foShowFrame, foShow3D, foShowCaption
];
DEFAULT_CENTER_RADIUS = 8;
DEFAULT_CIRCLE_RADIUS = 3;
DEFAULT_LENGTH_MAINTICKS = 15;
DEFAULT_LENGTH_SUBTICKS = 8;
DEFAULT_MARGIN = 10;
type
TA3nalogGauge = class(TCustomControl)
@ -85,6 +90,11 @@ type
FOnFrames: TNotifyEvent;
{$ENDIF}
// set properties
function IsCenterRadiusStored: Boolean;
function IsCircleRadiusStored: Boolean;
function IsLengthMainTicksStored: Boolean;
function IsLengthSubTicksStored: Boolean;
function IsMarginStored: Boolean;
procedure SetFrameColor(C: TColor);
procedure SetMinColor(C: TColor);
procedure SetMidColor(C: TColor);
@ -118,8 +128,10 @@ type
protected
procedure CaptionFontChanged(Sender: TObject);
procedure DrawScale(Bitmap: TBitmap; K: Integer);
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double); override;
procedure DrawArrow(Bitmap: TBitmap; K: Integer);
procedure DrawScale(Bitmap: TBitmap; K: Integer);
procedure FastAntiAliasPicture;
procedure Loaded; override;
procedure RedrawArrow;
@ -134,6 +146,7 @@ type
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ScaleFontsPPI(const AToPPI: Integer; const AProportion: Double); override;
published
property Angle: Integer
@ -153,11 +166,11 @@ type
property CenterColor: TColor
read FCenterColor write SetCenterColor default clDkGray;
property CenterRadius: Integer
read FCenterRadius write SetCenterRadius default 8;
read FCenterRadius write SetCenterRadius stored IsCenterRadiusStored;
property CircleColor: TColor
read FCircleColor write SetCircleColor default clBlue;
property CircleRadius: Integer
read FCircleRadius write SetCircleRadius default 3;
read FCircleRadius write SetCircleRadius stored IsCircleRadiusStored;
property FaceColor: TColor
read FFaceColor write SetFaceColor default clBtnFace;
property FaceOptions: TFaceOptions
@ -169,11 +182,11 @@ type
property IndMinimum: Integer
read FMinimum write SetMinimum default 20;
property LengthMainTicks: Integer
read FLengthMainTicks write SetLengthMainTicks default 15;
read FLengthMainTicks write SetLengthMainTicks stored IsLengthMainTicksStored;
property LengthSubTicks: Integer
read FLengthSubTicks write SetLengthSubTicks default 8;
read FLengthSubTicks write SetLengthSubTicks stored IsLengthSubTicksStored;
property Margin: Integer
read FMargin write SetMargin default 10;
read FMargin write SetMargin stored IsMarginStored;
property MarginColor: TColor
read FMarginColor write SetMarginColor default clSilver;
property MaxColor: TColor
@ -246,7 +259,7 @@ begin
FValueColor := clBlack;
FCaptionColor := clBlack;
FArrowColor := clBlack;
FMarginColor := clSilver; //Black;
FMarginColor := clSilver;
FCenterColor := clDkGray;
FCircleColor := clBlue;
FMinColor := clGreen;
@ -254,17 +267,17 @@ begin
FMaxColor := clRed;
FArrowWidth := 1;
FPosition := 0;
FMargin := 10;
FMargin := Scale96ToFont(DEFAULT_MARGIN);
FStyle := agsCenterStyle;
FScaleValue := 100;
FMaximum := 80;
FMinimum := 20;
FScaleAngle := 120;
FCircleRadius := 3;
FCenterRadius := 8;
FCircleRadius := Scale96ToFont(DEFAULT_CIRCLE_RADIUS);
FCenterRadius := Scale96ToFont(DEFAULT_CENTER_RADIUS);
FNumMainTicks := 5;
FLengthMainTicks := 15;
FLengthSubTicks := 8;
FLengthMainTicks := Scale96ToFont(DEFAULT_LENGTH_MAINTICKS);
FLengthSubTicks := Scale96ToFont(DEFAULT_LENGTH_SUBTICKS);
FCaption := '';
FFaceOptions := DEFAULT_FACE_OPTIONS;
FAntiAliased := aaNone;
@ -300,6 +313,31 @@ begin
RedrawScale;
end;
procedure TA3nalogGauge.DoAutoAdjustLayout(
const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double);
begin
inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion);
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
begin
DisableAutosizing;
try
if IsCenterRadiusStored then
FCenterRadius := Round(FCenterRadius * AXProportion);
if IsCircleRadiusStored then
FCircleRadius := Round(FCircleRadius * AXProportion);
if IsLengthMainTicksStored then
FLengthMainTicks := Round(FLengthMainTicks * AXProportion);
if IsLengthSubTicksStored then
FLengthSubTicks := Round(FLengthSubTicks * AXProportion);
if IsMarginStored then
FMargin := Round(FMargin * AXProportion);
finally
EnableAutoSizing;
end;
end;
end;
procedure TA3nalogGauge.DrawScale(Bitmap: TBitmap; K: Integer);
var
I, J, X, Y, N, M, W, H, R: Integer;
@ -312,15 +350,16 @@ var
pt: TPoint;
txt: String;
txtDist: Integer;
apw: Integer; // pen width of arc
begin
W := Bitmap.Width;
H := Bitmap.Height;
Max := FMaximum;
Min := FMinimum;
N := FNumMainTicks*5;
N := FNumMainTicks * 5;
M := FMargin * K;
R := FCircleRadius * K;
txtDist := 10;
txtDist := Scale96ToFont(10);
with Bitmap do begin
Canvas.Brush.Color := FFaceColor;
@ -412,8 +451,9 @@ begin
end;
{ Draw min/max indicator arcs }
apw := Scale96ToFont(4 * K);
if (foShowIndicatorMax in FFaceOptions) then begin
SetPenStyles(Canvas.Pen, 4 * K, FMaxColor);
SetPenStyles(Canvas.Pen, apw, FMaxColor);
SinCos(DegToRad(A + FScaleAngle), sinA, cosA);
SinCos(DegToRad(A + Max*FScaleAngle/FScaleValue), sinB, cosB);
Canvas.Arc(X - J, Y - J, X + J, Y + J,
@ -424,7 +464,7 @@ begin
);
end;
if (foShowIndicatorMid in FFaceOptions) and (FMinimum < FMaximum) then begin
SetPenStyles(Canvas.Pen, 4 * K, FMidColor);
SetPenStyles(Canvas.Pen, apw, FMidColor);
SinCos(DegToRad(A + Max*FScaleAngle/FScaleValue), sinA, cosA);
SinCos(DegToRad(A + Min*FScaleAngle/FScaleValue), sinB, cosB);
Canvas.Arc(X - J, Y - J, X + J, Y + J,
@ -435,9 +475,9 @@ begin
);
end;
if (foShowIndicatorMin in FFaceOptions) then begin
SetPenStyles(Canvas.Pen, apw, FMinColor);
SinCos(DegToRad(A + Min*FScaleAngle/FScaleValue), sinA, cosA);
SinCos(DegToRad(A), sinB, cosB);
SetPenStyles(Canvas.Pen, 4 * K, FMinColor);
Canvas.Arc(X - J, Y - J, X + J, Y + J,
Round(C - J * cosA),
Round(Y - J * sinA),
@ -757,6 +797,31 @@ begin
end;
}
function TA3nalogGauge.IsCenterRadiusStored: Boolean;
begin
Result := FCenterRadius <> Scale96ToFont(DEFAULT_CENTER_RADIUS);
end;
function TA3nalogGauge.IsCircleRadiusStored: Boolean;
begin
Result := FCircleRadius <> Scale96ToFont(DEFAULT_CIRCLE_RADIUS);
end;
function TA3nalogGauge.IsLengthMainTicksStored: Boolean;
begin
Result := FLengthMainTicks <> Scale96ToFont(DEFAULT_LENGTH_MAINTICKS);
end;
function TA3nalogGauge.IsLengthSubTicksStored: Boolean;
begin
Result := FLengthSubTicks <> Scale96ToFont(DEFAULT_LENGTH_SUBTICKS);
end;
function TA3nalogGauge.IsMarginStored: Boolean;
begin
Result := FMargin <> Scale96ToFont(DEFAULT_MARGIN);
end;
procedure TA3nalogGauge.Loaded;
begin
inherited;
@ -813,6 +878,13 @@ begin
inherited;
end;
procedure TA3nalogGauge.ScaleFontsPPI(const AToPPI: Integer;
const AProportion: Double);
begin
inherited;
DoScaleFontPPI(FCaptionFont, AToPPI, AProportion);
end;
procedure TA3nalogGauge.SetCaptionFont(AValue: TFont);
begin
FCaptionFont.Assign(AValue);

21
components/industrialstuff/source/indgnoumeter.pas
View File

@ -106,15 +106,15 @@ type
property Color;
property Font;
property ParentColor;
property ColorFore: Tcolor read fColorFore write SetColorFore;
property ColorBack: Tcolor read fColorBack write SetColorBack;
property ColorFore: Tcolor read fColorFore write SetColorFore default clRed;
property ColorBack: Tcolor read fColorBack write SetColorBack default clBtnFace;
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 ShowIncrements: Boolean read fShowIncrements write SetShowIncrements default true;
property Transparent: Boolean read GetTransparent write SetTransparent default true;
property GapTop: Word
read fGapTop write SetGapTop stored IsGapTopStored;
property GapBottom: Word
@ -126,7 +126,7 @@ type
read fMarkerDist write SetMarkerDist stored IsMarkerDistStored;
property MarkerSize: Integer
read fMarkerSize write SetMarkerSize stored IsMarkerSizeStored;
property ShowMarker: Boolean read fShowMarker write SetShowMarker;
property ShowMarker: Boolean read fShowMarker write SetShowMarker default true;
end;
@ -462,9 +462,9 @@ begin
with Canvas do
begin
TheRect := ClientRect;
TheRect.Left := LeftMeter + BarThickness + 10;
TheRect.Left := LeftMeter + BarThickness + Scale96ToFont(10);
TheRect.Top := TopTextHeight;
TheRect.Bottom := Height - fGapBottom + 6;
TheRect.Bottom := Height - fGapBottom + Scale96ToFont(6);
Brush.Style := bsClear;
DrawStyle := DT_SINGLELINE + DT_NOPREFIX + DT_LEFT + DT_BOTTOM;
DisplayValue := FloatToStrF(ValueMin, ffFixed, 8, fDigits) + ' ' + fSignalUnit;
@ -478,8 +478,8 @@ begin
with Canvas do
begin
TheRect := ClientRect;
TheRect.Left := LeftMeter + BarThickness + 10;
TheRect.Top := TopTextHeight - 6;
TheRect.Left := LeftMeter + BarThickness + Scale96ToFont(10);
TheRect.Top := TopTextHeight - Scale96ToFont(6);
Brush.Style := bsClear;
DrawStyle := DT_SINGLELINE + DT_NOPREFIX + DT_LEFT + DT_TOP;
DisplayValue := FloatToStrF(ValueMax, ffFixed, 8, fDigits) + ' ' + fSignalUnit;
@ -523,7 +523,6 @@ begin
MoveTo(LeftMeter + 1, ValueToPixels(fValue) - 1);
LineTo(LeftMeter + fBarThickness, ValueToPixels(fValue) - 1);
end;
end;
end;
@ -541,7 +540,7 @@ end;
procedure TindGnouMeter.Paint;
begin
LeftMeter := (Width div 2) - 10 - fBarThickness;
LeftMeter := (Width div 2) - Scale96ToFont(10) - fBarThickness;
with Canvas do
begin
if not Transparent then

8
components/industrialstuff/source/lednumber.pas
View File

@ -311,8 +311,8 @@ var
I : Integer;
begin
for I := 0 to MAX_POINTS do begin
Points[i].X := DigitPoints[i].X * (FSize - 1);
Points[i].Y := DigitPoints[i].Y * (FSize - 1);
Points[i].X := Scale96ToFont(DigitPoints[i].X * (FSize - 1));
Points[i].Y := Scale96ToFont(DigitPoints[i].Y * (FSize - 1));
end;
end;
{=====}
@ -320,9 +320,9 @@ end;
function TCustomLEDNumber.NewOffset(xOry: char; OldOffset: Integer): Integer;
begin
if (xOry = 'x')then
newOffset := oldOffset + 17 * (FSize - 1)
newOffset := oldOffset + Scale96ToFont(17 * (FSize - 1))
else
newOffset := oldOffset + 30 * (FSize -1)
newOffset := oldOffset + Scale96ToFont(30 * (FSize -1))
end;
{=====}

23
components/industrialstuff/source/sensors.pas
View File

@ -137,14 +137,9 @@ begin
with FlblShowText do
begin
Alignment := taCenter;
AutoSize := False;
Font := Self.Font;
Height := 17;
Left := 5;
Top := 57;
Width := 160;
Parent := Self;
Align := alBottom;
Font := Self.Font;
Parent := Self;
end;
FShowLevel := True;
@ -325,8 +320,8 @@ var
begin
X := Scale96ToFont(20);
Y := Scale96ToFont(23);
W := ClientWidth - 2*X;
H := ClientHeight - 2*Y;
W := ClientWidth - 2*X; //130;
H := ClientHeight - 2*Y; //33;
if (W < 1) or (H < 1) then Exit;
with Canvas do
@ -366,9 +361,8 @@ begin
end;
procedure TAnalogSensor.PaintAsHorizontal;
var
MiddleX: Integer;
X, Y, W, H: Integer;
var MiddleX: Integer;
X, Y, W, H: Integer;
begin
X := Scale96ToFont(20);
Y := Scale96ToFont(23);
@ -408,9 +402,8 @@ begin
end;
procedure TAnalogSensor.PaintAsVertical;
var
MiddleY: Integer;
X, Y, W, H: Integer;
var MiddleY: Integer;
X, Y, W, H: Integer;
begin
X := Scale96ToFont(20);
Y := Scale96ToFont(23);