|
![]() |
|
Registriert seit: 22. Okt 2012 267 Beiträge |
#1
Ich habe das jetzt wie folgt abgeändert:
Delphi-Quellcode:
Das läuft jetzt etwas besser, aber in Summe ist es immer noch nicht wirklich performant.
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. |
![]() |
Registriert seit: 18. Mär 2004 Ort: Luxembourg 3.492 Beiträge Delphi 7 Enterprise |
#2
Eventuell solltest Du lieber die generischen Routinen FillPath und DrawPath verwenden, dann muss Firemonkey Deine TPointF-Arrays nicht mehr umkopieren.
Ibi fas ubi proxima merces
sudo /Developer/Library/uninstall-devtools --mode=all |
![]() |
Ansicht |
![]() |
![]() |
![]() |
ForumregelnEs ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.
BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus. Trackbacks are an
Pingbacks are an
Refbacks are aus
|
|
Nützliche Links |
Heutige Beiträge |
Sitemap |
Suchen |
Code-Library |
Wer ist online |
Alle Foren als gelesen markieren |
Gehe zu... |
LinkBack |
![]() |
![]() |