楼主:
外网看到的
unit UGauge;
interface
uses System.Types, System.SysUtils, System.Classes, System.UITypes,
FMX.Types, FMX.Graphics, FMX.Controls;
type
TGauge = class(TControl)
protected
FScale: single;
FBitmap: TBitmap;
FBackColor: TAlphaColor;
FDialColor: TAlphaColor;
FForeColor: TAlphaColor;
FFlatMode: Boolean;
FForceUpdate: Boolean;
FGlossAlpha: Byte;
FCurrentValue: single;
FThreshHold: single;
FCaptureThresh: Boolean;
FMaxValue: single;
FMinValue: single;
FToAngle: single;
FFromAngle: single;
FNoOfDivisions: integer;
FNoOfSubDivisions: integer;
FGaugeName: String;
procedure SetFlatMode(const Value: Boolean);
procedure DrawBackground(const Canvas: TCanvas; const RealWidth, Width, Height: single;
const Center: TPointF);
procedure DrawCenterPoint(const Canvas: TCanvas; const Width: single;
const Center: TPointF);
procedure DrawCallibration(const Canvas: TCanvas; const Width: single;
const Center: TPointF);
procedure DrawPointer(const Canvas: TCanvas; const Width: single;
const Center: TPointF; const Thresh: Boolean = false);
procedure DrawGloss(const Canvas: TCanvas; const Width: single;
const Center: TPointF);
procedure SetCurrentValue(const Value: single);
procedure Paint; override;
procedure Resize; override;
procedure RenderBackground(const Width, Height: single);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ResetThreshold;
property BackColor: TAlphaColor read FBackColor write FBackColor;
property ForeColor: TAlphaColor read FForeColor write FForeColor;
property DialColor: TAlphaColor read FDialColor write FDialColor;
property GlossAlpha: Byte read FGlossAlpha write FGlossAlpha;
property CurrentValue: single read FCurrentValue write SetCurrentValue;
property MaxValue: single read FMaxValue write FMaxValue;
property MinValue: single read FMinValue write FMinValue;
property ToAngle: single read FToAngle write FToAngle;
property FromAngle: single read FFromAngle write FFromAngle;
property noOfDivisions: integer read FNoOfDivisions write FNoOfDivisions;
property noOfSubDivisions: integer read FNoOfSubDivisions
write FNoOfSubDivisions;
property GaugeName: String read FGaugeName write FGaugeName;
property CaptureThresh: Boolean read FCaptureThresh write FCaptureThresh;
property FlatMode: Boolean read FFlatMode write SetFlatMode;
published
property Align;
property Anchors;
property ClipChildren default false;
property ClipParent default false;
property DesignVisible default True;
property Enabled default True;
property Locked default false;
property Height;
property HitTest default True;
property Padding;
property Opacity;
property Margins;
property PopupMenu;
property position;
property RotationAngle;
property RotationCenter;
property Scale;
property Visible default True;
property Width;
{ Mouse events }
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseEnter;
property OnMouseLeave;
property OnPainting;
property OnPaint;
property OnResize;
end;
implementation
uses FMX.Platform;
{ TGauge }
constructor TGauge.Create(AOwner: TComponent);
var
ScreenSvc: IFMXScreenService;
begin
inherited;
FBitmap := TBitmap.Create;
{$IFDEF ANDROID}
FFlatMode := True;
{$ENDIF}
FBackColor := $FF000080;
FDialColor := $FFE6E6FA;
FForeColor := $FF000000;
MaxValue := 100;
MinValue := 0;
CurrentValue := 0;
FromAngle := 135;
ToAngle := 405;
noOfDivisions := 10;
noOfSubDivisions := 3;
FGaugeName := '';
GlossAlpha := 200;
if TPlatformServices.Current.SupportsPlatformService(IFMXScreenService,
IInterface(ScreenSvc)) then
FScale := ScreenSvc.GetScreenScale
else
FScale := 1;
FForceUpdate := True;
end;
destructor TGauge.Destroy;
begin
FreeAndNil(FBitmap);
inherited;
end;
procedure TGauge.DrawCallibration(const Canvas: TCanvas; const Width: single;
const Center: TPointF);
var
currentAngle: single;
gap: integer;
X, Y, x1, y1, tx, ty, radius: single;
rulerValue, incr, totalAngle: single;
i, j: integer;
begin
gap := trunc(Width * 0.01);
radius := Width / 2 - gap * 5;
currentAngle := FromAngle * PI / 180;
totalAngle := ToAngle - FromAngle;
incr := totalAngle / (noOfDivisions * noOfSubDivisions) * PI / 180;
rulerValue := MinValue;
Canvas.stroke.Kind := TBrushKind.bkSolid;
Canvas.stroke.Color := $FF000000;
Canvas.Fill.Color := $FF000000 or (FForeColor and $FFFFFF);
Canvas.Font.Size := Width / 24;
for i := 0 to noOfDivisions do
begin
// Draw Thick Line
X := (Center.X + radius * Cos(currentAngle));
Y := (Center.Y + radius * Sin(currentAngle));
x1 := (Center.X + (radius - Width / 20) * Cos(currentAngle));
y1 := (Center.Y + (radius - Width / 20) * Sin(currentAngle));
Canvas.DrawLine(PointF(X, Y), PointF(x1, y1), 1);
// Draw Strings
tx := (Center.X + (radius - Width / 10) * Cos(currentAngle));
ty := (Center.Y - Width / 25 + (radius - Width / 10) * Sin(currentAngle));
Canvas.FillText(RectF(tx, ty, tx + 1024, ty + 1024),
format('%0.0f', [rulerValue]), false, 1, [], TTextAlign.taLeading,
TTextAlign.taLeading);
rulerValue := rulerValue + round((MaxValue - MinValue) / noOfDivisions);
if i < noOfDivisions then
for j := 0 to noOfSubDivisions - 1 do
begin
// Draw thin lines
currentAngle := currentAngle + incr;
X := (Center.X + radius * Cos(currentAngle));
Y := (Center.Y + radius * Sin(currentAngle));
x1 := (Center.X + (radius - Width / 50) * Cos(currentAngle));
y1 := (Center.Y + (radius - Width / 50) * Sin(currentAngle));
Canvas.DrawLine(PointF(X, Y), PointF(x1, y1), 1);
end;
end;
end;
procedure TGauge.DrawPointer(const Canvas: TCanvas; const Width: single;
const Center: TPointF; const Thresh: Boolean = false);
var
radius: single;
val: single;
angle: single;
pts: TPolygon;
Value, w, len: single;
begin
radius := Width / 2 - (Width * 0.12);
val := MaxValue - MinValue;
if Thresh then
begin
w := 6;
Value := FThreshHold;
len := 0.09;
end
else
begin
w := 20;
Value := CurrentValue;
len := 0.09;
end;
val := (100 * (Value - MinValue)) / val;
val := ((ToAngle - FromAngle) * val) / 100;
val := val + FromAngle;
angle := val * PI / 180;
setlength(pts, 5);
pts[0].X := (Center.X + radius * Cos(angle));
pts[0].Y := (Center.Y + radius * Sin(angle));
pts[4].X := (Center.X + radius * Cos(angle - 0.02));
pts[4].Y := (Center.Y + radius * Sin(angle - 0.02));
angle := (val + w) * PI / 180;
pts[1].X := (Center.X + (Width * len) * Cos(angle));
pts[1].Y := (Center.Y + (Width * len) * Sin(angle));
pts[2].X := Center.X;
pts[2].Y := Center.Y;
angle := (val - w) * PI / 180;
pts[3].X := (Center.X + (Width * len) * Cos(angle));
pts[3].Y := (Center.Y + (Width * len) * Sin(angle));
if Thresh then
Canvas.Fill.Color := $FFFF0000
else
Canvas.Fill.Color := $FF000000;
Canvas.FillPolygon(pts, 1);
if Thresh then
exit;
setlength(pts, 3);
angle := val * PI / 180;
pts[0].X := (Center.X + radius * Cos(angle));
pts[0].Y := (Center.Y + radius * Sin(angle));
angle := (val + w) * PI / 180;
pts[1].X := (Center.X + (Width * len) * Cos(angle));
pts[1].Y := (Center.Y + (Width * len) * Sin(angle));
pts[2].X := Center.X;
pts[2].Y := Center.Y;
if FFlatMode then
begin
Canvas.Fill.Color := $FF808080;
Canvas.FillPolygon(pts, 1);
end
else
begin
Canvas.Fill.Kind := TBrushKind.bkGradient;
try
Canvas.Fill.Gradient.Color := $FF808080;
Canvas.Fill.Gradient.Color1 := $0F000000;
Canvas.FillPolygon(pts, 1);
finally
Canvas.Fill.Kind := TBrushKind.bkSolid;
end;
end;
end;
procedure TGauge.DrawGloss(const Canvas: TCanvas; const Width: single;
const Center: TPointF);
var
R: TRectF;
X, Y: single;
begin
R := RectF(Center.X - Width / 2, Center.Y - Width / 2, Center.X + Width / 2,
Center.Y + Width / 2);
if not FFlatMode then
Canvas.Fill.Kind := TBrushKind.bkGradient;
try
Canvas.Fill.Color := (GlossAlpha div 4 and $FF) shl 24 or $FFFFFF;
if not FFlatMode then
begin
Canvas.Fill.Gradient.Color := (GlossAlpha and $FF) shl 24 or $FFFFFF;
Canvas.Fill.Gradient.Color1 := $00FFFFFF;
end;
X := R.Left + (Width * 0.10);
Y := R.Top + (Width * 0.07);
Canvas.FillEllipse(RectF(X, Y, X + (Width * 0.80), Y + (Width * 0.7)), 1);
Canvas.Fill.Color := ((GlossAlpha div 3) and $FF) shl 24 or
(FBackColor and $FFFFFF);
if not FFlatMode then
begin
Canvas.Fill.Gradient.Color := $00FFFFFF;
Canvas.Fill.Gradient.Color1 := Canvas.Fill.Color;
end;
X := R.Left + Width * 0.25;
Y := R.Top + Width * 0.77;
Canvas.FillEllipse(RectF(X, Y, X + Width * 0.5, Y + Width * 0.2), 1);
finally
Canvas.Fill.Kind := TBrushKind.bkSolid;
end;
end;
procedure TGauge.DrawCenterPoint(const Canvas: TCanvas; const Width: single;
const Center: TPointF);
var
R: TRectF;
shift: single;
begin
shift := Width / 5;
R := RectF(Center.X - (shift / 2), Center.Y - (shift / 2),
Center.X + (shift / 2), Center.Y + (shift / 2));
if not FFlatMode then
Canvas.Fill.Kind := TBrushKind.bkGradient;
try
Canvas.Fill.Color := 100 shl 24 or (FDialColor and $FFFFFF);
if FFlatMode then
begin
Canvas.Fill.Gradient.Color := $FF000000;
Canvas.Fill.Gradient.Color1 := Canvas.Fill.Color;
end;
Canvas.FillEllipse(R, 1);
shift := Width / 7;
R := RectF(Center.X - (shift / 2), Center.Y - (shift / 2),
Center.X + (shift / 2), Center.Y + (shift / 2));
if FFlatMode then
Canvas.Fill.Color := $80808080
else
begin
Canvas.Fill.Gradient.Color := $FF808080;
Canvas.Fill.Gradient.Color1 := $FF000000;
end;
Canvas.FillEllipse(R, 1);
finally
Canvas.Fill.Kind := TBrushKind.bkSolid;
end;
end;
procedure TGauge.DrawBackground(const Canvas: TCanvas;
const RealWidth, Width, Height: single; const Center: TPointF);
var
R: TRectF;
Y: single;
begin
R := RectF(Center.X - (Width / 2), Center.Y - (Width / 2),
Center.X + (Width / 2), Center.Y + (Width / 2));
Canvas.Fill.Color := 120 shl 24 or (FDialColor and $FFFFFF);
Canvas.FillEllipse(R, 1);
// Draw Rim
Canvas.stroke.Kind := TBrushKind.bkSolid;
Canvas.stroke.Color := $64808080;
Canvas.DrawEllipse(R, 1);
Canvas.stroke.Color := $FF808080;
Canvas.DrawEllipse(R, 1);
Canvas.Fill.Color := $FF000000 or (FForeColor and $FFFFFF);
Canvas.Font.Size := Width / 18;
Canvas.FillText(RectF(0, Center.Y + (Width / 4.5), RealWidth, Height), FGaugeName,
false, 1, [], TTextAlign.taCenter, TTextAlign.taLeading);
DrawCallibration(Canvas, Width, Center);
end;
procedure TGauge.Resize;
begin
inherited;
FForceUpdate := True;
end;
procedure TGauge.RenderBackground(const Width, Height: single);
var
Center: TPointF;
begin
if not FForceUpdate then
exit;
FForceUpdate := false;
FBitmap.Resize(trunc(Width * FScale), trunc(Height * FScale));
Center := PointF(FBitmap.Width / 2, FBitmap.Height / 2);
FBitmap.Clear(0);
FBitmap.Canvas.BeginScene(nil);
DrawBackground(FBitmap.Canvas, FBitmap.Width, 0.98*FBitmap.Width, FBitmap.Height, Center);
FBitmap.Canvas.EndScene;
end;
procedure TGauge.SetFlatMode(const Value: Boolean);
begin
if FFlatMode <> Value then
begin
FFlatMode := Value;
FForceUpdate := True;
repaint;
end
end;
procedure TGauge.Paint;
var
Center: TPointF;
w, Y: single;
begin
RenderBackground(Width, Height);
if Canvas.BeginScene(nil) then
try
Center := PointF(Width / 2, Height / 2);
Canvas.DrawBitmap(FBitmap, RectF(0, 0, FBitmap.Width, FBitmap.Height),
RectF(0, 0, Width, Height), 1);
Y := Center.Y + Height / 3.5;
w := 0.98*Width;
Canvas.Font.Size := Width / 10;
Canvas.Fill.Color := $FF000000 or (FForeColor and $FFFFFF);
Canvas.FillText(RectF(0, Y, Width, Height),
format('%0.1f', [CurrentValue]), false, 1, [], TTextAlign.taCenter,
TTextAlign.taLeading);
if FThreshHold >= FMinValue then
DrawPointer(Canvas, w, Center, True);
DrawPointer(Canvas, w, Center);
DrawCenterPoint(Canvas, w, Center);
DrawGloss(Canvas, w, Center);
finally
Canvas.EndScene;
end;
end;
procedure TGauge.SetCurrentValue(const Value: single);
begin
if abs(FCurrentValue - Value) >= 0.1 then
begin
FCurrentValue := Value;
if (CaptureThresh) and (FThreshHold < Value) then
FThreshHold := Value;
repaint;
end;
end;
procedure TGauge.ResetThreshold;
begin
CaptureThresh := false;
FThreshHold := FMinValue - 1;
repaint;
end;
end.
----------------------------------------------
相信自己,若自己都不相信,那还有谁可信。