// SPDX-License-Identifier: LGPL-3.0-linking-exception { Part of BGRA Controls. Made by third party. For detailed information see readme.txt Site: https://sourceforge.net/p/bgra-controls/ Wiki: http://wiki.lazarus.freepascal.org/BGRAControls Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html } unit DTAnalogCommon; {$mode objfpc}{$H+} interface uses Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, BGRABitmap, BGRABitmapTypes; type TDTFillStyle = (fsnone, fsGradient{, fsTexture}); TDTNeedleStyle = (nsLine, nsTriangle{, nsLineExt, nsTriangleExt}); { TDTOrigin } TDTOrigin = packed record CenterPoint: TPoint; Radius: integer; end; { TDTPointerCapSettings } TDTPointerCapSettings = class(TPersistent) private FEdgeColor: TColor; FEdgeThickness: integer; FFillColor: TColor; FOnChange: TNotifyEvent; FRadius: integer; procedure SetEdgeColor(AValue: TColor); procedure SetEdgeThickness(AValue: integer); procedure SetFillColor(AValue: TColor); procedure SetOnChange(AValue: TNotifyEvent); procedure SetRadius(AValue: integer); protected public constructor Create; destructor Destroy; override; property OnChange: TNotifyEvent read FOnChange write SetOnChange; published property EdgeColor: TColor read FEdgeColor write SetEdgeColor; property FillColor: TColor read FFillColor write SetFillColor; property Radius: integer read FRadius write SetRadius; property EdgeThickness: integer read FEdgeThickness write SetEdgeThickness; end; { TDTPointerSettings } TDTPointerSettings = class(TPersistent) private FColor: TColor; FLength: integer; FOnChange: TNotifyEvent; FThickness: integer; procedure SetColor(AValue: TColor); procedure SetLength(AValue: integer); procedure SetOnChange(AValue: TNotifyEvent); procedure SetThickness(AValue: integer); protected public constructor Create; destructor Destroy; override; property OnChange: TNotifyEvent read FOnChange write SetOnChange; published property Color: TColor read FColor write SetColor; property Length: integer read FLength write SetLength; property Thickness: integer read FThickness write SetThickness; end; { TDTNeedleSettings } TDTNeedleSettings = class(TPersistent) private FCapColor: TColor; FCapEdgeColor: TColor; FCapRadius: integer; FNeedleColor: TColor; FNeedleLength: integer; FNeedleStyle: TDTNeedleStyle; FOnChange: TNotifyEvent; procedure SetCapColor(AValue: TColor); procedure SetCapEdgeColor(AValue: TColor); procedure SetCapRadius(AValue: integer); procedure SetNeedleColor(AValue: TColor); procedure SetNeedleLength(AValue: integer); procedure SetNeedleStyle(AValue: TDTNeedleStyle); procedure SetOnChange(AValue: TNotifyEvent); protected public constructor Create; destructor Destroy; override; property OnChange: TNotifyEvent read FOnChange write SetOnChange; property NeedleStyle: TDTNeedleStyle read FNeedleStyle write SetNeedleStyle; published property NeedleColor: TColor read FNeedleColor write SetNeedleColor; property NeedleLength: integer read FNeedleLength write SetNeedleLength; property CapRadius: integer read FCapRadius write SetCapRadius; property CapColor: TColor read FCapColor write SetCapColor; property CapEdgeColor: TColor read FCapEdgeColor write SetCapEdgeColor; end; { TDTScaleSettings } TDTScaleSettings = class(TPersistent) private FEnableScaleText: boolean; FMaximum: integer; FTesting: boolean; FTextFont: string; FTextRadius: integer; FTextSize: integer; FTickColor: TColor; FEnableMainTicks: boolean; FEnableRangeIndicator: boolean; FEnableSubTicks: boolean; FLengthMainTick: integer; FLengthSubTick: integer; FMainTickCount: integer; FMinimum: integer; FOnChange: TNotifyEvent; FSubTickCount: integer; FTextColor: TColor; FThicknessMainTick: integer; FThicknessSubTick: integer; FAngle: integer; procedure SetEnableScaleText(AValue: boolean); procedure SetFAngle(AValue: integer); procedure SetMaximum(AValue: integer); procedure SetTesting(AValue: boolean); procedure SetTextFont(AValue: string); procedure SetTextRadius(AValue: integer); procedure SetTextSize(AValue: integer); procedure SetTickColor(AValue: TColor); procedure SetEnableMainTicks(AValue: boolean); procedure SetEnableRangeIndicator(AValue: boolean); procedure SetEnableSubTicks(AValue: boolean); procedure SetLengthMainTick(AValue: integer); procedure SetLengthSubTick(AValue: integer); procedure SetMainTickCount(AValue: integer); procedure SetOnChange(AValue: TNotifyEvent); procedure SetSubTickCount(AValue: integer); procedure SetTextColor(AValue: TColor); procedure SetThicknessMainTick(AValue: integer); procedure SetThicknessSubTick(AValue: integer); protected property Testing: boolean read FTesting write SetTesting; public constructor Create; destructor Destroy; override; property OnChange: TNotifyEvent read FOnChange write SetOnChange; published property TickColor: TColor read FTickColor write SetTickColor; property TextColor: TColor read FTextColor write SetTextColor; property TextSize: integer read FTextSize write SetTextSize; property TextFont: string read FTextFont write SetTextFont; property EnableMainTicks: boolean read FEnableMainTicks write SetEnableMainTicks; property EnableSubTicks: boolean read FEnableSubTicks write SetEnableSubTicks; property EnableScaleText: boolean read FEnableScaleText write SetEnableScaleText; property Maximum: integer read FMaximum write SetMaximum; property MainTickCount: integer read FMainTickCount write SetMainTickCount; property SubTickCount: integer read FSubTickCount write SetSubTickCount; property LengthMainTick: integer read FLengthMainTick write SetLengthMainTick; property LengthSubTick: integer read FLengthSubTick write SetLengthSubTick; property ThicknessMainTick: integer read FThicknessMainTick write SetThicknessMainTick; property ThicknessSubTick: integer read FThicknessSubTick write SetThicknessSubTick; property TextRadius: integer read FTextRadius write SetTextRadius; property Angle: integer read FAngle write SetFAngle; property EnableRangeIndicator: boolean read FEnableRangeIndicator write SetEnableRangeIndicator; //property RangeMinValue: integer read FRangeMinValue write SetRangeMinValue; //property RangeMidValue: integer read FRangeMidValue write SetRangeMidValue; //property RangeMaxValue: integer read FRangeMaxValue write SetRangeMaxValue; //property RangeMinColor: TColor read FRangeMinColor write SetRangeMinColor; //property RangeMidColor: TColor read FRangeMidColor write SetRangeMidColor; //property RangeMaxColor: TColor read FRangeMaxColor write SetRangeMaxColor; end; { TDTFaceSettings } TDTFaceSettings = class(TPersistent) private FColorEnd: TColor; FColorFrame: TColor; FColorStart: TColor; FFillStyle: TDTFillStyle; FOnChange: TNotifyEvent; procedure SetColorEnd(AValue: TColor); procedure SetColorFrame(AValue: TColor); procedure SetColorStart(AValue: TColor); procedure SetFillStyle(AValue: TDTFillStyle); procedure SetOnChange(AValue: TNotifyEvent); protected public constructor Create; destructor Destroy; override; property OnChange: TNotifyEvent read FOnChange write SetOnChange; published property FillStyle: TDTFillStyle read FFillStyle write SetFillStyle; property ColorFrame: TColor read FColorFrame write SetColorFrame; property ColorStart: TColor read FColorStart write SetColorStart; property ColorEnd: TColor read FColorEnd write SetColorEnd; end; { TDTBaseAnalogDevice } TDTBaseAnalogDevice = class(TGraphicControl) private FFaceSettings: TDTFaceSettings; FScaleSettings: TDTScaleSettings; procedure SetFaceSettings(AValue: TDTFaceSettings); procedure SetScaleSettings(AValue: TDTScaleSettings); protected procedure DoChange({%H-}Sender: TObject); public fGaugeBitmap: TBGRABitmap; FFrameBitmap: TBGRABitmap; FFaceBitmap: TBGRABitmap; constructor Create(AOwner: TComponent); override; destructor Destroy; override; property FaceSettings: TDTFaceSettings read FFaceSettings write SetFaceSettings; property ScaleSettings: TDTScaleSettings read FScaleSettings write SetScaleSettings; procedure Paint; override; procedure DrawGauge; procedure DrawFrame; procedure DrawFace; end; function Initializebitmap(var Bitmap: TBGRABitmap; Width, Height: integer): TDTOrigin; implementation function Initializebitmap(var Bitmap: TBGRABitmap; Width, Height: integer): TDTOrigin; begin Bitmap.SetSize(Width, Height); // Clear bitmap to transparent BitMap.Fill(BGRA(0, 0, 0, 0)); // Get origin information Result.CenterPoint.x := Width div 2; Result.CenterPoint.y := Height div 2; Result.Radius := Result.CenterPoint.y; if Result.CenterPoint.x > Result.CenterPoint.y then Result.Radius := Result.CenterPoint.y; if Result.CenterPoint.x < Result.CenterPoint.y then Result.Radius := Result.CenterPoint.x; end; { TDTPointerCapSettings } procedure TDTPointerCapSettings.SetEdgeColor(AValue: TColor); begin if FEdgeColor = AValue then Exit; FEdgeColor := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTPointerCapSettings.SetEdgeThickness(AValue: integer); begin if FEdgeThickness = AValue then Exit; FEdgeThickness := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTPointerCapSettings.SetFillColor(AValue: TColor); begin if FFillColor = AValue then Exit; FFillColor := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTPointerCapSettings.SetOnChange(AValue: TNotifyEvent); begin if FOnChange = AValue then Exit; FOnChange := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTPointerCapSettings.SetRadius(AValue: integer); begin if FRadius = AValue then Exit; FRadius := AValue; if Assigned(FOnChange) then FOnChange(Self); end; constructor TDTPointerCapSettings.Create; begin FEdgeColor := $00CCDCDC; FFillColor := $003F3F3F; FRadius := 10; FEdgeThickness := 1; end; destructor TDTPointerCapSettings.Destroy; begin inherited Destroy; end; { TDTPointerSettings } procedure TDTPointerSettings.SetColor(AValue: TColor); begin if FColor = AValue then Exit; FColor := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTPointerSettings.SetLength(AValue: integer); begin if FLength = AValue then Exit; FLength := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTPointerSettings.SetOnChange(AValue: TNotifyEvent); begin if FOnChange = AValue then Exit; FOnChange := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTPointerSettings.SetThickness(AValue: integer); begin if FThickness = AValue then Exit; FThickness := AValue; if Assigned(FOnChange) then FOnChange(Self); end; constructor TDTPointerSettings.Create; begin FColor := BGRA(199, 199, 173); FLength := 100; FThickness := 3; end; destructor TDTPointerSettings.Destroy; begin inherited Destroy; end; { TDTBaseAnalogDevice } procedure TDTBaseAnalogDevice.SetFaceSettings(AValue: TDTFaceSettings); begin if FFaceSettings = AValue then Exit; FFaceSettings := AValue; DoChange(self); end; procedure TDTBaseAnalogDevice.SetScaleSettings(AValue: TDTScaleSettings); begin if FScaleSettings = AValue then Exit; FScaleSettings := AValue; DoChange(self); end; procedure TDTBaseAnalogDevice.DoChange(Sender: TObject); begin Invalidate; end; constructor TDTBaseAnalogDevice.Create(AOwner: TComponent); begin inherited Create(AOwner); Width := 240; Height := 240; FScaleSettings := TDTScaleSettings.Create; ScaleSettings.OnChange := @DoChange; ScaleSettings.TextRadius := round((Width * 0.6) / 2); FFaceSettings := TDTFaceSettings.Create; FaceSettings.OnChange := @DoChange; FGaugeBitmap := TBGRABitmap.Create; FFaceBitmap := TBGRABitmap.Create; FFrameBitmap := TBGRABitmap.Create; end; destructor TDTBaseAnalogDevice.Destroy; begin FScaleSettings.Free; FFaceSettings.Free; fGaugeBitmap.Free; FFaceBitmap.Free; FFrameBitmap.Free; inherited Destroy; end; procedure TDTBaseAnalogDevice.Paint; begin inherited Paint; FGaugeBitmap.Fill(BGRA(0, 0, 0, 0)); fGaugeBitmap.SetSize(Width, Height); DrawGauge; FGaugeBitmap.BlendImage(0, 0, FFrameBitmap, boLinearBlend); FGaugeBitmap.BlendImage(0, 0, FFaceBitmap, boLinearBlend); FGaugeBitmap.Draw(Canvas, 0, 0, False); end; procedure TDTBaseAnalogDevice.DrawGauge; begin DrawFrame; DrawFace; end; procedure TDTBaseAnalogDevice.DrawFrame; var Origin: TDTOrigin; r: integer; begin Origin := Initializebitmap(FFrameBitmap, Width, Height); r := round(Origin.Radius * 0.95); // Draw Bitmap frame FFrameBitmap.FillEllipseAntialias(Origin.CenterPoint.x, Origin.CenterPoint.y, r, r, FFaceSettings.ColorFrame); // Draw thin antialiased border to smooth against background FFrameBitmap.EllipseAntialias(Origin.CenterPoint.x, Origin.CenterPoint.y, r, r, ColorToBGRA(clBlack, 120), 1); end; procedure TDTBaseAnalogDevice.DrawFace; var Origin: TDTOrigin; r: integer; begin Origin := Initializebitmap(FFaceBitmap, Width, Height); r := round(Origin.Radius * 0.95) - 5; case FFaceSettings.FillStyle of fsGradient: FFaceBitmap.FillEllipseLinearColorAntialias(Origin.CenterPoint.x, Origin.CenterPoint.y, r, r, ColorToBGRA(FFaceSettings.ColorStart), ColorToBGRA(FFaceSettings.ColorEnd)); fsnone: FFaceBitmap.FillEllipseAntialias(Origin.CenterPoint.x, Origin.CenterPoint.y, r, r, FFaceSettings.ColorStart); end; end; { TDTNeedleSettings } procedure TDTNeedleSettings.SetCapColor(AValue: TColor); begin if FCapColor = AValue then Exit; FCapColor := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTNeedleSettings.SetCapEdgeColor(AValue: TColor); begin if FCapEdgeColor = AValue then Exit; FCapEdgeColor := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTNeedleSettings.SetCapRadius(AValue: integer); begin if FCapRadius = AValue then Exit; FCapRadius := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTNeedleSettings.SetNeedleColor(AValue: TColor); begin if FNeedleColor = AValue then Exit; FNeedleColor := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTNeedleSettings.SetNeedleLength(AValue: integer); begin if FNeedleLength = AValue then Exit; FNeedleLength := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTNeedleSettings.SetNeedleStyle(AValue: TDTNeedleStyle); begin if FNeedleStyle = AValue then Exit; FNeedleStyle := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTNeedleSettings.SetOnChange(AValue: TNotifyEvent); begin if FOnChange = AValue then Exit; FOnChange := AValue; if Assigned(FOnChange) then FOnChange(Self); end; constructor TDTNeedleSettings.Create; begin FCapColor := BGRA(63, 63, 63); FCapEdgeColor := BGRA(220, 220, 204); FCapRadius := 10; FNeedleStyle := nsLine; FNeedleColor := BGRA(255, 81, 81); FNeedleLength := 100; end; destructor TDTNeedleSettings.Destroy; begin inherited Destroy; end; { TDTScaleSettings } constructor TDTScaleSettings.Create; begin FTickColor := bgra(223, 196, 125); FTextColor := bgra(140, 208, 211); FTextFont := 'Calibri'; FTextSize := 15; FEnableMainTicks := True; FEnableSubTicks := True; FEnableScaleText := True; FMainTickCount := 10; FSubTickCount := 5; FMaximum := 100; FMinimum := 0; FLengthMainTick := 15; FLengthSubTick := 8; FThicknessMainTick := 3; FThicknessSubTick := 1; FAngle := 300; FEnableRangeIndicator := True; end; destructor TDTScaleSettings.Destroy; begin inherited Destroy; end; procedure TDTScaleSettings.SetTextFont(AValue: string); begin if FTextFont = AValue then Exit; FTextFont := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetEnableScaleText(AValue: boolean); begin if FEnableScaleText = AValue then Exit; FEnableScaleText := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetFAngle(AValue: integer); begin if FAngle=AValue then Exit; FAngle:=AValue; end; procedure TDTScaleSettings.SetMaximum(AValue: integer); begin if FMaximum = AValue then Exit; FMaximum := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetTesting(AValue: boolean); begin if FTesting = AValue then Exit; FTesting := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetTextRadius(AValue: integer); begin if FTextRadius = AValue then Exit; FTextRadius := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetTextSize(AValue: integer); begin if FTextSize = AValue then Exit; FTextSize := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetTickColor(AValue: TColor); begin if FTickColor = AValue then Exit; FTickColor := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetEnableMainTicks(AValue: boolean); begin if FEnableMainTicks = AValue then Exit; FEnableMainTicks := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetEnableRangeIndicator(AValue: boolean); begin if FEnableRangeIndicator = AValue then Exit; FEnableRangeIndicator := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetEnableSubTicks(AValue: boolean); begin if FEnableSubTicks = AValue then Exit; FEnableSubTicks := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetLengthMainTick(AValue: integer); begin if FLengthMainTick = AValue then Exit; FLengthMainTick := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetLengthSubTick(AValue: integer); begin if FLengthSubTick = AValue then Exit; FLengthSubTick := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetMainTickCount(AValue: integer); begin if FMainTickCount = AValue then Exit; FMainTickCount := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetOnChange(AValue: TNotifyEvent); begin if FOnChange = AValue then Exit; FOnChange := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetSubTickCount(AValue: integer); begin if FSubTickCount = AValue then Exit; FSubTickCount := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetTextColor(AValue: TColor); begin if FTextColor = AValue then Exit; FTextColor := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetThicknessMainTick(AValue: integer); begin if FThicknessMainTick = AValue then Exit; FThicknessMainTick := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTScaleSettings.SetThicknessSubTick(AValue: integer); begin if FThicknessSubTick = AValue then Exit; FThicknessSubTick := AValue; if Assigned(FOnChange) then FOnChange(Self); end; { TDTFaceSettings } constructor TDTFaceSettings.Create; begin FColorFrame := BGRA(35, 35, 35); FColorStart := BGRA(63, 63, 63); FColorEnd := BGRA(93, 93, 93); FFillStyle := fsGradient; end; destructor TDTFaceSettings.Destroy; begin inherited Destroy; end; procedure TDTFaceSettings.SetColorEnd(AValue: TColor); begin if FColorEnd = AValue then Exit; FColorEnd := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTFaceSettings.SetColorFrame(AValue: TColor); begin if FColorFrame = AValue then Exit; FColorFrame := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTFaceSettings.SetColorStart(AValue: TColor); begin if FColorStart = AValue then Exit; FColorStart := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTFaceSettings.SetFillStyle(AValue: TDTFillStyle); begin if FFillStyle = AValue then Exit; FFillStyle := AValue; if Assigned(FOnChange) then FOnChange(Self); end; procedure TDTFaceSettings.SetOnChange(AValue: TNotifyEvent); begin if FOnChange = AValue then Exit; FOnChange := AValue; if Assigned(FOnChange) then FOnChange(Self); end; { TDTBackGround } end.