Trying to implement a ring colour picker in firemonkey similar to this: http://dph.am/iDropper/
I thought it could be done using a TCircle with a multi point gradient on the stroke. From my experimentation and research the gradient can only go top to bottom or center out.
Is there a way to get TGradient to follow the path of the stroke?
It's probably a little rough around the edges but here is a Firemonkey ring based colour picker for anyone looking...
Credit must be given to MX Software's mbColor Lib that I used as the base for this - http://mxs.bergsoft.net/.
unit uRingColorPicker;
interface
uses
System.SysUtils, System.Classes, System.Types, FMX.Types, FMX.Controls,
FMX.Objects, FMX.Graphics, System.UITypes, Math, System.UIConsts,
FMX.Colors;
type
TRingColorPicker = class(TPaintBox)
private
{ Private declarations }
bm: TBitmap;
FOnChange: TNotifyEvent;
mdx, mdy: double;
FSat: integer;
FHue: integer;
FValue: integer;
FManual: boolean;
FChange: boolean;
FRadius: integer;
FHueLineColor: TAlphaColor;
FSelectedColor: TAlphaColor;
Quad: TColorQuad;
procedure PaintHSVCircle;
procedure UpdateCoords;
procedure SetHue(Value: integer);
procedure SetSat(Value: integer);
procedure SetValue(Value: integer);
procedure SetHueLineColor(const Value: TAlphaColor);
procedure SetSelectedColor(const Value: TAlphaColor);
procedure SetQuadPosSize;
procedure SelectionChanged(x, y: single);
function GetSelectedColor: TAlphaColor;
protected
{ Protected declarations }
procedure Paint; override;
procedure Resize; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
public
{ Public declarations }
property SelectedColor: TAlphaColor read GetSelectedColor write SetSelectedColor;
function PointInObject(X, Y: Single): Boolean; override;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 0;
property Value: integer read FValue write SetValue default 255;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('LightFactoryFMX', [TRingColorPicker]);
end;
function PointInCirc(p: TPointF; size : integer): boolean;
var
r: integer;
begin
r := size div 2;
Result := (SQR(p.x - r) + SQR(p.y - r) <= SQR(r));
end;
function MathRound(AValue: Extended): Int64; inline;
begin
if AValue >= 0 then
Result := Trunc(AValue + 0.5)
else
Result := Trunc(AValue - 0.5);
end;
function MulDiv(nNumber, nNumerator, nDenominator: Integer): Integer;
begin
if nDenominator = 0 then
Result := -1
else
Result := MathRound(Int64(nNumber) * Int64(nNumerator) / nDenominator);
end;
{ TRingColorPicker }
constructor TRingColorPicker.Create(AOwner: TComponent);
begin
inherited;
bm := TBitmap.Create;
bm.Resize(204, 204);
Width := 204;
Height := 204;
FManual := false;
FChange := true;
FRadius := Round(Width * 0.35);
Quad := TColorQuad.Create(Self);
Quad.Parent := self;
Quad.Visible := true;
Quad.Stored := false;
Quad.Locked := true;
Quad.Sat := 1;
Quad.Lum := 0.5;
end;
destructor TRingColorPicker.Destroy;
begin
bm.Free;
Quad.Free;
inherited;
end;
procedure TRingColorPicker.PaintHSVCircle;
var
i, j, size: integer;
vBitMapData : TBitmapData;
tc: TAlphaColor;
H, x, y, Radius, RadiusSquared, dSquared: Single;
begin
size := Round(Min(Width, Height));
Radius := size / 2;
RadiusSquared := Radius*Radius;
bm.Clear($00ffffff);
if bm.Map(TMapAccess.Write, vBitMapData) then
begin
for j := 0 to size - 1 do
begin
Y := Size - 1 - j - Radius;
for i := 0 to size - 1 do
begin
X := i - Radius;
dSquared := X*X + Y*Y;
if (dSquared>(RadiusSquared - (FRadius*FRadius))) and (dSquared <= RadiusSquared) then
begin
H := 180 * (1 + ArcTan2(X, Y) / PI);
H := H + 90;
if H > 360 then H := H - 360;
tc := HSLtoRGB(H/360, 1, 0.5); //S/255
vBitmapData.SetPixel(i, Size - 1 - j, tc); // set the pixel colour at x:10, y:20
end
end;
end;
bm.Unmap(vBitMapData); // unlock the bitmap
end;
end;
function TRingColorPicker.GetSelectedColor: TAlphaColor;
begin
result := Quad.ColorBox.Color;
end;
procedure TRingColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
inherited;
if (Button = TMouseButton.mbLeft) and PointInCirc(PointF(x, y), Round(Min(Width, Height))) then
begin
SelectionChanged(X, Y);
FManual := true;
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
end;
SetFocus;
end;
procedure TRingColorPicker.SelectionChanged(x, y: Single);
var
Angle, Distance: integer;
xDelta, yDelta, Radius: Double;
begin
if PointInCirc(PointF(x, y), Round(Min(Width, Height))) then
begin
FSelectedColor := TAlphaColorRec.White;
Radius := Min(Width, Height) / 2;
xDelta := x - Radius;
yDelta := y - Radius;
Angle := ROUND(360 + 180*ArcTan2(-yDelta,xDelta)/PI);
if Angle < 0 then Inc(Angle, 360)
else if Angle > 360 then
Dec(Angle, 360);
Fchange := false;
SetHue(Angle);
Distance := ROUND(SQRT(SQR(xDelta) + SQR(yDelta)));
if Distance >= Radius then SetSat(255)
else SetSat(MulDiv(Distance, 255, Round(Radius)));
Fchange := true;
end;
end;
procedure TRingColorPicker.MouseMove(Shift: TShiftState; X, Y: Single);
begin
inherited;
if (ssLeft in Shift) and PointInCirc(PointF(x, y), Round(Min(Width, Height))) then
begin
SelectionChanged(X, Y);
FManual := true;
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TRingColorPicker.UpdateCoords;
var
r, angle: real;
radius: double;
begin
radius := Min(Width, Height) / 2;
r := -MulDiv(Round(radius), FSat, 255);
angle := -FHue*PI/180 - PI;
mdx := (COS(angle)*ROUND(r)) + radius;
mdy := (SIN(angle)*ROUND(r)) + radius;
end;
procedure TRingColorPicker.Paint;
begin
inherited;
PaintHSVCircle;
Canvas.BeginScene;
Canvas.DrawBitmap(bm, bm.BoundsF, bm.BoundsF, 1);
Canvas.EndScene;
SetQuadPosSize;
end;
function TRingColorPicker.PointInObject(X, Y: Single): Boolean;
var
size: integer;
Radius, RadiusSquared, dSquared: Single;
begin
X := X - Position.X;
Y := Y - Position.Y;
size := Round(Min(Width, Height));
Radius := size / 2;
RadiusSquared := Radius*Radius;
Y := Size - 1 - Y - Radius;
X := X - Radius;
dSquared := X*X + Y*Y;
result := (dSquared>(RadiusSquared - (FRadius*FRadius))) and (dSquared <= RadiusSquared);
end;
procedure TRingColorPicker.Resize;
begin
inherited;
bm.Resize(Round(Width), Round(Height));
FRadius := Round(Width * 0.35);
UpdateCoords;
SetQuadPosSize;
end;
procedure TRingColorPicker.SetQuadPosSize;
var
size: integer;
Radius, a, d: Single;
begin
size := Round(Min(Width, Height));
Radius := Round(FRadius * 0.9);
a := SQRT((Radius*Radius) / 2);
d := (size / 2) - a;
if assigned(Quad) then
begin
if Quad.Position.X <> d then
Quad.Position.X := d;
if Quad.Position.Y <> d then
Quad.Position.Y := d;
if Quad.Width <> a * 2 then
Quad.Width := a * 2;
if Quad.Height <> a * 2 then
Quad.Height := a * 2;
end;
end;
procedure TRingColorPicker.SetHue(Value: integer);
begin
if Value > 360 then Value := 360;
if Value < 0 then Value := 0;
if FHue <> Value then
begin
FHue := Value;
FManual := false;
UpdateCoords;
InvalidateRect(RectF(0,0,width,height));
Quad.Hue := Value/360;
Quad.RotationAngle := 360-FHue;
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TRingColorPicker.SetHueLineColor(const Value: TAlphaColor);
begin
if FHueLineColor <> Value then
begin
FHueLineColor := Value;
InvalidateRect(RectF(0,0,width,height));
end;
end;
procedure TRingColorPicker.SetSat(Value: integer);
begin
if Value > 255 then Value := 255;
if Value < 0 then Value := 0;
if FSat <> Value then
begin
FSat := Value;
FManual := false;
UpdateCoords;
InvalidateRect(RectF(0,0,width,height));
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TRingColorPicker.SetSelectedColor(const Value: TAlphaColor);
var
H, S, L: Single;
begin
FSelectedColor := Value;
RGBtoHSL(FSelectedColor, H, S, L);
Fchange := false;
SetHue(Round(H*360));
Quad.Sat := S;
Quad.Lum := L;
Fchange := true;
end;
procedure TRingColorPicker.SetValue(Value: integer);
begin
if Value > 255 then Value := 255;
if Value < 0 then Value := 0;
if FValue <> Value then
begin
FValue := Value;
FManual := false;
InvalidateRect(RectF(0,0,width,height));
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
end;
end;
end.