导航:
论坛 -> 移动应用开发
斑竹:flyers,iamdream
作者:
2017/1/22 16:10:19
标题:
Gauge in Firemonkey
浏览:1641
加入我的收藏
楼主:
外网看到的 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.
----------------------------------------------
相信自己,若自己都不相信,那还有谁可信。
作者:
2017/1/22 22:20:47
1楼:
mark~ 回头好好研究一下
----------------------------------------------
-