pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

mbColorLib: Refactor OnChange events. (NOTE: OfficeColorDialog may hang when switching pickers).

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5578 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2017-01-02 00:05:26 +00:00
parent 176aff8ff1
commit 454f0baf7b
41 changed files with 1830 additions and 1837 deletions
Download Patch File Download Diff File Expand all files Collapse all files

178
components/mbColorLib/SLColorPicker.pas
View File

@@ -6,7 +6,7 @@ interface
uses
LCLIntf, LCLType, LMessages,
SysUtils, Classes, Controls, Graphics, Math, Forms,
SysUtils, Classes, Controls, Graphics, Forms,
mbColorPickerControl;
type
@@ -14,38 +14,37 @@ type
private
FHue, FSat, FLum: Double;
FMaxHue, FMaxSat, FMaxLum: integer;
//FChange: boolean;
procedure DrawMarker(x, y: integer);
procedure SelectionChanged(x, y: integer);
procedure UpdateCoords;
function GetHue: Integer;
function GetLum: Integer;
function GetSat: Integer;
procedure SetHue(H: integer);
procedure SetSat(S: integer);
procedure SetLum(L: integer);
procedure SetSat(S: integer);
procedure SetMaxHue(H: Integer);
procedure SetMaxLum(L: Integer);
procedure SetMaxSat(S: Integer);
procedure UpdateCoords;
protected
function GetGradientColor2D(X, Y: Integer): TColor; override;
function GetSelectedColor: TColor; override;
procedure SetSelectedColor(c: TColor); override;
procedure Paint; override;
procedure Resize; override;
procedure CorrectCoords(var x, y: integer);
procedure CreateWnd; override;
function GetGradientColor2D(X, Y: Integer): TColor; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure Resize; override;
procedure Paint; override;
procedure SelectColor(x, y: integer);
procedure SetSelectedColor(c: TColor); override;
public
constructor Create(AOwner: TComponent); override;
function GetColorAtPoint(x, y: integer): TColor; override;
property ColorUnderCursor;
published
property Hue: integer read GetHue write SetHue;
property Saturation: integer read GetSat write SetSat;
property Luminance: integer read GetLum write SetLum;
property Hue: integer read GetHue write SetHue default 0;
property Saturation: integer read GetSat write SetSat default 0;
property Luminance: integer read GetLum write SetLum default 240;
property MaxHue: Integer read FMaxHue write SetMaxHue default 359;
property MaxSaturation: Integer read FMaxSat write SetMaxSat default 240;
property MaxLuminance: Integer read FMaxLum write SetMaxLum default 240;
@@ -57,6 +56,7 @@ type
implementation
uses
Math,
ScanLines, RGBHSLUtils, HTMLColors, mbUtils;
{ TSLColorPicker }
@@ -70,13 +70,18 @@ begin
FGradientWidth := FMaxSat + 1; // x --> Saturation
FGradientHeight := FMaxLum + 1; // y --> Luminance
SetInitialBounds(0, 0, FGradientWidth, FGradientHeight);
FHue := 0.0;
FSat := 0.0;
FLum := 1.0;
FChange := true;
FSelected := clWhite;
RGBToHSL(FSelected, FHue, FSat, FLum);
HintFormat := 'S: %hslS L: %l'#13'Hex: %hex';
MarkerStyle := msCircle;
end;
procedure TSLColorPicker.CorrectCoords(var x, y: integer);
begin
Clamp(x, 0, Width - 1);
Clamp(y, 0, Height - 1);
end;
procedure TSLColorPicker.CreateWnd;
begin
inherited;
@@ -93,17 +98,25 @@ begin
end;
function TSLColorPicker.GetColorAtPoint(x, y: integer): TColor;
var
S, L: Double;
begin
Result := HSLToRGB(FHue, x/(Width - 1), (Height - 1 - y) / (Height - 1));
S := x / (Width - 1);
L := 1.0 - y / (Height - 1);
Result := HSLToRGB(FHue, S, L);
// Result := HSLToRGB(FHue, x/(Width - 1), (Height - 1 - y) / (Height - 1));
if WebSafe then
Result := GetWebSafe(Result);
end;
{ This picker has Saturation along the X and Luminance along the Y axis. }
{ This picker has Saturation along the X and Luminance along the Y axis.
NOTE: The HSL conversion (HSLtoColor) seems to be wrong
but it produces the display seen elsewhere }
function TSLColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
begin
Result := HSLtoColor(FHue, x / FMaxSat, (FMaxLum - y) / FMaxLum);
// Result := HSLtoRGB(FHue, x / FMaxSat, (FMaxLum - y) / FMaxLum);
// Result := HSLtoColor(FHue, x / FMaxSat, (FMaxLum - y) / FMaxLum); // wrong formula
Result := HSLtoRGB(FHue, x / FMaxSat, (FMaxLum - y) / FMaxLum); // correct, but looks wrong...
end;
function TSLColorPicker.GetHue: Integer;
@@ -121,24 +134,22 @@ begin
Result := round(FSat * FMaxSat);
end;
function TSLColorPicker.GetSelectedColor: TColor;
begin
Result := HSLtoRGB(FHue, FSat, FLum);
if WebSafe then
Result := GetWebSafe(Result);
end;
procedure TSLColorPicker.KeyDown(var Key: Word; Shift: TShiftState);
var
eraseKey: Boolean;
delta: Integer;
begin
eraseKey := true;
if ssCtrl in Shift then
delta := 10
else
delta := 1;
delta := IfThen(ssCtrl in Shift, 10, 1);
case Key of
VK_LEFT : SelectColor(mdx - delta, mdy);
VK_RIGHT : SelectColor(mdx + delta, mdy);
VK_UP : SelectColor(mdx, mdy - delta);
VK_DOWN : SelectColor(mdx, mdy + delta);
else eraseKey := false;
end;
{
case Key of
VK_LEFT:
if (mdx - delta >= 0) then
@@ -146,7 +157,7 @@ begin
Dec(mdx, delta);
SelectionChanged(mdx, mdy);
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
DoChange;
end;
VK_RIGHT:
if (mdx + delta < Width) then
@@ -154,7 +165,7 @@ begin
Inc(mdx, delta);
SelectionChanged(mdx, mdy);
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
DoChange;
end;
VK_UP:
if (mdy - delta >= 0) then
@@ -162,7 +173,7 @@ begin
Dec(mdy, delta);
SelectionChanged(mdx, mdy);
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
DoChange;
end;
VK_DOWN:
if (mdy + delta < Height) then
@@ -170,11 +181,12 @@ begin
Inc(mdy, delta);
SelectionChanged(mdx, mdy);
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
DoChange;
end;
else
eraseKey := false;
end;
}
if eraseKey then
Key := 0;
@@ -188,12 +200,8 @@ begin
inherited;
if csDesigning in ComponentState then
Exit;
if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then
begin
mdx := x;
mdy := y;
SelectionChanged(X, Y);
end;
if (Button = mbLeft) then
SelectColor(X, Y);
SetFocus;
end;
@@ -202,27 +210,18 @@ begin
inherited;
if csDesigning in ComponentState then
Exit;
if (ssLeft in Shift) and PtInRect(ClientRect, Point(x, y)) then
begin
mdx := x;
mdy := y;
SelectionChanged(X, Y);
end;
if (ssLeft in Shift) then
SelectColor(X, Y);
end;
procedure TSLColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
if csDesigning in ComponentState then Exit;
if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then
begin
mdx := x;
mdy := y;
SelectionChanged(X, Y);
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
if csDesigning in ComponentState then
Exit;
if (Button = mbLeft)then
SelectColor(X, Y);
end;
procedure TSLColorPicker.Paint;
@@ -238,16 +237,22 @@ begin
UpdateCoords;
end;
procedure TSLColorPicker.SelectionChanged(x, y: integer);
procedure TSLColorPicker.SelectColor(x, y: integer);
var
S, L: Double;
begin
FChange := false;
FSat := x / (Width - 1);
FLum := (Height - y - 1) / (Height - 1);
FManual := false;
UpdateCoords;
CorrectCoords(x, y);
S := x / (Width - 1);
L := 1 - y / (Height - 1);
if (S = FSat) and (L = FLum) then
exit;
FSat := S;
FLum := L;
FSelected := HSLtoRGB(FHue, FSat, FLum);
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
FChange := true;
UpdateCoords;
DoChange;
end;
procedure TSLColorPicker.SetHue(H: integer);
@@ -256,11 +261,11 @@ begin
if GetHue() <> H then
begin
FHue := h / FMaxHue;
FManual := false;
FSelected := HSLtoRGB(FHue, FSat, FLum);
CreateGradient;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
DoChange;
end;
end;
@@ -270,10 +275,10 @@ begin
if GetLum() <> L then
begin
FLum := L / FMaxLum;
FManual := false;
FSelected := HSLtoRGB(FHue, FSat, FLum);
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
DoChange;
end;
end;
@@ -283,7 +288,7 @@ begin
exit;
FMaxHue := H;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
//if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
@@ -294,7 +299,7 @@ begin
FMaxLum := L;
FGradientHeight := FMaxLum + 1;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
//if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
@@ -305,7 +310,7 @@ begin
FMaxSat := S;
FGradientWidth := FMaxSat + 1;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
//if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
@@ -315,26 +320,35 @@ begin
if GetSat() <> S then
begin
FSat := S / FMaxSat;
FManual := false;
FSelected := HSLtoRGB(FHue, FSat, FLum);
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
DoChange;
end;
end;
procedure TSLColorPicker.SetSelectedColor(c: TColor);
var
h, s, l: Double;
H, S, L: Double;
needNewGradient: Boolean;
begin
if WebSafe then c := GetWebSafe(c);
FManual := false;
FChange := false;
ColorToHSL(c, FHue, FSat, FLum);
FManual := false;
if WebSafe then
c := GetWebSafe(c);
if c = GetSelectedColor then
exit;
RGBToHSL(c, H, S, L);
// ColorToHSL(c, H, S, L);
needNewGradient := (FHue <> H);
FHue := H;
FSat := S;
FLum := L;
FSelected := c;
UpdateCoords;
if needNewGradient then
CreateGradient;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
FChange := true;
DoChange;
end;
procedure TSLColorPicker.UpdateCoords;