|
|
@@ -7,6 +7,8 @@
|
|
|
Author: Boban Spasic
|
|
|
Credits to: hedgehog, circular and lainz from Lazarus forum
|
|
|
Based on TFluentProgressRing from hedgehog
|
|
|
+
|
|
|
+ 2024-11-20 Massimo Magnano Added Draw of Caption and TextLayouts
|
|
|
}
|
|
|
|
|
|
unit BCLeaRingSlider;
|
|
|
@@ -80,10 +82,19 @@ type
|
|
|
FLightPositionX: integer;
|
|
|
FLightPositionY: integer;
|
|
|
FLightPositionZ: integer;
|
|
|
+ rCaptionLayout: TTextLayout;
|
|
|
+ rDrawCaption: Boolean;
|
|
|
+ rDrawCaptionPhong: Boolean;
|
|
|
+ rTextLayout: TTextLayout;
|
|
|
+
|
|
|
+ procedure SetCaptionLayout(AValue: TTextLayout);
|
|
|
+ procedure SetDrawCaption(AValue: Boolean);
|
|
|
+ procedure SetDrawCaptionPhong(AValue: Boolean);
|
|
|
procedure SetLineBkgColor(AValue: TColor);
|
|
|
procedure SetLineColor(AValue: TColor);
|
|
|
procedure SetMaxValue(AValue: integer);
|
|
|
procedure SetMinValue(AValue: integer);
|
|
|
+ procedure SetTextLayout(AValue: TTextLayout);
|
|
|
procedure SetValue(AValue: integer);
|
|
|
procedure SetLineWidth(AValue: integer);
|
|
|
procedure UpdateVerticalPos(X, Y: integer);
|
|
|
@@ -112,6 +123,7 @@ type
|
|
|
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
|
|
|
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
|
|
|
procedure MouseMove(Shift: TShiftState; X, Y: integer); override;
|
|
|
+
|
|
|
public
|
|
|
constructor Create(AOwner: TComponent); override;
|
|
|
destructor Destroy; override;
|
|
|
@@ -120,6 +132,7 @@ type
|
|
|
procedure SaveThemeToFile(AFileName: string);
|
|
|
procedure LoadThemeFromFile(AFileName: string);
|
|
|
procedure ApplyDefaultTheme;
|
|
|
+
|
|
|
published
|
|
|
property Align;
|
|
|
property Caption;
|
|
|
@@ -175,6 +188,10 @@ type
|
|
|
property PointerSize: integer read FPointerSize write SetPointerSize default 2;
|
|
|
property Altitude: integer read FAltitude write SetAltitude default 2;
|
|
|
property Theme: TBCLeaTheme read FTheme write SetTheme;
|
|
|
+ property TextLayout: TTextLayout read rTextLayout write SetTextLayout default tlCenter;
|
|
|
+ property DrawCaption: Boolean read rDrawCaption write SetDrawCaption default False;
|
|
|
+ property DrawCaptionPhong: Boolean read rDrawCaptionPhong write SetDrawCaptionPhong default False;
|
|
|
+ property CaptionLayout: TTextLayout read rCaptionLayout write SetCaptionLayout default tlBottom;
|
|
|
end;
|
|
|
|
|
|
procedure Register;
|
|
|
@@ -242,6 +259,27 @@ begin
|
|
|
Invalidate;
|
|
|
end;
|
|
|
|
|
|
+procedure TBCLeaRingSlider.SetCaptionLayout(AValue: TTextLayout);
|
|
|
+begin
|
|
|
+ if rCaptionLayout=AValue then Exit;
|
|
|
+ rCaptionLayout:=AValue;
|
|
|
+ Invalidate;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TBCLeaRingSlider.SetDrawCaption(AValue: Boolean);
|
|
|
+begin
|
|
|
+ if rDrawCaption=AValue then Exit;
|
|
|
+ rDrawCaption:=AValue;
|
|
|
+ Invalidate;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure TBCLeaRingSlider.SetDrawCaptionPhong(AValue: Boolean);
|
|
|
+begin
|
|
|
+ if rDrawCaptionPhong=AValue then Exit;
|
|
|
+ rDrawCaptionPhong:=AValue;
|
|
|
+ Invalidate;
|
|
|
+end;
|
|
|
+
|
|
|
procedure TBCLeaRingSlider.SetLineColor(AValue: TColor);
|
|
|
begin
|
|
|
if FLineColor = AValue then
|
|
|
@@ -263,6 +301,13 @@ begin
|
|
|
Invalidate;
|
|
|
end;
|
|
|
|
|
|
+procedure TBCLeaRingSlider.SetTextLayout(AValue: TTextLayout);
|
|
|
+begin
|
|
|
+ if rTextLayout=AValue then Exit;
|
|
|
+ rTextLayout:=AValue;
|
|
|
+ Invalidate;
|
|
|
+end;
|
|
|
+
|
|
|
procedure TBCLeaRingSlider.SetValue(AValue: integer);
|
|
|
begin
|
|
|
if FValue = AValue then
|
|
|
@@ -314,6 +359,7 @@ var
|
|
|
Blur: TBGRABitmap;
|
|
|
Mask, Mask2: TBGRABitmap;
|
|
|
Phong: TPhongShading;
|
|
|
+ TextSize: TSize;
|
|
|
|
|
|
procedure DoDrawArc(a, b: single; c: TColor);
|
|
|
begin
|
|
|
@@ -392,9 +438,38 @@ begin
|
|
|
begin
|
|
|
TextStr := IntToStr(FValue);
|
|
|
TextBmp := TextShadow(EffectiveSize, EffectiveSize, TextStr, Font.Height,
|
|
|
- Font.Color, FontShadowColor, FontShadowOFfsetX,
|
|
|
+ Font.Color, FontShadowColor, FontShadowOffsetX,
|
|
|
FontShadowOffsetY, FontShadowRadius, Font.Style, Font.Name) as TBGRABitmap;
|
|
|
- FBitmap.PutImage(0, 0, TextBmp, dmDrawWithTransparency);
|
|
|
+ TextSize:= TextBmp.TextSize(TextStr);
|
|
|
+ TextSize.cy:= TextSize.cy+FontShadowOffsetY; //+2*FontShadowRadius ?
|
|
|
+
|
|
|
+ Case rTextLayout of
|
|
|
+ tlTop: FBitmap.PutImage(0, -(HalfUp(((EffectiveSize-TextSize.cy) / 2))-Trunc(EffectiveLineWidth)),
|
|
|
+ TextBmp, dmDrawWithTransparency);
|
|
|
+ tlCenter: FBitmap.PutImage(0, 0, TextBmp, dmDrawWithTransparency);
|
|
|
+ tlBottom: FBitmap.PutImage(0, +(HalfUp(((EffectiveSize-TextSize.cy) / 2))-Trunc(EffectiveLineWidth)),
|
|
|
+ TextBmp, dmDrawWithTransparency);
|
|
|
+ end;
|
|
|
+
|
|
|
+ TextBmp.Free;
|
|
|
+ end;
|
|
|
+
|
|
|
+ if rDrawCaption and rDrawCaptionPhong then
|
|
|
+ begin
|
|
|
+ TextBmp := TextShadow(EffectiveSize, EffectiveSize, Caption, Font.Height,
|
|
|
+ Font.Color, FontShadowColor, FontShadowOffsetX,
|
|
|
+ FontShadowOffsetY, FontShadowRadius, Font.Style, Font.Name) as TBGRABitmap;
|
|
|
+ TextSize:= TextBmp.TextSize(Caption);
|
|
|
+ TextSize.cy:= TextSize.cy+FontShadowOffsetY; //+2*FontShadowRadius ?
|
|
|
+
|
|
|
+ Case rCaptionLayout of
|
|
|
+ tlTop: FBitmap.PutImage(0, -(HalfUp(((EffectiveSize-TextSize.cy) / 2))-Trunc(EffectiveLineWidth)),
|
|
|
+ TextBmp, dmDrawWithTransparency);
|
|
|
+ tlCenter: FBitmap.PutImage(0, 0, TextBmp, dmDrawWithTransparency);
|
|
|
+ tlBottom: FBitmap.PutImage(0, +(HalfUp(((EffectiveSize-TextSize.cy) / 2))-Trunc(EffectiveLineWidth)),
|
|
|
+ TextBmp, dmDrawWithTransparency);
|
|
|
+ end;
|
|
|
+
|
|
|
TextBmp.Free;
|
|
|
end;
|
|
|
|
|
|
@@ -444,9 +519,38 @@ begin
|
|
|
begin
|
|
|
TextStr := IntToStr(FValue);
|
|
|
TextBmp := TextShadow(EffectiveSize, EffectiveSize, TextStr, Font.Height,
|
|
|
- Font.Color, FontShadowColor, FontShadowOFfsetX,
|
|
|
+ Font.Color, FontShadowColor, FontShadowOffsetX,
|
|
|
FontShadowOffsetY, FontShadowRadius, Font.Style, Font.Name) as TBGRABitmap;
|
|
|
- FBitmap.PutImage(0, 0, TextBmp, dmDrawWithTransparency);
|
|
|
+ TextSize:= TextBmp.TextSize(TextStr);
|
|
|
+ TextSize.cy:= TextSize.cy+FontShadowOffsetY; //+2*FontShadowRadius ?
|
|
|
+
|
|
|
+ Case rTextLayout of
|
|
|
+ tlTop: FBitmap.PutImage(0, -(HalfUp(((EffectiveSize-TextSize.cy) / 2))-Trunc(EffectiveLineWidth)),
|
|
|
+ TextBmp, dmDrawWithTransparency);
|
|
|
+ tlCenter: FBitmap.PutImage(0, 0, TextBmp, dmDrawWithTransparency);
|
|
|
+ tlBottom: FBitmap.PutImage(0, +(HalfUp(((EffectiveSize-TextSize.cy) / 2))-Trunc(EffectiveLineWidth)),
|
|
|
+ TextBmp, dmDrawWithTransparency);
|
|
|
+ end;
|
|
|
+
|
|
|
+ TextBmp.Free;
|
|
|
+ end;
|
|
|
+
|
|
|
+ if rDrawCaption and not(rDrawCaptionPhong) then
|
|
|
+ begin
|
|
|
+ TextBmp := TextShadow(EffectiveSize, EffectiveSize, Caption, Font.Height,
|
|
|
+ Font.Color, FontShadowColor, FontShadowOffsetX,
|
|
|
+ FontShadowOffsetY, FontShadowRadius, Font.Style, Font.Name) as TBGRABitmap;
|
|
|
+ TextSize:= TextBmp.TextSize(Caption);
|
|
|
+ TextSize.cy:= TextSize.cy+FontShadowOffsetY; //+2*FontShadowRadius ?
|
|
|
+
|
|
|
+ Case rCaptionLayout of
|
|
|
+ tlTop: FBitmap.PutImage(0, -(HalfUp(((EffectiveSize-TextSize.cy) / 2))-Trunc(EffectiveLineWidth)),
|
|
|
+ TextBmp, dmDrawWithTransparency);
|
|
|
+ tlCenter: FBitmap.PutImage(0, 0, TextBmp, dmDrawWithTransparency);
|
|
|
+ tlBottom: FBitmap.PutImage(0, +(HalfUp(((EffectiveSize-TextSize.cy) / 2))-Trunc(EffectiveLineWidth)),
|
|
|
+ TextBmp, dmDrawWithTransparency);
|
|
|
+ end;
|
|
|
+
|
|
|
TextBmp.Free;
|
|
|
end;
|
|
|
|
|
|
@@ -472,7 +576,10 @@ begin
|
|
|
Font.Color := clBlack;
|
|
|
Font.Height := 20;
|
|
|
FDrawText := True;
|
|
|
+ rTextLayout:= tlCenter;
|
|
|
FDrawPointer := False;
|
|
|
+ rDrawCaption:= False;
|
|
|
+ rCaptionLayout:= tlBottom;
|
|
|
ApplyDefaultTheme;
|
|
|
FBitmap := TBGRABitmap.Create(Width, Height, FBkgColor);
|
|
|
end;
|