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

mbControls: Refactoring of the 2D gradients and code used in several units over again.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5461 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2016-12-11 15:10:49 +00:00
parent 8daab50f04
commit 8b1a85037f
21 changed files with 2431 additions and 2911 deletions
Download Patch File Download Diff File Expand all files Collapse all files

388
components/mbColorLib/BAxisColorPicker.pas
View File

@ -7,57 +7,45 @@ unit BAxisColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms, SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines; HTMLColors, mbColorPickerControl;
type type
TBAxisColorPicker = class(TmbColorPickerControl) TBAxisColorPicker = class(TmbColorPickerControl)
private private
FSelected: TColor; FR, FG, FB: integer;
FBmp: TBitmap; dx, dy, mxx, myy: integer;
FOnChange: TNotifyEvent; procedure SetRValue(r: integer);
FR, FG, FB: integer; procedure SetGValue(g: integer);
FManual: boolean; procedure SetBValue(b: integer);
dx, dy, mxx, myy: integer; protected
function GetGradientColor2D(x, y: Integer): TColor; override;
procedure SetRValue(r: integer); procedure SetSelectedColor(c: TColor); override;
procedure SetGValue(g: integer); procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
procedure SetBValue(b: integer); message CN_KEYDOWN;
protected procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
function GetSelectedColor: TColor; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure WebSafeChanged; override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure SetSelectedColor(c: TColor); override; procedure DrawMarker(x, y: integer);
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); procedure Paint; override;
message CN_KEYDOWN; procedure Resize; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure CreateWnd; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure CorrectCoords(var x, y: integer);
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; public
procedure DrawMarker(x, y: integer); constructor Create(AOwner: TComponent); override;
procedure Paint; override; published
procedure CreateRGBGradient; property SelectedColor default clBlue;
procedure Resize; override; property RValue: integer read FR write SetRValue default 0;
procedure CreateWnd; override; property GValue: integer read FG write SetGValue default 0;
procedure CorrectCoords(var x, y: integer); property BValue: integer read FB write SetBValue default 255;
public property MarkerStyle default msCircle;
constructor Create(AOwner: TComponent); override; property OnChange;
destructor Destroy; override; end;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property SelectedColor default clBlue;
property RValue: integer read FR write SetRValue default 0;
property GValue: integer read FG write SetGValue default 0;
property BValue: integer read FB write SetBValue default 255;
property MarkerStyle default msCircle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
procedure Register; procedure Register;
@ -67,218 +55,189 @@ implementation
{$R BAxisColorPicker.dcr} {$R BAxisColorPicker.dcr}
{$ENDIF} {$ENDIF}
uses
mbUtils;
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TBAxisColorPicker]); RegisterComponents('mbColor Lib', [TBAxisColorPicker]);
end; end;
{TBAxisColorPicker} {TBAxisColorPicker}
constructor TBAxisColorPicker.Create(AOwner: TComponent); constructor TBAxisColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FBmp := TBitmap.Create; FGradientWidth := 256;
FBmp.PixelFormat := pf32bit; FGradientHeight := 256;
FBmp.SetSize(256, 256); {$IFDEF DELPHI}
Width := 256; Width := 256;
Height := 256; Height := 256;
HintFormat := 'R: %r G: %g'#13'Hex: %hex'; {$ELSE}
FG := 0; SetInitialBounds(0, 0, 255, 255);
FB := 255; {$ENDIF}
FR := 0; HintFormat := 'R: %r G: %g'#13'Hex: %hex';
FSelected := clBlue; FG := 0;
FManual := false; FB := 255;
dx := 0; FR := 0;
dy := 0; FSelected := clBlue;
mxx := 0; FManual := false;
myy := 0; dx := 0;
MarkerStyle := msCircle; dy := 0;
end; mxx := 0;
myy := 0;
destructor TBAxisColorPicker.Destroy; MarkerStyle := msCircle;
begin
FBmp.Free;
inherited Destroy;
end; end;
procedure TBAxisColorPicker.CreateWnd; procedure TBAxisColorPicker.CreateWnd;
begin begin
inherited; inherited;
CreateRGBGradient; CreateGradient;
end; end;
procedure TBAxisColorPicker.CreateRGBGradient; { x is RED, y is GREEN }
var function TBAxisColorPicker.GetGradientColor2D(x, y: Integer): TColor;
r, g: integer;
row: pRGBQuadArray;
begin begin
if FBmp = nil then Result := RGB(x, FGradientBmp.Height - 1 - y, FB);
begin
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.Width := 256;
FBmp.Height := 256;
end;
for g := 0 to 255 do
begin
row := FBmp.ScanLine[255 - g];
for r := 0 to 255 do
if not WebSafe then
row[r] := RGBtoRGBQuad(r, g, FB)
else
row[r] := RGBtoRGBQuad(GetWebSafe(RGB(r, g, FB)));
end;
end; end;
procedure TBAxisColorPicker.CorrectCoords(var x, y: integer); procedure TBAxisColorPicker.CorrectCoords(var x, y: integer);
begin begin
if x < 0 then x := 0; Clamp(x, 0, Width - 1);
if y < 0 then y := 0; Clamp(y, 0, Height - 1);
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
end; end;
procedure TBAxisColorPicker.DrawMarker(x, y: integer); procedure TBAxisColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
begin begin
CorrectCoords(x, y); CorrectCoords(x, y);
FR := GetRValue(FSelected); FR := GetRValue(FSelected);
FG := GetGValue(FSelected); FG := GetGValue(FSelected);
FB := GetBValue(FSelected); FB := GetBValue(FSelected);
if Assigned(FOnChange) then if Assigned(FOnChange) then
FOnChange(Self); FOnChange(Self);
dx := x; dx := x;
dy := y; dy := y;
if Focused or (csDesigning in ComponentState) then if Focused or (csDesigning in ComponentState) then
c := clBlack c := clBlack
else else
c := clWhite; c := clWhite;
case MarkerStyle of InternalDrawMarker(x, y, c);
msCircle: DrawSelCirc(x, y, Canvas);
msSquare: DrawSelSquare(x, y, Canvas);
msCross: DrawSelCross(x, y, Canvas, c);
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
end;
end;
function TBAxisColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
end; end;
procedure TBAxisColorPicker.SetSelectedColor(c: TColor); procedure TBAxisColorPicker.SetSelectedColor(c: TColor);
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
FR := GetRValue(c); FR := GetRValue(c);
FG := GetGValue(c); FG := GetGValue(c);
FB := GetBValue(c); FB := GetBValue(c);
FSelected := c; FSelected := c;
FManual := false; FManual := false;
mxx := Round(FR*(Width/255)); mxx := Round(FR*(Width/255));
myy := Round((255-FG)*(Height/255)); myy := Round((255-FG)*(Height/255));
CreateRGBGradient; CreateGradient;
Invalidate; Invalidate;
end; end;
procedure TBAxisColorPicker.Paint; procedure TBAxisColorPicker.Paint;
begin begin
Canvas.StretchDraw(ClientRect, FBmp); Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy); CorrectCoords(mxx, myy);
DrawMarker(mxx, myy); DrawMarker(mxx, myy);
end; end;
procedure TBAxisColorPicker.Resize; procedure TBAxisColorPicker.Resize;
begin begin
FManual := false; FManual := false;
mxx := Round(FR*(Width/255)); mxx := round(FR * (Width / 255));
myy := Round((255-FG)*(Height/255)); myy := round((255 - FG) * (Height / 255));
inherited; inherited;
end; end;
procedure TBAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TBAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var var
R: TRect; R: TRect;
begin begin
inherited; inherited;
mxx := x; mxx := x;
myy := y; myy := y;
if Button = mbLeft then if Button = mbLeft then
begin begin
R := ClientRect; R := ClientRect;
R.TopLeft := ClientToScreen(R.TopLeft); R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight); R.BottomRight := ClientToScreen(R.BottomRight);
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(@R); ClipCursor(@R);
{$ENDIF} {$ENDIF}
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
SetFocus; SetFocus;
end; end;
procedure TBAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TBAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(nil); ClipCursor(nil);
{$ENDIF} {$ENDIF}
mxx := x; mxx := x;
myy := y; myy := y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
procedure TBAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TBAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
if ssLeft in Shift then if ssLeft in Shift then
begin begin
mxx := x; mxx := x;
myy := y; myy := y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
end; end;
procedure TBAxisColorPicker.CNKeyDown( procedure TBAxisColorPicker.CNKeyDown(
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} );
var var
Shift: TShiftState; Shift: TShiftState;
FInherited: boolean; FInherited: boolean;
begin begin
FInherited := false; FInherited := false;
Shift := KeyDataToShiftState(Message.KeyData); Shift := KeyDataToShiftState(Message.KeyData);
if not (ssCtrl in Shift) then if not (ssCtrl in Shift) then
case Message.CharCode of case Message.CharCode of
VK_LEFT: VK_LEFT:
begin begin
mxx := dx - 1; mxx := dx - 1;
myy := dy; myy := dy;
FSelected := GetColorAtPoint(mxx, myy); FSelected := GetColorAtPoint(mxx, myy);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
VK_RIGHT: VK_RIGHT:
begin begin
mxx := dx + 1; mxx := dx + 1;
myy := dy; myy := dy;
FSelected := GetColorAtPoint(mxx, myy); FSelected := GetColorAtPoint(mxx, myy);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
VK_UP: VK_UP:
begin begin
mxx := dx; mxx := dx;
myy := dy - 1; myy := dy - 1;
FSelected := GetColorAtPoint(mxx, myy); FSelected := GetColorAtPoint(mxx, myy);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
VK_DOWN: VK_DOWN:
begin begin
mxx := dx; mxx := dx;
@ -344,38 +303,23 @@ end;
procedure TBAxisColorPicker.SetRValue(r: integer); procedure TBAxisColorPicker.SetRValue(r: integer);
begin begin
if r > 255 then r := 255; Clamp(r, 0, 255);
if r < 0 then r := 0; FR := r;
FR := r; SetSelectedColor(RGB(FR, FG, FB));
SetSelectedColor(RGB(FR, FG, FB));
end; end;
procedure TBAxisColorPicker.SetGValue(g: integer); procedure TBAxisColorPicker.SetGValue(g: integer);
begin begin
if g > 255 then g := 255; Clamp(g, 0, 255);
if g < 0 then g := 0; FG := g;
FG := g; SetSelectedColor(RGB(FR, FG, FB));
SetSelectedColor(RGB(FR, FG, FB));
end; end;
procedure TBAxisColorPicker.SetBValue(b: integer); procedure TBAxisColorPicker.SetBValue(b: integer);
begin begin
if b > 255 then b := 255; Clamp(b, 0, 255);
if b < 0 then b := 0; FB := b;
FB := b; SetSelectedColor(RGB(FR, FG, FB));
SetSelectedColor(RGB(FR, FG, FB));
end;
function TBAxisColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure TBAxisColorPicker.WebSafeChanged;
begin
inherited;
CreateRGBGradient;
Invalidate;
end; end;
end. end.

343
components/mbColorLib/CIEAColorPicker.pas
View File

@ -7,57 +7,45 @@ unit CIEAColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms, SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, SelPropUtils, mbColorPickerControl, RGBCIEUtils, Scanlines; HTMLColors, RGBCIEUtils, mbColorPickerControl;
type type
TCIEAColorPicker = class(TmbColorPickerControl) TCIEAColorPicker = class(TmbColorPickerControl)
private private
FSelected: TColor; FL, FA, FB: integer;
FBmp: TBitmap; dx, dy, mxx, myy: integer;
FOnChange: TNotifyEvent; procedure SetLValue(l: integer);
FL, FA, FB: integer; procedure SetAValue(a: integer);
FManual: boolean; procedure SetBValue(b: integer);
dx, dy, mxx, myy: integer; protected
function GetGradientColor2D(x, y: Integer): TColor; override;
procedure SetLValue(l: integer); procedure SetSelectedColor(c: TColor); override;
procedure SetAValue(a: integer); procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
procedure SetBValue(b: integer); message CN_KEYDOWN;
protected procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
function GetSelectedColor: TColor; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure WebSafeChanged; override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure SetSelectedColor(c: TColor); override; procedure DrawMarker(x, y: integer);
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); procedure Paint; override;
message CN_KEYDOWN; procedure Resize; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure CreateWnd; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure CorrectCoords(var x, y: integer);
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; public
procedure DrawMarker(x, y: integer); constructor Create(AOwner: TComponent); override;
procedure Paint; override; published
procedure CreateLABGradient; property SelectedColor default clFuchsia;
procedure Resize; override; property LValue: integer read FL write SetLValue default 100;
procedure CreateWnd; override; property AValue: integer read FA write SetAValue default 127;
procedure CorrectCoords(var x, y: integer); property BValue: integer read FB write SetBValue default -128;
public property MarkerStyle default msCircle;
constructor Create(AOwner: TComponent); override; property OnChange;
destructor Destroy; override; end;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property SelectedColor default clFuchsia;
property LValue: integer read FL write SetLValue default 100;
property AValue: integer read FA write SetAValue default 127;
property BValue: integer read FB write SetBValue default -128;
property MarkerStyle default msCircle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
procedure Register; procedure Register;
@ -67,189 +55,165 @@ implementation
{$R CIEAColorPicker.dcr} {$R CIEAColorPicker.dcr}
{$ENDIF} {$ENDIF}
uses
mbUtils;
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TCIEAColorPicker]); RegisterComponents('mbColor Lib', [TCIEAColorPicker]);
end; end;
{TCIEAColorPicker} {TCIEAColorPicker}
constructor TCIEAColorPicker.Create(AOwner: TComponent); constructor TCIEAColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FBmp := TBitmap.Create; {
FBmp.PixelFormat := pf32bit; FBmp := TBitmap.Create;
FBmp.SetSize(256, 256); FBmp.PixelFormat := pf32bit;
Width := 256; FBmp.SetSize(256, 256);
Height := 256; }
HintFormat := 'L: %cieL B: %cieB'#13'Hex: %hex'; FGradientWidth := 256;
FSelected := clFuchsia; FGradientHeight := 256;
FL := 100; {$IFDEF DELPHI}
FA := 127; Width := 256;
FB := -128; Height := 256;
FManual := false; {$ELSE}
dx := 0; SetInitialBounds(0, 0, 256, 256);
dy := 0; {$ENDIF}
mxx := 0; HintFormat := 'L: %cieL B: %cieB'#13'Hex: %hex';
myy := 0; FSelected := clFuchsia;
MarkerStyle := msCircle; FL := 100;
end; FA := 127;
FB := -128;
destructor TCIEAColorPicker.Destroy; FManual := false;
begin dx := 0;
FBmp.Free; dy := 0;
inherited Destroy; mxx := 0;
myy := 0;
MarkerStyle := msCircle;
end; end;
procedure TCIEAColorPicker.CreateWnd; procedure TCIEAColorPicker.CreateWnd;
begin begin
inherited; inherited;
CreateLABGradient; CreateGradient;
end; end;
procedure TCIEAColorPicker.CreateLABGradient; // In the original code: for L ... for B ... LabToRGB(Round(100-L*100/255), FA, B-128);
var // --> x is B, y is L
l, b: integer; function TCIEAColorPicker.GetGradientColor2D(x, y: Integer): TColor;
row: pRGBQuadArray;
begin begin
if FBmp = nil then Result := LabToRGB(Round(100 - y*100/255), FA, x - 128);
begin
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.Width := 256;
FBmp.Height := 256;
end;
for l := 255 downto 0 do
begin
row := FBmp.Scanline[l];
for b := 0 to 255 do
if not WebSafe then
row[b] := RGBtoRGBQuad(LabToRGB(Round(100 - l*100/255), FA, b - 128))
else
row[b] := RGBtoRGBQuad(GetWebSafe(LabToRGB(Round(100 - l*100/255), FA, b - 128)));
end;
end; end;
procedure TCIEAColorPicker.CorrectCoords(var x, y: integer); procedure TCIEAColorPicker.CorrectCoords(var x, y: integer);
begin begin
if x < 0 then x := 0; Clamp(x, 0, Width - 1);
if y < 0 then y := 0; Clamp(y, 0, Height - 1);
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
end; end;
procedure TCIEAColorPicker.DrawMarker(x, y: integer); procedure TCIEAColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
begin begin
CorrectCoords(x, y); CorrectCoords(x, y);
FL := Round(GetCIELValue(FSelected)); FL := Round(GetCIELValue(FSelected));
FA := Round(GetCIEAValue(FSelected)); FA := Round(GetCIEAValue(FSelected));
FB := Round(GetCIEBValue(FSelected)); FB := Round(GetCIEBValue(FSelected));
if Assigned(FOnChange) then if Assigned(FOnChange) then
FOnChange(Self); FOnChange(Self);
dx := x; dx := x;
dy := y; dy := y;
if Focused or (csDesigning in ComponentState) then if Focused or (csDesigning in ComponentState) then
c := clBlack c := clBlack
else else
c := clWhite; c := clWhite;
case MarkerStyle of InternalDrawMarker(x, y, c);
msCircle: DrawSelCirc(x, y, Canvas);
msSquare: DrawSelSquare(x, y, Canvas);
msCross: DrawSelCross(x, y, Canvas, c);
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
end;
end;
function TCIEAColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
end; end;
procedure TCIEAColorPicker.SetSelectedColor(c: TColor); procedure TCIEAColorPicker.SetSelectedColor(c: TColor);
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
FL := Round(GetCIELValue(c)); FL := Round(GetCIELValue(c));
FA := Round(GetCIEAValue(c)); FA := Round(GetCIEAValue(c));
FB := Round(GetCIEBValue(c)); FB := Round(GetCIEBValue(c));
FSelected := c; FSelected := c;
FManual := false; FManual := false;
mxx := Round((FB+128)*(Width/255)); mxx := Round((FB+128)*(Width/255));
myy := Round(((100-FL)*255/100)*(Height/255)); myy := Round(((100-FL)*255/100)*(Height/255));
CreateLABGradient; CreateGradient;
Invalidate; Invalidate;
end; end;
procedure TCIEAColorPicker.Paint; procedure TCIEAColorPicker.Paint;
begin begin
Canvas.StretchDraw(ClientRect, FBmp); Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy); CorrectCoords(mxx, myy);
DrawMarker(mxx, myy); DrawMarker(mxx, myy);
end; end;
procedure TCIEAColorPicker.Resize; procedure TCIEAColorPicker.Resize;
begin begin
FManual := false; FManual := false;
mxx := Round((FB+128)*(Width/255)); mxx := Round((FB+128)*(Width/255));
myy := Round(((100-FL)*255/100)*(Height/255)); myy := Round(((100-FL)*255/100)*(Height/255));
inherited; inherited;
end; end;
procedure TCIEAColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TCIEAColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var var
R: TRect; R: TRect;
begin begin
inherited; inherited;
mxx := x; mxx := x;
myy := y; myy := y;
if Button = mbLeft then if Button = mbLeft then
begin begin
R := ClientRect; R := ClientRect;
R.TopLeft := ClientToScreen(R.TopLeft); R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight); R.BottomRight := ClientToScreen(R.BottomRight);
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(@R); ClipCursor(@R);
{$ENDIF} {$ENDIF}
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
SetFocus; SetFocus;
end; end;
procedure TCIEAColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TCIEAColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(nil); ClipCursor(nil);
{$ENDIF} {$ENDIF}
mxx := x; mxx := x;
myy := y; myy := y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
procedure TCIEAColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TCIEAColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
if ssLeft in Shift then if ssLeft in Shift then
begin begin
mxx := x; mxx := x;
myy := y; myy := y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
end; end;
procedure TCIEAColorPicker.CNKeyDown( procedure TCIEAColorPicker.CNKeyDown(
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} );
var var
Shift: TShiftState; Shift: TShiftState;
FInherited: boolean; FInherited: boolean;
begin begin
FInherited := false; FInherited := false;
Shift := KeyDataToShiftState(Message.KeyData); Shift := KeyDataToShiftState(Message.KeyData);
@ -344,38 +308,23 @@ end;
procedure TCIEAColorPicker.SetLValue(l: integer); procedure TCIEAColorPicker.SetLValue(l: integer);
begin begin
if l > 100 then l := 100; Clamp(L, 0, 100);
if l < 0 then l := 0; FL := L;
FL := l; SetSelectedColor(LabToRGB(FL, FA, FB));
SetSelectedColor(LabToRGB(FL, FA, FB));
end; end;
procedure TCIEAColorPicker.SetAValue(a: integer); procedure TCIEAColorPicker.SetAValue(a: integer);
begin begin
if a > 127 then a := 127; Clamp(a, -128, 127);
if a < -128 then a := -128; FA := a;
FA := a; SetSelectedColor(LabToRGB(FL, FA, FB));
SetSelectedColor(LabToRGB(FL, FA, FB));
end; end;
procedure TCIEAColorPicker.SetBValue(b: integer); procedure TCIEAColorPicker.SetBValue(b: integer);
begin begin
if b > 127 then b := 127; Clamp(b, -128, 127);
if b < -128 then b := -128; FB := b;
FB := b; SetSelectedColor(LabToRGB(FL, FA, FB));
SetSelectedColor(LabToRGB(FL, FA, FB));
end;
function TCIEAColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure TCIEAColorPicker.WebSafeChanged;
begin
inherited;
CreateLABGradient;
Invalidate;
end; end;
end. end.

337
components/mbColorLib/CIEBColorPicker.pas
View File

@ -7,57 +7,48 @@ unit CIEBColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms, SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, SelPropUtils, mbColorPickerControl, RGBCIEUtils, Scanlines; HTMLColors, RGBCIEUtils, mbColorPickerControl;
type type
TCIEBColorPicker = class(TmbColorPickerControl)
private
FSelected: TColor;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FL, FA, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer;
procedure SetLValue(l: integer); { TCIEBColorPicker }
procedure SetAValue(a: integer);
procedure SetBValue(b: integer);
protected
function GetSelectedColor: TColor; override;
procedure WebSafeChanged; override;
procedure SetSelectedColor(c: TColor); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
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 DrawMarker(x, y: integer);
procedure Paint; override;
procedure CreateLABGradient;
procedure Resize; override;
procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override; TCIEBColorPicker = class(TmbColorPickerControl)
property Manual: boolean read FManual; private
published FL, FA, FB: integer;
property SelectedColor default clLime; dx, dy, mxx, myy: integer;
property LValue: integer read FL write SetLValue default 100; procedure SetLValue(l: integer);
property AValue: integer read FA write SetAValue default -128; procedure SetAValue(a: integer);
property BValue: integer read FB write SetBValue default 127; procedure SetBValue(b: integer);
property MarkerStyle default msCircle; protected
function GetGradientColor2D(x, y: Integer): TColor; override;
property OnChange: TNotifyEvent read FOnChange write FOnChange; procedure SetSelectedColor(c: TColor); override;
end; procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
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 DrawMarker(x, y: integer);
procedure Paint; override;
procedure Resize; override;
procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer);
public
constructor Create(AOwner: TComponent); override;
published
property SelectedColor default clLime;
property LValue: integer read FL write SetLValue default 100;
property AValue: integer read FA write SetAValue default -128;
property BValue: integer read FB write SetBValue default 127;
property MarkerStyle default msCircle;
property OnChange;
end;
procedure Register; procedure Register;
@ -67,181 +58,152 @@ implementation
{$R CIEBColorPicker.dcr} {$R CIEBColorPicker.dcr}
{$ENDIF} {$ENDIF}
uses
mbUtils;
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TCIEBColorPicker]); RegisterComponents('mbColor Lib', [TCIEBColorPicker]);
end; end;
{TCIEBColorPicker} {TCIEBColorPicker}
constructor TCIEBColorPicker.Create(AOwner: TComponent); constructor TCIEBColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FBmp := TBitmap.Create; FGradientWidth := 256;
FBmp.PixelFormat := pf32bit; FGradientHeight := 256;
FBmp.SetSize(256, 256); {$IFDEF DELPHI}
Width := 256; Width := 256;
Height := 256; Height := 256;
HintFormat := 'L: %cieL A: %cieA'#13'Hex: %hex'; {$ELSE}
FSelected := clLime; SetInitialBounds(0, 0, 256, 256);
FL := 100; {$ENDIF}
FA := -128; HintFormat := 'L: %cieL A: %cieA'#13'Hex: %hex';
FB := 127; FSelected := clLime;
FManual := false; FL := 100;
dx := 0; FA := -128;
dy := 0; FB := 127;
mxx := 0; FManual := false;
myy := 0; dx := 0;
MarkerStyle := msCircle; dy := 0;
end; mxx := 0;
myy := 0;
destructor TCIEBColorPicker.Destroy; MarkerStyle := msCircle;
begin
FBmp.Free;
inherited Destroy;
end; end;
procedure TCIEBColorPicker.CreateWnd; procedure TCIEBColorPicker.CreateWnd;
begin begin
inherited; inherited;
CreateLABGradient; CreateGradient;
end; end;
procedure TCIEBColorPicker.CreateLABGradient; { In the original code: for L ... for A ... LabToRGB(Round(100-L*100/244), A-128, FB)
var --> x is A, y is L}
l, a: integer; function TCIEBColorPicker.GetGradientColor2D(x, y: Integer): TColor;
row: pRGBQuadArray;
begin begin
if FBmp = nil then Result := LabToRGB(Round(100 - y*100/255), x - 128, FB);
begin
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.Width := 256;
FBmp.Height := 256;
end;
for l := 255 downto 0 do
begin
row := FBmp.Scanline[l];
for a := 0 to 255 do
if not WebSafe then
row[a] := RGBtoRGBQuad(LabToRGB(Round(100 - l*100/255), a-128, FB))
else
row[a] := RGBtoRGBQuad(GetWebSafe(LabToRGB(Round(100 - l*100/255), a-128, FB)));
end;
end; end;
procedure TCIEBColorPicker.CorrectCoords(var x, y: integer); procedure TCIEBColorPicker.CorrectCoords(var x, y: integer);
begin begin
if x < 0 then x := 0; Clamp(x, 0, Width - 1);
if y < 0 then y := 0; Clamp(y, 0, Height - 1);
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
end; end;
procedure TCIEBColorPicker.DrawMarker(x, y: integer); procedure TCIEBColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
begin begin
CorrectCoords(x, y); CorrectCoords(x, y);
FL := Round(GetCIELValue(FSelected)); FL := Round(GetCIELValue(FSelected));
FA := Round(GetCIEAValue(FSelected)); FA := Round(GetCIEAValue(FSelected));
FB := Round(GetCIEBValue(FSelected)); FB := Round(GetCIEBValue(FSelected));
if Assigned(FOnChange) then if Assigned(FOnChange) then
FOnChange(Self); FOnChange(Self);
dx := x; dx := x;
dy := y; dy := y;
if Focused or (csDesigning in ComponentState) then if Focused or (csDesigning in ComponentState) then
c := clBlack c := clBlack
else else
c := clWhite; c := clWhite;
case MarkerStyle of InternalDrawMarker(x, y, c);
msCircle: DrawSelCirc(x, y, Canvas);
msSquare: DrawSelSquare(x, y, Canvas);
msCross: DrawSelCross(x, y, Canvas, c);
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
end;
end;
function TCIEBColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
end; end;
procedure TCIEBColorPicker.SetSelectedColor(c: TColor); procedure TCIEBColorPicker.SetSelectedColor(c: TColor);
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
FL := Round(GetCIELValue(c)); FL := Round(GetCIELValue(c));
FA := Round(GetCIEAValue(c)); FA := Round(GetCIEAValue(c));
FB := Round(GetCIEBValue(c)); FB := Round(GetCIEBValue(c));
FSelected := c; FSelected := c;
FManual := false; FManual := false;
mxx := Round((FA+128)*(Width/255)); mxx := Round((FA+128)*(Width/255));
myy := Round(((100-FL)*255/100)*(Height/255)); myy := Round(((100-FL)*255/100)*(Height/255));
CreateLABGradient; CreateGradient;
Invalidate; Invalidate;
end; end;
procedure TCIEBColorPicker.Paint; procedure TCIEBColorPicker.Paint;
begin begin
Canvas.StretchDraw(ClientRect, FBmp); Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy); CorrectCoords(mxx, myy);
DrawMarker(mxx, myy); DrawMarker(mxx, myy);
end; end;
procedure TCIEBColorPicker.Resize; procedure TCIEBColorPicker.Resize;
begin begin
FManual := false; FManual := false;
mxx := Round((FA+128)*(Width/255)); mxx := Round((FA + 128) * (Width / 255));
myy := Round(((100-FL)*255/100)*(Height/255)); myy := Round(((100 - FL) * 255 / 100) * (Height / 255));
inherited; inherited;
end; end;
procedure TCIEBColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TCIEBColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var var
R: TRect; R: TRect;
begin begin
inherited; inherited;
mxx := x; mxx := x;
myy := y; myy := y;
if Button = mbLeft then if Button = mbLeft then
begin begin
R := ClientRect; R := ClientRect;
R.TopLeft := ClientToScreen(R.TopLeft); R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight); R.BottomRight := ClientToScreen(R.BottomRight);
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(@R); ClipCursor(@R);
{$ENDIF} {$ENDIF}
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
SetFocus; SetFocus;
end; end;
procedure TCIEBColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TCIEBColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(nil); ClipCursor(nil);
{$ENDIF} {$ENDIF}
mxx := x; mxx := x;
myy := y; myy := y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
procedure TCIEBColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TCIEBColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
if ssLeft in Shift then if ssLeft in Shift then
begin begin
mxx := x; mxx := x;
myy := y; myy := y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
end; end;
@ -342,40 +304,25 @@ begin
OnKeyDown(Self, Message.CharCode, Shift); OnKeyDown(Self, Message.CharCode, Shift);
end; end;
procedure TCIEBColorPicker.SetLValue(l: integer); procedure TCIEBColorPicker.SetLValue(L: integer);
begin begin
if l > 100 then l := 100; Clamp(L, 0, 100);
if l < 0 then l := 0; FL := L;
FL := l; SetSelectedColor(LabToRGB(FL, FA, FB));
SetSelectedColor(LabToRGB(FL, FA, FB));
end; end;
procedure TCIEBColorPicker.SetAValue(a: integer); procedure TCIEBColorPicker.SetAValue(a: integer);
begin begin
if a > 127 then a := 127; Clamp(a, -128, 127);
if a < -128 then a := -128; FA := a;
FA := a; SetSelectedColor(LabToRGB(FL, FA, FB));
SetSelectedColor(LabToRGB(FL, FA, FB));
end; end;
procedure TCIEBColorPicker.SetBValue(b: integer); procedure TCIEBColorPicker.SetBValue(b: integer);
begin begin
if b > 127 then b := 127; Clamp(b, -128, 127);
if b < -128 then b := -128; FB := b;
FB := b; SetSelectedColor(LabToRGB(FL, FA, FB));
SetSelectedColor(LabToRGB(FL, FA, FB));
end;
function TCIEBColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure TCIEBColorPicker.WebSafeChanged;
begin
inherited;
CreateLABGradient;
Invalidate;
end; end;
end. end.

335
components/mbColorLib/CIELColorPicker.pas
View File

@ -7,56 +7,44 @@ unit CIELColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms, SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, SelPropUtils, mbColorPickerControl, RGBCIEUtils, Scanlines; HTMLColors, RGBCIEUtils, mbColorPickerControl;
type type
TCIELColorPicker = class(TmbColorPickerControl) TCIELColorPicker = class(TmbColorPickerControl)
private private
FSelected: TColor; FL, FA, FB: integer;
FBmp: TBitmap; dx, dy, mxx, myy: integer;
FOnChange: TNotifyEvent; procedure SetLValue(l: integer);
FL, FA, FB: integer; procedure SetAValue(a: integer);
FManual: boolean; procedure SetBValue(b: integer);
dx, dy, mxx, myy: integer; protected
function GetGradientColor2D(x, y: Integer): TColor; override;
procedure SetLValue(l: integer); procedure SetSelectedColor(c: TColor); override;
procedure SetAValue(a: integer); procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
procedure SetBValue(b: integer); message CN_KEYDOWN;
protected procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
function GetSelectedColor: TColor; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure WebSafeChanged; override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure SetSelectedColor(c: TColor); override; procedure DrawMarker(x, y: integer);
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); procedure Paint; override;
message CN_KEYDOWN; procedure Resize; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure CreateWnd; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure CorrectCoords(var x, y: integer);
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; public
procedure DrawMarker(x, y: integer); constructor Create(AOwner: TComponent); override;
procedure Paint; override; published
procedure CreateLABGradient; property SelectedColor default clAqua;
procedure Resize; override; property LValue: integer read FL write SetLValue default 100;
procedure CreateWnd; override; property AValue: integer read FA write SetAValue default -128;
procedure CorrectCoords(var x, y: integer); property BValue: integer read FB write SetBValue default 127;
public property MarkerStyle default msCircle;
constructor Create(AOwner: TComponent); override; property OnChange;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property SelectedColor default clAqua;
property LValue: integer read FL write SetLValue default 100;
property AValue: integer read FA write SetAValue default -128;
property BValue: integer read FB write SetBValue default 127;
property MarkerStyle default msCircle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end; end;
procedure Register; procedure Register;
@ -67,183 +55,151 @@ implementation
{$R CIELColorPicker.dcr} {$R CIELColorPicker.dcr}
{$ENDIF} {$ENDIF}
uses
mbUtils;
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TCIELColorPicker]); RegisterComponents('mbColor Lib', [TCIELColorPicker]);
end; end;
{TCIELColorPicker} {TCIELColorPicker}
constructor TCIELColorPicker.Create(AOwner: TComponent); constructor TCIELColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FBmp := TBitmap.Create; FGradientWidth := 256;
FBmp.PixelFormat := pf32bit; FGradientHeight := 256;
FBmp.SetSize(256, 256); {$IFDEF DELPHI}
Width := 256; Width := 256;
Height := 256; Height := 256;
HintFormat := 'A: %cieA B: %cieB'#13'Hex: %hex'; {$ELSE}
FSelected := clAqua; SetInitialBounds(0, 0, 256, 256);
FL := 100; {$ENDIF}
FA := -128; HintFormat := 'A: %cieA B: %cieB'#13'Hex: %hex';
FB := 127; FSelected := clAqua;
FManual := false; FL := 100;
dx := 0; FA := -128;
dy := 0; FB := 127;
mxx := 0; FManual := false;
myy := 0; dx := 0;
MarkerStyle := msCircle; dy := 0;
end; mxx := 0;
myy := 0;
destructor TCIELColorPicker.Destroy; MarkerStyle := msCircle;
begin
FBmp.Free;
inherited Destroy;
end; end;
procedure TCIELColorPicker.CreateWnd; procedure TCIELColorPicker.CreateWnd;
begin begin
inherited; inherited;
CreateLABGradient; CreateGradient;
end; end;
procedure TCIELColorPicker.CreateLABGradient; { Original code: for A ... for B ---> LabToRGB(FL, A - 128, B - 128) }
var function TCIELColorPicker.GetGradientColor2D(x, y: Integer): TColor;
a, b: integer;
row: pRGBQuadArray;
begin begin
if FBmp = nil then Result := LabToRGB(FL, y - 128, x - 128);
begin
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.Width := 256;
FBmp.Height := 256;
end;
for a := 0 to 255 do
for b := 255 downto 0 do
begin
row := FBmp.Scanline[255 - b];
if not WebSafe then
row[a] := RGBToRGBQuad(LabToRGB(FL, a - 128, b - 128))
// FBmp.Canvas.Pixels[a, 255 - b] := LabToRGB(FL, a - 128, b - 128)
else
row[a] := RGBToRGBQuad(GetWebSafe(LabToRGB(FL, a - 128, b - 128)));
// FBmp.Canvas.Pixels[a, 255 - b] := GetWebSafe(LabToRGB(FL, a - 128, b - 128));
end;
end; end;
procedure TCIELColorPicker.CorrectCoords(var x, y: integer); procedure TCIELColorPicker.CorrectCoords(var x, y: integer);
begin begin
if x < 0 then x := 0; Clamp(x, 0, Width - 1);
if y < 0 then y := 0; clamp(y, 0, Height - 1);
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
end; end;
procedure TCIELColorPicker.DrawMarker(x, y: integer); procedure TCIELColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
begin begin
CorrectCoords(x, y); CorrectCoords(x, y);
FL := Round(GetCIELValue(FSelected)); FL := Round(GetCIELValue(FSelected));
FA := Round(GetCIEAValue(FSelected)); FA := Round(GetCIEAValue(FSelected));
FB := Round(GetCIEBValue(FSelected)); FB := Round(GetCIEBValue(FSelected));
if Assigned(FOnChange) then if Assigned(FOnChange) then
FOnChange(Self); FOnChange(Self);
dx := x; dx := x;
dy := y; dy := y;
if Focused or (csDesigning in ComponentState) then if Focused or (csDesigning in ComponentState) then
c := clBlack c := clBlack
else else
c := clWhite; c := clWhite;
case MarkerStyle of InternalDrawMarker(x, y, c);
msCircle: DrawSelCirc(x, y, Canvas);
msSquare: DrawSelSquare(x, y, Canvas);
msCross: DrawSelCross(x, y, Canvas, c);
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
end;
end;
function TCIELColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
end; end;
procedure TCIELColorPicker.SetSelectedColor(c: TColor); procedure TCIELColorPicker.SetSelectedColor(c: TColor);
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
FL := Round(GetCIELValue(c)); FL := Round(GetCIELValue(c));
FA := Round(GetCIEAValue(c)); FA := Round(GetCIEAValue(c));
FB := Round(GetCIEBValue(c)); FB := Round(GetCIEBValue(c));
FSelected := c; FSelected := c;
FManual := false; FManual := false;
mxx := Round((FA+128)*(Width/255)); mxx := Round((FA+128)*(Width/255));
myy := Round((255-(FB+128))*(Height/255)); myy := Round((255-(FB+128))*(Height/255));
CreateLABGradient; CreateGradient;
Invalidate; Invalidate;
end; end;
procedure TCIELColorPicker.Paint; procedure TCIELColorPicker.Paint;
begin begin
Canvas.StretchDraw(ClientRect, FBmp); Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy); CorrectCoords(mxx, myy);
DrawMarker(mxx, myy); DrawMarker(mxx, myy);
end; end;
procedure TCIELColorPicker.Resize; procedure TCIELColorPicker.Resize;
begin begin
FManual := false; FManual := false;
mxx := Round((FA+128)*(Width/255)); mxx := Round((FA+128)*(Width/255));
myy := Round((255-(FB+128))*(Height/255)); myy := Round((255-(FB+128))*(Height/255));
inherited; inherited;
end; end;
procedure TCIELColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TCIELColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var var
R: TRect; R: TRect;
begin begin
inherited; inherited;
mxx := x; mxx := x;
myy := y; myy := y;
if Button = mbLeft then if Button = mbLeft then
begin begin
R := ClientRect; R := ClientRect;
R.TopLeft := ClientToScreen(R.TopLeft); R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight); R.BottomRight := ClientToScreen(R.BottomRight);
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(@R); ClipCursor(@R);
{$ENDIF} {$ENDIF}
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
SetFocus; SetFocus;
end; end;
procedure TCIELColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TCIELColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(nil); ClipCursor(nil);
{$ENDIF} {$ENDIF}
mxx := x; mxx := x;
myy := y; myy := y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
procedure TCIELColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TCIELColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
if ssLeft in Shift then if ssLeft in Shift then
begin begin
mxx := x; mxx := x;
myy := y; myy := y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
end; end;
@ -346,38 +302,23 @@ end;
procedure TCIELColorPicker.SetLValue(l: integer); procedure TCIELColorPicker.SetLValue(l: integer);
begin begin
if l > 100 then l := 100; Clamp(L, 0, 100);
if l < 0 then l := 0; FL := L;
FL := l; SetSelectedColor(LabToRGB(FL, FA, FB));
SetSelectedColor(LabToRGB(FL, FA, FB));
end; end;
procedure TCIELColorPicker.SetAValue(a: integer); procedure TCIELColorPicker.SetAValue(a: integer);
begin begin
if a > 127 then a := 127; Clamp(A, -128, 127);
if a < -128 then a := -128; FA := a;
FA := a; SetSelectedColor(LabToRGB(FL, FA, FB));
SetSelectedColor(LabToRGB(FL, FA, FB));
end; end;
procedure TCIELColorPicker.SetBValue(b: integer); procedure TCIELColorPicker.SetBValue(b: integer);
begin begin
if b > 127 then b := 127; Clamp(b, -128, 127);
if b < -128 then b := -128; FB := b;
FB := b; SetSelectedColor(LabToRGB(FL, FA, FB));
SetSelectedColor(LabToRGB(FL, FA, FB));
end;
function TCIELColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure TCIELColorPicker.WebSafeChanged;
begin
inherited;
CreateLABGradient;
Invalidate;
end; end;
end. end.

7
components/mbColorLib/Demo/Demo.lpi
View File

@ -58,6 +58,13 @@
<IncludeFiles Value="$(ProjOutDir)"/> <IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths> </SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions> </CompilerOptions>
<Debugging> <Debugging>
<Exceptions Count="3"> <Exceptions Count="3">

76
components/mbColorLib/Demo/main.lfm
View File

@ -42,9 +42,9 @@ object Form1: TForm1
Height = 331 Height = 331
Top = 6 Top = 6
Width = 399 Width = 399
ActivePage = TabSheet11 ActivePage = TabSheet1
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
TabIndex = 6 TabIndex = 0
TabOrder = 0 TabOrder = 0
object TabSheet1: TTabSheet object TabSheet1: TTabSheet
Caption = 'HSLColorPicker' Caption = 'HSLColorPicker'
@ -55,7 +55,7 @@ object Form1: TForm1
Height = 287 Height = 287
Top = 8 Top = 8
Width = 377 Width = 377
SelectedColor = 562183 SelectedColor = 494343
HSPickerHintFormat = 'H: %h S: %s'#13'Hex: %hex' HSPickerHintFormat = 'H: %h S: %s'#13'Hex: %hex'
LPickerHintFormat = 'Luminance: %l' LPickerHintFormat = 'Luminance: %l'
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
@ -991,13 +991,13 @@ object Form1: TForm1
end end
object TabSheet10: TTabSheet object TabSheet10: TTabSheet
Caption = 'Yet even more' Caption = 'Yet even more'
ClientHeight = 299 ClientHeight = 303
ClientWidth = 389 ClientWidth = 391
ImageIndex = 9 ImageIndex = 9
object RAxisColorPicker1: TRAxisColorPicker object RAxisColorPicker1: TRAxisColorPicker
Left = 10 Left = 10
Height = 100 Height = 100
Top = 8 Top = 28
Width = 100 Width = 100
HintFormat = 'G: %g B: %b'#13'Hex: %hex' HintFormat = 'G: %g B: %b'#13'Hex: %hex'
TabOrder = 0 TabOrder = 0
@ -1005,25 +1005,25 @@ object Form1: TForm1
object GAxisColorPicker1: TGAxisColorPicker object GAxisColorPicker1: TGAxisColorPicker
Left = 130 Left = 130
Height = 100 Height = 100
Top = 10 Top = 28
Width = 100 Width = 100
HintFormat = 'R: %r B: %b'#13'Hex: %hex' HintFormat = 'R: %r B: %b'#13'Hex: %hex'
TabOrder = 1 TabOrder = 1
MarkerStyle = msCross MarkerStyle = msCross
end end
object BAxisColorPicker1: TBAxisColorPicker object BAxisColorPicker1: TBAxisColorPicker
Left = 252 Left = 250
Height = 100 Height = 100
Top = 10 Top = 28
Width = 100 Width = 100
HintFormat = 'R: %r G: %g'#13'Hex: %hex' HintFormat = 'R: %r G: %g'#13'Hex: %hex'
TabOrder = 2 TabOrder = 2
MarkerStyle = msCrossCirc MarkerStyle = msCrossCirc
end end
object CIELColorPicker1: TCIELColorPicker object CIELColorPicker1: TCIELColorPicker
Left = 8 Left = 10
Height = 100 Height = 100
Top = 130 Top = 164
Width = 100 Width = 100
SelectedColor = 16119089 SelectedColor = 16119089
HintFormat = 'A: %cieA B: %cieB'#13'Hex: %hex' HintFormat = 'A: %cieA B: %cieB'#13'Hex: %hex'
@ -1033,9 +1033,9 @@ object Form1: TForm1
BValue = -32 BValue = -32
end end
object CIEAColorPicker1: TCIEAColorPicker object CIEAColorPicker1: TCIEAColorPicker
Left = 128 Left = 130
Height = 100 Height = 100
Top = 130 Top = 164
Width = 100 Width = 100
SelectedColor = 16515327 SelectedColor = 16515327
HintFormat = 'L: %cieL B: %cieB'#13'Hex: %hex' HintFormat = 'L: %cieL B: %cieB'#13'Hex: %hex'
@ -1048,7 +1048,7 @@ object Form1: TForm1
object CIEBColorPicker1: TCIEBColorPicker object CIEBColorPicker1: TCIEBColorPicker
Left = 250 Left = 250
Height = 100 Height = 100
Top = 130 Top = 164
Width = 100 Width = 100
SelectedColor = 130823 SelectedColor = 130823
HintFormat = 'L: %cieL A: %cieA'#13'Hex: %hex' HintFormat = 'L: %cieL A: %cieA'#13'Hex: %hex'
@ -1057,6 +1057,54 @@ object Form1: TForm1
AValue = -88 AValue = -88
BValue = 74 BValue = 74
end end
object Label10: TLabel
Left = 130
Height = 15
Top = 8
Width = 90
Caption = 'GAxisColorPicker'
ParentColor = False
end
object Label11: TLabel
Left = 10
Height = 15
Top = 8
Width = 89
Caption = 'RAxisColorPicker'
ParentColor = False
end
object Label12: TLabel
Left = 250
Height = 15
Top = 8
Width = 89
Caption = 'BAxisColorPicker'
ParentColor = False
end
object Label13: TLabel
Left = 10
Height = 15
Top = 144
Width = 84
Caption = 'CIELColorPicker'
ParentColor = False
end
object Label14: TLabel
Left = 130
Height = 15
Top = 144
Width = 86
Caption = 'CIEAColorPicker'
ParentColor = False
end
object Label15: TLabel
Left = 250
Height = 15
Top = 144
Width = 85
Caption = 'CIEBColorPicker'
ParentColor = False
end
end end
end end
object sc: TmbColorPreview object sc: TmbColorPreview

19
components/mbColorLib/Demo/main.pas
View File

@ -16,7 +16,16 @@ uses
mbColorTree, mbColorList {for internet shortcuts}; mbColorTree, mbColorList {for internet shortcuts};
type type
{ TForm1 }
TForm1 = class(TForm) TForm1 = class(TForm)
Label10: TLabel;
Label11: TLabel;
Label12: TLabel;
Label13: TLabel;
Label14: TLabel;
Label15: TLabel;
PageControl1: TPageControl; PageControl1: TPageControl;
TabSheet1: TTabSheet; TabSheet1: TTabSheet;
TabSheet2: TTabSheet; TabSheet2: TTabSheet;
@ -295,13 +304,13 @@ end;
// only for internet shortcuts // only for internet shortcuts
procedure TForm1.FormCreate(Sender: TObject); procedure TForm1.FormCreate(Sender: TObject);
begin begin
with TIniFile.Create(ExtractFilePath(Application.ExeName) + '\MXS Website.url') do with TIniFile.Create(ExtractFilePath(Application.ExeName) + '\MXS Website.url') do
try try
WriteString('InternetShortcut','URL', 'http://mxs.bergsoft.net'); WriteString('InternetShortcut','URL', 'http://mxs.bergsoft.net');
WriteInteger('InternetShortcut','IconIndex', 1); WriteInteger('InternetShortcut','IconIndex', 1);
WriteString('InternetShortcut','IconFile', '"' + Application.ExeName + '"'); WriteString('InternetShortcut','IconFile', '"' + Application.ExeName + '"');
finally finally
Free; Free;
end; end;
end; end;

345
components/mbColorLib/GAxisColorPicker.pas
View File

@ -7,57 +7,45 @@ unit GAxisColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLType, LCLIntf, LMessages, LCLType, LCLIntf, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms, SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines; HTMLColors, mbColorPickerControl;
type type
TGAxisColorPicker = class(TmbColorPickerControl) TGAxisColorPicker = class(TmbColorPickerControl)
private private
FSelected: TColor; FR, FG, FB: integer;
FBmp: TBitmap; dx, dy, mxx, myy: integer;
FOnChange: TNotifyEvent; procedure SetRValue(r: integer);
FR, FG, FB: integer; procedure SetGValue(g: integer);
FManual: boolean; procedure SetBValue(b: integer);
dx, dy, mxx, myy: integer; protected
function GetGradientColor2D(x, y: Integer): TColor; override;
procedure SetRValue(r: integer); procedure SetSelectedColor(c: TColor); override;
procedure SetGValue(g: integer); procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
procedure SetBValue(b: integer); message CN_KEYDOWN;
protected procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
function GetSelectedColor: TColor; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure WebSafeChanged; override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure SetSelectedColor(c: TColor); override; procedure DrawMarker(x, y: integer);
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); procedure Paint; override;
message CN_KEYDOWN; procedure Resize; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure CreateWnd; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure CorrectCoords(var x, y: integer);
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; public
procedure DrawMarker(x, y: integer); constructor Create(AOwner: TComponent); override;
procedure Paint; override; published
procedure CreateRGBGradient; property SelectedColor default clLime;
procedure Resize; override; property RValue: integer read FR write SetRValue default 0;
procedure CreateWnd; override; property GValue: integer read FG write SetGValue default 255;
procedure CorrectCoords(var x, y: integer); property BValue: integer read FB write SetBValue default 0;
public property MarkerStyle default msCircle;
constructor Create(AOwner: TComponent); override; property OnChange;
destructor Destroy; override; end;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property SelectedColor default clLime;
property RValue: integer read FR write SetRValue default 0;
property GValue: integer read FG write SetGValue default 255;
property BValue: integer read FB write SetBValue default 0;
property MarkerStyle default msCircle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
procedure Register; procedure Register;
@ -67,194 +55,164 @@ implementation
{$R GAxisColorPicker.dcr} {$R GAxisColorPicker.dcr}
{$ENDIF} {$ENDIF}
uses
mbUtils;
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TGAxisColorPicker]); RegisterComponents('mbColor Lib', [TGAxisColorPicker]);
end; end;
{TGAxisColorPicker} {TGAxisColorPicker}
constructor TGAxisColorPicker.Create(AOwner: TComponent); constructor TGAxisColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FBmp := TBitmap.Create; FGradientWidth := 256;
FBmp.PixelFormat := pf32bit; FGradientHeight := 256;
FBmp.SetSize(256, 256); {$IFDEF DELPHI}
Width := 256; Width := 256;
Height := 256; Height := 256;
HintFormat := 'R: %r B: %b'#13'Hex: %hex'; {$ELSE}
FG := 255; SetInitialBounds(0, 0, 256, 256);
FB := 0; {$ENDIF}
FR := 0; HintFormat := 'R: %r B: %b'#13'Hex: %hex';
FSelected := clLime; FG := 255;
FManual := false; FB := 0;
dx := 0; FR := 0;
dy := 0; FSelected := clLime;
mxx := 0; FManual := false;
myy := 0; dx := 0;
MarkerStyle := msCircle; dy := 0;
end; mxx := 0;
myy := 0;
destructor TGAxisColorPicker.Destroy; MarkerStyle := msCircle;
begin
FBmp.Free;
inherited Destroy;
end; end;
procedure TGAxisColorPicker.CreateWnd; procedure TGAxisColorPicker.CreateWnd;
begin begin
inherited; inherited;
CreateRGBGradient; CreateGradient;
end; end;
procedure TGAxisColorPicker.CreateRGBGradient; function TGAxisColorPicker.GetGradientColor2D(x, y: Integer): TColor;
var
r, b : integer;
row: pRGBQuadArray;
begin begin
if FBmp = nil then Result := RGB(FGradientBmp.Height - 1 - y, FG, x);
begin
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.Width := 256;
FBmp.Height := 256;
end;
for r := 255 downto 0 do
begin
row := FBmp.Scanline[255-r];
for b := 0 to 255 do
if not WebSafe then
row[b] := RGBtoRGBQuad(r, FG, b)
else
row[b] := RGBtoRGBQuad(GetWebSafe(RGB(r, FG, b)));
end;
end; end;
procedure TGAxisColorPicker.CorrectCoords(var x, y: integer); procedure TGAxisColorPicker.CorrectCoords(var x, y: integer);
begin begin
if x < 0 then x := 0; Clamp(x, 0, Width-1);
if y < 0 then y := 0; Clamp(y, 0, Height-1);
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
end; end;
procedure TGAxisColorPicker.DrawMarker(x, y: integer); procedure TGAxisColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
begin begin
CorrectCoords(x, y); CorrectCoords(x, y);
FR := GetRValue(FSelected); FR := GetRValue(FSelected);
FG := GetGValue(FSelected); FG := GetGValue(FSelected);
FB := GetBValue(FSelected); FB := GetBValue(FSelected);
if Assigned(FOnChange) then if Assigned(FOnChange) then
FOnChange(Self); FOnChange(Self);
dx := x; dx := x;
dy := y; dy := y;
if Focused or (csDesigning in ComponentState) then if Focused or (csDesigning in ComponentState) then
c := clBlack c := clBlack
else else
c := clWhite; c := clWhite;
case MarkerStyle of InternalDrawMarker(x, y, c);
msCircle: DrawSelCirc(x, y, Canvas);
msSquare: DrawSelSquare(x, y, Canvas);
msCross: DrawSelCross(x, y, Canvas, c);
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
end;
end;
function TGAxisColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
end; end;
procedure TGAxisColorPicker.SetSelectedColor(c: TColor); procedure TGAxisColorPicker.SetSelectedColor(c: TColor);
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
FR := GetRValue(c); FR := GetRValue(c);
FG := GetGValue(c); FG := GetGValue(c);
FB := GetBValue(c); FB := GetBValue(c);
FSelected := c; FSelected := c;
FManual := false; FManual := false;
myy := Round((255-FR)*(Height/255)); myy := Round((255-FR)*(Height/255));
mxx := Round(FB*(Width/255)); mxx := Round(FB*(Width/255));
CreateRGBGradient; CreateGradient;
Invalidate; Invalidate;
end; end;
procedure TGAxisColorPicker.Paint; procedure TGAxisColorPicker.Paint;
begin begin
Canvas.StretchDraw(ClientRect, FBmp); Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy); CorrectCoords(mxx, myy);
DrawMarker(mxx, myy); DrawMarker(mxx, myy);
end; end;
procedure TGAxisColorPicker.Resize; procedure TGAxisColorPicker.Resize;
begin begin
FManual := false; FManual := false;
myy := Round((255-FR)*(Height/255)); myy := Round((255-FR)*(Height/255));
mxx := Round(FB*(Width/255)); mxx := Round(FB*(Width/255));
inherited; inherited;
end; end;
procedure TGAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TGAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var var
R: TRect; R: TRect;
begin begin
inherited; inherited;
mxx := x; mxx := x;
myy := y; myy := y;
if Button = mbLeft then if Button = mbLeft then
begin begin
R := ClientRect; R := ClientRect;
R.TopLeft := ClientToScreen(R.TopLeft); R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight); R.BottomRight := ClientToScreen(R.BottomRight);
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(@R); ClipCursor(@R);
{$ENDIF} {$ENDIF}
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
SetFocus; SetFocus;
end; end;
procedure TGAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TGAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(nil); ClipCursor(nil);
{$ENDIF} {$ENDIF}
mxx := x; mxx := X;
myy := y; myy := Y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(X, Y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
procedure TGAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TGAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
if ssLeft in Shift then if ssLeft in Shift then
begin begin
mxx := x; mxx := X;
myy := y; myy := Y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(X, Y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
end; end;
procedure TGAxisColorPicker.CNKeyDown( procedure TGAxisColorPicker.CNKeyDown(
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
var var
Shift: TShiftState; Shift: TShiftState;
FInherited: boolean; FInherited: boolean;
begin begin
FInherited := false; FInherited := false;
Shift := KeyDataToShiftState(Message.KeyData); Shift := KeyDataToShiftState(Message.KeyData);
if not (ssCtrl in Shift) then if not (ssCtrl in Shift) then
case Message.CharCode of case Message.CharCode of
VK_LEFT: VK_LEFT:
begin begin
mxx := dx - 1; mxx := dx - 1;
myy := dy; myy := dy;
@ -343,38 +301,23 @@ end;
procedure TGAxisColorPicker.SetRValue(r: integer); procedure TGAxisColorPicker.SetRValue(r: integer);
begin begin
if r > 255 then r := 255; Clamp(r, 0, 255);
if r < 0 then r := 0; FR := r;
FR := r; SetSelectedColor(RGB(FR, FG, FB));
SetSelectedColor(RGB(FR, FG, FB));
end; end;
procedure TGAxisColorPicker.SetGValue(g: integer); procedure TGAxisColorPicker.SetGValue(g: integer);
begin begin
if g > 255 then g := 255; Clamp(g, 0, 255);
if g < 0 then g := 0; FG := g;
FG := g; SetSelectedColor(RGB(FR, FG, FB));
SetSelectedColor(RGB(FR, FG, FB));
end; end;
procedure TGAxisColorPicker.SetBValue(b: integer); procedure TGAxisColorPicker.SetBValue(b: integer);
begin begin
if b > 255 then b := 255; Clamp(b, 0, 255);
if b < 0 then b := 0; FB := b;
FB := b; SetSelectedColor(RGB(FR, FG, FB));
SetSelectedColor(RGB(FR, FG, FB));
end;
function TGAxisColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure TGAxisColorPicker.WebSafeChanged;
begin
inherited;
CreateRGBGradient;
Invalidate;
end; end;
end. end.

10
components/mbColorLib/HColorPicker.pas
View File

@ -61,11 +61,14 @@ end;
constructor THColorPicker.Create(AOwner: TComponent); constructor THColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FGradientWidth := 256; FGradientWidth := 360;
FGradientHeight := 12; FGradientHeight := 12;
{$IFDEF DELPHI}
Width := 267;
Height := 22;
{$ELSE}
SetInitialBounds(0, 0, 267, 22); SetInitialBounds(0, 0, 267, 22);
//Width := 267; {$ENDIF}
//Height := 22;
FSat := 255; FSat := 255;
FVal := 255; FVal := 255;
FArrowPos := ArrowPosFromHue(0); FArrowPos := ArrowPosFromHue(0);
@ -78,6 +81,7 @@ end;
function THColorPicker.GetGradientColor(AValue: Integer): TColor; function THColorPicker.GetGradientColor(AValue: Integer): TColor;
begin begin
if Layout = lyVertical then AValue := 360 - AValue;
Result := HSVtoColor(AValue, FSat, FVal); Result := HSVtoColor(AValue, FSat, FVal);
end; end;

564
components/mbColorLib/HRingPicker.pas
View File

@ -13,60 +13,52 @@ uses
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, RGBHSVUtils, SysUtils, Classes, Controls, Graphics, Math, RGBHSVUtils,
Forms, {IFDEF DELPHI_7_UP Themes, $ENDIF} HTMLColors, mbColorPickerControl, Forms, {IFDEF DELPHI_7_UP Themes, $ENDIF} HTMLColors, mbColorPickerControl;
Scanlines;
type type
THRingPicker = class(TmbColorPickerControl) THRingPicker = class(TmbColorPickerControl)
private private
FHue, FSat, FValue: integer; FHue, FSat, FValue: integer;
FHueLineColor: TColor; FHueLineColor: TColor;
FSelectedColor: TColor; FSelectedColor: TColor;
FOnChange: TNotifyEvent; FManual: boolean;
FManual: boolean; mx, my, mdx, mdy: integer;
mx, my, mdx, mdy: integer; FChange: boolean;
Fchange: boolean; FRadius: integer;
FRadius: integer; FDoChange: boolean;
FBMP: TBitmap; function RadHue(New: integer): integer;
FDoChange: boolean; procedure SetRadius(r: integer);
procedure SetValue(v: integer);
procedure CreateHSVCircle; procedure SetHue(h: integer);
function RadHue(New: integer): integer; procedure SetSat(s: integer);
procedure SetRadius(r: integer); procedure SetHueLineColor(c: TColor);
procedure SetValue(v: integer); procedure DrawHueLine;
procedure SetHue(h: integer); procedure SelectionChanged(x, y: integer);
procedure SetSat(s: integer); procedure UpdateCoords;
procedure SetHueLineColor(c: TColor);
procedure DrawHueLine;
procedure SelectionChanged(x, y: integer);
procedure UpdateCoords;
protected protected
function GetSelectedColor: TColor; override; procedure CreateGradient; override;
procedure WebSafeChanged; override; function GetGradientColor2D(X, Y: Integer): TColor; override;
procedure SetSelectedColor(c: TColor); override; function GetSelectedColor: TColor; override;
procedure Paint; override; procedure SetSelectedColor(c: TColor); override;
procedure Resize; override; procedure Paint; override;
procedure CreateWnd; override; procedure Resize; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure CreateWnd; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
message CN_KEYDOWN; procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; function GetColorAtPoint(x, y: integer): TColor; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published published
property Hue: integer read FHue write SetHue default 0; property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 0; property Saturation: integer read FSat write SetSat default 0;
property Value: integer read FValue write SetValue default 255; property Value: integer read FValue write SetValue default 255;
property HueLineColor: TColor read FHueLineColor write SetHueLineColor default clGray; property HueLineColor: TColor read FHueLineColor write SetHueLineColor default clGray;
property SelectedColor default clNone; property SelectedColor default clNone;
property Radius: integer read FRadius write SetRadius default 30; property Radius: integer read FRadius write SetRadius default 40;
property OnChange;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end; end;
procedure Register; procedure Register;
@ -75,223 +67,176 @@ implementation
{$IFDEF FPC} {$IFDEF FPC}
{$R HRingPicker.dcr} {$R HRingPicker.dcr}
{$ENDIF}
uses uses
IntfGraphics, fpimage; mbUtils;
{$ENDIF}
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [THRingPicker]); RegisterComponents('mbColor Lib', [THRingPicker]);
end; end;
function PointInCirc(p: TPoint; size : integer): boolean;
var { THRingPicker }
r: integer;
begin
r := size div 2;
Result := (SQR(p.x - r) + SQR(p.y - r) <= SQR(r));
end;
constructor THRingPicker.Create(AOwner: TComponent); constructor THRingPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FBMP := TBitmap.Create; {$IFDEF DELPHI}
FBMP.PixelFormat := pf32bit; Width := 204;
Width := 204; Height := 204;
Height := 204; {$ELSE}
FValue := 255; SetInitialBounds(0, 0, 204, 204);
FHue := 0;
FSat := 0;
FHueLineColor := clGray;
FSelectedColor := clNone;
FManual := false;
Fchange := true;
FRadius := 30;
FDoChange := false;
end;
destructor THRingPicker.Destroy;
begin
FBMP.Free;
inherited;
end;
procedure THRingPicker.CreateHSVCircle;
var
dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer;
row: pRGBQuadArray;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF} {$ENDIF}
FValue := 255;
FHue := 0;
FSat := 0;
FHueLineColor := clGray;
FSelectedColor := clNone;
FManual := false;
FChange := true;
FRadius := 40;
FDoChange := false;
end;
procedure THRingPicker.CreateGradient;
begin begin
if FBmp = nil then FGradientWidth := Min(Width, Height);
begin FGradientHeight := FGradientWidth;
FBmp := TBitmap.Create; inherited;
FBmp.PixelFormat := pf32bit; end;
end;
size := Min(Width, Height);
FBmp.Width := size;
FBmp.Height := size;
PaintParentBack(FBmp);
{ Outer loop: Y, Inner loop: X }
function THRingPicker.GetGradientColor2D(X, Y: Integer): TColor;
var
xcoord, ycoord: Integer;
dSq, radiusSq: Integer;
radius, size: Integer;
S, H, V: Integer;
q: TRGBQuad;
begin
size := FGradientWidth; // or Height, they are the same...
radius := size div 2; radius := size div 2;
radiusSquared := radius * radius; radiusSq := sqr(radius);
V := FValue; xcoord := X - radius;
ycoord := Y - radius;
{$IFDEF FPC} dSq := sqr(xcoord) + sqr(ycoord);
intfimg := TLazIntfImage.Create(FBmp.Width, FBmp.Height); if dSq <= radiusSq then
try begin
intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle); if radius <> 0 then
{$ENDIF} S := round((255 * sqrt(dSq)) / radius)
else
for j := 0 to size - 1 do S := 0;
begin H := round( 180 * (1 + arctan2(xcoord, ycoord) / pi)); // wp: order (x,y) is correct!
Y := Size - 1 - j - radius; H := H + 90;
if H > 360 then H := H - 360;
{$IFDEF FPC} Result := HSVtoColor(H, S, FValue);
row := intfImg.GetDataLineStart(size - 1 - j); if WebSafe then
{$ELSE} Result := GetWebSafe(Result);
row := FBmp.Scanline(size - 1 - j); end else
{$ENDIF} Result := GetDefaultColor(dctBrush);
for i := 0 to size - 1 do
begin
X := i - radius;
dSquared := X*X + Y*Y;
if dSquared <= radiusSquared then
begin
if Radius <> 0 then
S := round((255 * sqrt(dSquared)) / radius)
else
S := 0;
H := round( 180 * (1 + arctan2(X, Y) / PI)); // wp: order (x,y) is correct!
H := H + 90;
if H > 360 then H := H - 360;
if not WebSafe then
row[i] := HSVtoRGBQuad(H,S,V)
else
begin
c := GetWebSafe(HSVtoColor(H, S, V));
row[i] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
end;
end
end;
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBmp.Handle := imgHandle;
FBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
{$ENDIF}
end; end;
procedure THRingPicker.Resize; procedure THRingPicker.Resize;
begin begin
inherited; inherited;
CreateHSVCircle; CreateGradient;
UpdateCoords; UpdateCoords;
end; end;
procedure THRingPicker.CreateWnd; procedure THRingPicker.CreateWnd;
begin begin
inherited; inherited;
CreateHSVCircle; CreateGradient;
UpdateCoords; UpdateCoords;
end; end;
procedure THRingPicker.UpdateCoords; procedure THRingPicker.UpdateCoords;
var var
r, angle: real; r, angle: real;
radius: integer; radius: integer;
sinAngle, cosAngle: Double;
begin begin
radius := Min(Width, Height) div 2; radius := Min(Width, Height) div 2;
r := -MulDiv(radius, FSat, 255); r := -MulDiv(radius, FSat, 255);
angle := -FHue*PI/180 - PI; angle := -FHue * pi/180 - pi;
mdx := ROUND(COS(angle)*ROUND(r)) + radius; SinCos(angle, sinAngle, cosAngle);
mdy := ROUND(SIN(angle)*ROUND(r)) + radius; mdx := round(cosAngle * r) + radius;
mdy := round(sinAngle * r) + radius;
end; end;
procedure THRingPicker.SetHue(h: integer); procedure THRingPicker.SetHue(h: integer);
begin begin
if h > 360 then h := 360; Clamp(h, 0, 360);
if h < 0 then h := 0; if FHue <> h then
if FHue <> h then
begin begin
FHue := h; FHue := h;
FManual := false; FManual := false;
UpdateCoords; UpdateCoords;
Invalidate; Invalidate;
if Fchange then if FChange and Assigned(FOnChange) then FOnChange(Self);
if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure THRingPicker.SetSat(s: integer); procedure THRingPicker.SetSat(s: integer);
begin begin
if s > 255 then s := 255; Clamp(s, 0, 255);
if s < 0 then s := 0; if FSat <> s then
if FSat <> s then
begin begin
FSat := s; FSat := s;
FManual := false; FManual := false;
UpdateCoords; UpdateCoords;
Invalidate; Invalidate;
if Fchange then if FChange and Assigned(FOnChange) then FOnChange(Self);
if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure THRingPicker.SetValue(v: integer); procedure THRingPicker.SetValue(v: integer);
begin begin
if V > 255 then V := 255; Clamp(v, 0, 255);
if V < 0 then V := 0; if FValue <> V then
if FValue <> V then
begin begin
FValue := V; FValue := V;
FManual := false; FManual := false;
CreateHSVCircle; CreateGradient;
Invalidate; Invalidate;
if Fchange then if FChange and Assigned(FOnChange) then FOnChange(Self);
if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure THRingPicker.SetHueLineColor(c: TColor); procedure THRingPicker.SetHueLineColor(c: TColor);
begin begin
if FHueLineColor <> c then if FHueLineColor <> c then
begin begin
FHueLineColor := c; FHueLineColor := c;
Invalidate; Invalidate;
end; end;
end; end;
procedure THRingPicker.SetRadius(r: integer); procedure THRingPicker.SetRadius(r: integer);
begin begin
if FRadius <> r then if FRadius <> r then
begin begin
FRadius := r; FRadius := r;
Invalidate; Invalidate;
end; end;
end; end;
procedure THRingPicker.DrawHueLine; procedure THRingPicker.DrawHueLine;
var var
angle: double; angle: double;
radius: integer; sinAngle, cosAngle: Double;
radius: integer;
begin begin
Radius := Min(Width, Height) div 2; radius := Min(Width, Height) div 2;
if (FHue >= 0) and (FHue <= 360) then if (FHue >= 0) and (FHue <= 360) then
begin begin
Angle := -FHue*PI/180; angle := -FHue*PI/180;
Canvas.Pen.Color := FHueLineColor; SinCos(angle, sinAngle, cosAngle);
Canvas.MoveTo(Radius,Radius); Canvas.Pen.Color := FHueLineColor;
Canvas.LineTo(Radius + Round(Radius*COS(angle)), Radius + Round(Radius*SIN(angle))); Canvas.MoveTo(radius, radius);
Canvas.LineTo(radius + round(radius*cosAngle), radius + round(radius*sinAngle));
end; end;
end; end;
@ -308,6 +253,7 @@ begin
r := ClientRect; r := ClientRect;
r.Right := R.Left + size; r.Right := R.Left + size;
R.Bottom := R.Top + size; R.Bottom := R.Top + size;
InflateRect(R, -1, -1); // Remove spurious black pixels at the border
r1 := CreateEllipticRgnIndirect(R); r1 := CreateEllipticRgnIndirect(R);
if ringwidth > 0 then if ringwidth > 0 then
begin begin
@ -317,7 +263,7 @@ begin
CombineRgn(rgn, r1, r2, RGN_DIFF); CombineRgn(rgn, r1, r2, RGN_DIFF);
end; end;
SelectClipRgn(Canvas.Handle, rgn); SelectClipRgn(Canvas.Handle, rgn);
Canvas.Draw(0, 0, FBmp); Canvas.Draw(0, 0, FGradientBmp);
DeleteObject(rgn); DeleteObject(rgn);
DrawHueLine; DrawHueLine;
if FDoChange then if FDoChange then
@ -329,152 +275,157 @@ end;
procedure THRingPicker.SelectionChanged(x, y: integer); procedure THRingPicker.SelectionChanged(x, y: integer);
var var
Angle, Distance, xDelta, yDelta, Radius: integer; angle, Distance, xDelta, yDelta, Radius: integer;
begin begin
if not PointInCirc(Point(x, y), Min(Width, Height)) then if not PointInCircle(Point(x, y), Min(Width, Height)) then
begin begin
FChange := false; FChange := false;
SetSelectedColor(clNone); SetSelectedColor(clNone);
FChange := true; FChange := true;
Exit; Exit;
end end
else else
FSelectedColor := clWhite; FSelectedColor := clWhite;
Radius := Min(Width, Height) div 2; Radius := Min(Width, Height) div 2;
xDelta := x - Radius; xDelta := x - Radius;
yDelta := y - Radius; yDelta := y - Radius;
Angle := ROUND(360 + 180*ArcTan2(-yDelta,xDelta)/PI); angle := round(360 + 180*arctan2(-yDelta, xDelta) / pi);
if Angle < 0 then Inc(Angle, 360) if angle < 0 then
else if Angle > 360 then Inc(angle, 360)
Dec(Angle, 360); else if angle > 360 then
Fchange := false; Dec(angle, 360);
SetHue(Angle); FChange := false;
Distance := ROUND(SQRT(SQR(xDelta) + SQR(yDelta))); SetHue(angle);
if Distance >= Radius then SetSat(255) distance := round(sqrt(sqr(xDelta) + sqr(yDelta)));
else SetSat(MulDiv(Distance, 255, Radius)); if distance >= radius then
Fchange := true; SetSat(255)
else
SetSat(MulDiv(distance, 255, radius));
FChange := true;
end; end;
procedure THRingPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; procedure THRingPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); X, Y: Integer);
begin begin
inherited; inherited;
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(nil); ClipCursor(nil);
{$ENDIF} {$ENDIF}
if csDesigning in ComponentState then Exit; if csDesigning in ComponentState then Exit;
if (Button = mbLeft) and PointInCirc(Point(x, y), Min(Width, Height)) then if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then
begin begin
mdx := x; mdx := x;
mdy := y; mdy := y;
FDoChange := true; FDoChange := true;
SelectionChanged(X, Y); SelectionChanged(X, Y);
FManual := true; FManual := true;
end; end;
end; end;
procedure THRingPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; procedure THRingPicker.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); X, Y: Integer);
var var
R: TRect; R: TRect;
begin begin
inherited; inherited;
if csDesigning in ComponentState then Exit; if csDesigning in ComponentState then Exit;
if (Button = mbLeft) and PointInCirc(Point(x, y), Min(Width, Height)) then if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then
begin begin
mdx := x; mdx := x;
mdy := y; mdy := y;
R := ClientRect; R := ClientRect;
InflateRect(R, 1, 1); InflateRect(R, 1, 1);
R.TopLeft := ClientToScreen(R.TopLeft); R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight); R.BottomRight := ClientToScreen(R.BottomRight);
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(@R); ClipCursor(@R);
{$ENDIF} {$ENDIF}
FDoChange := true; FDoChange := true;
SelectionChanged(X, Y); SelectionChanged(X, Y);
FManual := true; FManual := true;
end; end;
SetFocus; SetFocus;
end; end;
procedure THRingPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure THRingPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
if csDesigning in ComponentState then Exit; if csDesigning in ComponentState then Exit;
if (ssLeft in Shift) and PointInCirc(Point(x, y), Min(Width, Height)) then if (ssLeft in Shift) and PointInCircle(Point(x, y), Min(Width, Height)) then
begin begin
mdx := x; mdx := x;
mdy := y; mdy := y;
FDoChange := true; FDoChange := true;
SelectionChanged(X, Y); SelectionChanged(X, Y);
FManual := true; FManual := true;
end; end;
end; end;
function THRingPicker.GetSelectedColor: TColor; function THRingPicker.GetSelectedColor: TColor;
begin begin
if FSelectedColor <> clNone then if FSelectedColor <> clNone then
begin begin
if not WebSafe then if not WebSafe then
Result := HSVtoColor(FHue, FSat, FValue) Result := HSVtoColor(FHue, FSat, FValue)
else else
Result := GetWebSafe(HSVtoColor(FHue, FSat, FValue)); Result := GetWebSafe(HSVtoColor(FHue, FSat, FValue));
end end
else else
Result := clNone; Result := clNone;
end; end;
function THRingPicker.GetColorAtPoint(x, y: integer): TColor; function THRingPicker.GetColorAtPoint(x, y: integer): TColor;
var var
Angle, Distance, xDelta, yDelta, Radius: integer; angle, distance, xDelta, yDelta, radius: integer;
h, s: integer; h, s: integer;
begin begin
Radius := Min(Width, Height) div 2; radius := Min(Width, Height) div 2;
xDelta := x - Radius; xDelta := x - Radius;
yDelta := y - Radius; yDelta := y - Radius;
Angle := ROUND(360 + 180*ArcTan2(-yDelta,xDelta)/PI); angle := round(360 + 180*arctan2(-yDelta, xDelta) / pi);
if Angle < 0 then Inc(Angle, 360) if angle < 0 then
else if Angle > 360 then Inc(angle, 360)
Dec(Angle, 360); else if angle > 360 then
h := Angle; Dec(angle, 360);
Distance := ROUND(SQRT(SQR(xDelta) + SQR(yDelta))); h := angle;
if Distance >= Radius then s := 255 distance := round(sqrt(sqr(xDelta) + sqr(yDelta)));
else s := MulDiv(Distance, 255, Radius); if distance >= radius then
if PointInCirc(Point(mx, my), Min(Width, Height)) then s := 255
else
s := MulDiv(distance, 255, radius);
if PointInCircle(Point(mx, my), Min(Width, Height)) then
begin begin
if not WebSafe then if not WebSafe then
Result := HSVtoColor(h, s, FValue) Result := HSVtoColor(h, s, FValue)
else else
Result := GetWebSafe(HSVtoColor(h, s, FValue)); Result := GetWebSafe(HSVtoColor(h, s, FValue));
end end
else else
Result := clNone; Result := clNone;
end; end;
procedure THRingPicker.SetSelectedColor(c: TColor); procedure THRingPicker.SetSelectedColor(c: TColor);
var var
changeSave: boolean; changeSave: boolean;
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
changeSave := FChange; changeSave := FChange;
FManual := false; FManual := false;
Fchange := false; Fchange := false;
SetValue(GetVValue(c)); SetValue(GetVValue(c));
SetHue(GetHValue(c)); SetHue(GetHValue(c));
SetSat(GetSValue(c)); SetSat(GetSValue(c));
FSelectedColor := c; FSelectedColor := c;
Fchange := changeSave; FChange := changeSave;
if Fchange then if FChange and Assigned(FOnChange) then FOnChange(Self);
if Assigned(FOnChange) then FOnChange(Self); FChange := true;
FChange := true;
end; end;
function THRingPicker.RadHue(New: integer): integer; function THRingPicker.RadHue(New: integer): integer;
begin begin
if New < 0 then New := New + 360; if New < 0 then New := New + 360;
if New > 360 then New := New - 360; if New > 360 then New := New - 360;
Result := New; Result := New;
end; end;
procedure THRingPicker.CNKeyDown( procedure THRingPicker.CNKeyDown(
@ -538,11 +489,4 @@ begin
OnKeyDown(Self, Message.CharCode, Shift); OnKeyDown(Self, Message.CharCode, Shift);
end; end;
procedure THRingPicker.WebSafeChanged;
begin
inherited;
CreateHSVCircle;
Invalidate;
end;
end. end.

360
components/mbColorLib/HSColorPicker.pas
View File

@ -7,58 +7,49 @@ unit HSColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Scanlines, Windows, Messages, Scanlines,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms, SysUtils, Classes, Controls, Graphics, Math, Forms,
RGBHSLUtils, HTMLColors, SelPropUtils, mbColorPickerControl; RGBHSLUtils, HTMLColors, mbColorPickerControl;
type type
THSColorPicker = class(TmbColorPickerControl)
private
FSelected: TColor;
FHSLBmp: TBitmap;
FOnChange: TNotifyEvent;
FHue, FSaturation, FLuminance: integer;
FLum: integer;
FManual: boolean;
dx, dy, mxx, myy: integer;
procedure SetHValue(h: integer); { THSColorPicker }
procedure SetSValue(s: integer);
protected
function GetSelectedColor: TColor; override;
procedure WebSafeChanged; override;
procedure SetSelectedColor(c: TColor); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
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 DrawMarker(x, y: integer);
procedure Paint; override;
procedure CreateHSLGradient;
procedure Resize; override;
procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer);
function PredictColor: TColor;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override; THSColorPicker = class(TmbColorPickerControl)
property Lum: integer read FLum write FLum default 120; private
property Manual: boolean read FManual; FHue, FSaturation, FLuminance: integer;
published FLum: integer;
property SelectedColor default clRed; dx, dy, mxx, myy: integer;
property HueValue: integer read FHue write SetHValue default 0; procedure SetHValue(h: integer);
property SaturationValue: integer read FSaturation write SetSValue default 240; procedure SetSValue(s: integer);
property MarkerStyle default msCross; protected
procedure CorrectCoords(var x, y: integer);
property OnChange: TNotifyEvent read FOnChange write FOnChange; function GetGradientColor2D(X, Y: Integer): TColor; override;
end; procedure SetSelectedColor(c: TColor); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
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 DrawMarker(x, y: integer);
procedure Paint; override;
procedure Resize; override;
procedure CreateWnd; override;
function PredictColor: TColor;
public
constructor Create(AOwner: TComponent); override;
property Lum: integer read FLum write FLum default 120;
published
property SelectedColor default clRed;
property HueValue: integer read FHue write SetHValue default 0;
property SaturationValue: integer read FSaturation write SetSValue default 240;
property MarkerStyle default msCross;
property OnChange;
end;
procedure Register; procedure Register;
@ -66,226 +57,155 @@ implementation
{$IFDEF FPC} {$IFDEF FPC}
{$R HSColorPicker.dcr} {$R HSColorPicker.dcr}
{$ENDIF}
uses uses
IntfGraphics, fpimage; mbUtils;
{$ENDIF}
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [THSColorPicker]); RegisterComponents('mbColor Lib', [THSColorPicker]);
end; end;
{THSColorPicker} {THSColorPicker}
constructor THSColorPicker.Create(AOwner: TComponent); constructor THSColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FHSLBmp := TBitmap.Create; FGradientWidth := 240;
FHSLBmp.PixelFormat := pf32bit; FGradientHeight := 241;
FHSLBmp.SetSize(240, 241); {$IFDEF DELPHI}
Width := 239; Width := 239;
Height := 240; Height := 240;
HintFormat := 'H: %h S: %hslS'#13'Hex: %hex'; {$ELSE}
FHue := 0; SetInitialBounds(0, 0, 239, 240);
FSaturation := 240; {$ENDIF}
FLuminance := 120; HintFormat := 'H: %h S: %hslS'#13'Hex: %hex';
FSelected := clRed; FHue := 0;
FLum := 120; FSaturation := 240;
FManual := false; FLuminance := 120;
dx := 0; FSelected := clRed;
dy := 0; FLum := 120;
mxx := 0; FManual := false;
myy := 0; dx := 0;
MarkerStyle := msCross; dy := 0;
end; mxx := 0;
myy := 0;
destructor THSColorPicker.Destroy; MarkerStyle := msCross;
begin
FHSLBmp.Free;
inherited Destroy;
end; end;
procedure THSColorPicker.CreateWnd; procedure THSColorPicker.CreateWnd;
begin begin
inherited; inherited;
CreateHSLGradient; CreateGradient;
end; end;
{$IFDEF DELPHI} function THSColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
procedure THSColorPicker.CreateHSLGradient;
var
Hue, Sat : integer;
row: pRGBQuadArray;
begin begin
if FHSLBmp = nil then Result := HSLRangeToRGB(x, FGradientBmp.Height - 1 - y, 120);
begin
FHSLBmp := TBitmap.Create;
FHSLBmp.PixelFormat := pf32bit;
FHSLBmp.Width := 240;
FHSLBmp.Height := 241;
end;
for Hue := 0 to 239 do
for Sat := 0 to 240 do
begin
row := FHSLBmp.ScanLine[240 - Sat];
if not WebSafe then
row[Hue] := RGBToRGBQuad(HSLRangeToRGB(Hue, Sat, 120))
// FHSLBmp.Canvas.Pixels[Hue, 240 - Sat] := HSLRangeToRGB(Hue, Sat, 120)
else
row[Hue] := RGBToRGBQuad(GetWebSafe(HSLRangeToRGB(Hue, Sat, 120)));
// FHSLBmp.Canvas.Pixels[Hue, 240 - Sat] := GetWebSafe(HSLRangeToRGB(Hue, Sat, 120));
end;
end; end;
{$ELSE}
procedure THSColorPicker.CreateHSLGradient;
var
Hue, Sat: Integer;
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
c: TColor;
begin
if FHSLBmp = nil then
begin
FHSLBmp := TBitmap.Create;
FHSLBmp.PixelFormat := pf32Bit;
FHSLBmp.Width := 240;
FHSLBmp.Height := 241;
end;
intfimg := TLazIntfImage.Create(FHSLBmp.Width, FHSLBmp.Height);
try
intfImg.LoadFromBitmap(FHSLBmp.Handle, FHSLBmp.MaskHandle);
for Hue := 0 to 239 do
for Sat := 0 to 240 do
begin
if not WebSafe then
c := HSLRangeToRGB(Hue, Sat, 120)
else
c := GetWebSafe(HSLRangeToRGB(Hue, Sat, 120));
intfimg.Colors[Hue, 240-Sat] := TColorToFPColor(c);
end;
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FHSLBmp.Handle := imgHandle;
FHSLBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
end;
{$ENDIF}
procedure THSColorPicker.CorrectCoords(var x, y: integer); procedure THSColorPicker.CorrectCoords(var x, y: integer);
begin begin
if x < 0 then x := 0; Clamp(x, 0, Width - 1);
if y < 0 then y := 0; Clamp(y, 0, Height - 1);
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
end; end;
procedure THSColorPicker.DrawMarker(x, y: integer); procedure THSColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
begin begin
CorrectCoords(x, y); CorrectCoords(x, y);
RGBtoHSLRange(FSelected, FHue, FSaturation, FLuminance); RGBtoHSLRange(FSelected, FHue, FSaturation, FLuminance);
if Assigned(FOnChange) then if Assigned(FOnChange) then
FOnChange(Self); FOnChange(Self);
dx := x; dx := x;
dy := y; dy := y;
if Focused or (csDesigning in ComponentState) then if Focused or (csDesigning in ComponentState) then
c := clBlack c := clBlack
else else
c := clWhite; c := clWhite;
case MarkerStyle of InternalDrawMarker(x, y, c);
msCircle: DrawSelCirc(x, y, Canvas);
msSquare: DrawSelSquare(x, y, Canvas);
msCross: DrawSelCross(x, y, Canvas, c);
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
end;
end;
function THSColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
end; end;
procedure THSColorPicker.SetSelectedColor(c: TColor); procedure THSColorPicker.SetSelectedColor(c: TColor);
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
RGBtoHSLRange(c, FHue, FSaturation, FLuminance); RGBtoHSLRange(c, FHue, FSaturation, FLuminance);
FSelected := c; FSelected := c;
FManual := false; FManual := false;
mxx := Round(FHue*(Width/239)); mxx := Round(FHue*(Width/239));
myy := Round((240-FSaturation)*(Height/240)); myy := Round((240-FSaturation)*(Height/240));
Invalidate; Invalidate;
end; end;
procedure THSColorPicker.Paint; procedure THSColorPicker.Paint;
begin begin
Canvas.StretchDraw(ClientRect, FHSLBmp); Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy); CorrectCoords(mxx, myy);
DrawMarker(mxx, myy); DrawMarker(mxx, myy);
end; end;
procedure THSColorPicker.Resize; procedure THSColorPicker.Resize;
begin begin
SetSelectedColor(FSelected); SetSelectedColor(FSelected);
inherited; inherited;
end; end;
procedure THSColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure THSColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var var
R: TRect; R: TRect;
begin begin
inherited; inherited;
mxx := x; mxx := x;
myy := y; myy := y;
if Button = mbLeft then if Button = mbLeft then
begin begin
R := ClientRect; R := ClientRect;
R.TopLeft := ClientToScreen(R.TopLeft); R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight); R.BottomRight := ClientToScreen(R.BottomRight);
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(@R); ClipCursor(@R);
{$ENDIF} {$ENDIF}
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
SetFocus; SetFocus;
end; end;
procedure THSColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure THSColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(nil); ClipCursor(nil);
{$ENDIF} {$ENDIF}
mxx := x; mxx := x;
myy := y; myy := y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
procedure THSColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure THSColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
if ssLeft in Shift then if ssLeft in Shift then
begin begin
mxx := x; mxx := x;
myy := y; myy := y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
end; end;
function THSColorPicker.PredictColor: TColor; function THSColorPicker.PredictColor: TColor;
var var
FTHue, FTSat, FTLum: integer; FTHue, FTSat, FTLum: integer;
begin begin
RGBtoHSLRange(GetColorUnderCursor, FTHue, FTSat, FTLum); RGBtoHSLRange(GetColorUnderCursor, FTHue, FTSat, FTLum);
Result := HSLRangeToRGB(FTHue, FTSat, FLum); Result := HSLRangeToRGB(FTHue, FTSat, FLum);
end; end;
procedure THSColorPicker.CNKeyDown( procedure THSColorPicker.CNKeyDown(
@ -387,30 +307,16 @@ end;
procedure THSColorPicker.SetHValue(h: integer); procedure THSColorPicker.SetHValue(h: integer);
begin begin
if h > 239 then h := 239; Clamp(h, 0, 239);
if h < 0 then h := 0; FHue := h;
FHue := h; SetSelectedColor(HSLRangeToRGB(FHue, FSaturation, 120)); // why hard-coded 120?
SetSelectedColor(HSLRangeToRGB(FHue, FSaturation, 120));
end; end;
procedure THSColorPicker.SetSValue(s: integer); procedure THSColorPicker.SetSValue(s: integer);
begin begin
if s > 240 then s := 240; Clamp(s, 0, 240);
if s < 0 then s := 0; FSaturation := s;
FSaturation := s; SetSelectedColor(HSLRangeToRGB(FHue, FSaturation, 120));
SetSelectedColor(HSLRangeToRGB(FHue, FSaturation, 120));
end;
function THSColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure THSColorPicker.WebSafeChanged;
begin
inherited;
CreateHSLGradient;
Invalidate;
end; end;
end. end.

283
components/mbColorLib/HSLRingPicker.pas
View File

@ -117,65 +117,77 @@ end;
constructor THSLRingPicker.Create(AOwner: TComponent); constructor THSLRingPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}]; ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}];
DoubleBuffered := true; DoubleBuffered := true;
PBack := TBitmap.Create; PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit; PBack.PixelFormat := pf32bit;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
ParentBackground := true; ParentBackground := true;
{$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF}
Width := 245; {$IFDEF DELPHI}
Height := 245; Width := 245;
TabStop := true; Height := 245;
FSelectedColor := clRed; {$ELSE}
FRingPicker := THRingPicker.Create(Self); SetInitialBounds(0, 0, 245, 245);
InsertControl(FRingPicker); {$ENDIF}
FRingCursor := crDefault; TabStop := true;
FSLCursor := crDefault; FSelectedColor := clRed;
with FRingPicker do FRingPicker := THRingPicker.Create(Self);
InsertControl(FRingPicker);
FRingCursor := crDefault;
FSLCursor := crDefault;
with FRingPicker do
begin begin
Height := 246; {$IFDEF DELPHI}
Width := 246; Left := 0;
Top := 0; Top := 0;
Left := 0; Width := 246;
Radius := 100; Height := 246;
Align := alClient; {$ELSE}
Visible := true; SetInitialBounds(0, 0, 246, 246);
Saturation := 255; {$ENDIF}
Value := 255; Radius := 100;
Hue := 0; Align := alClient;
OnChange := RingPickerChange; Visible := true;
OnMouseMove := DoMouseMove; Saturation := 255;
Value := 255;
Hue := 0;
OnChange := RingPickerChange;
OnMouseMove := DoMouseMove;
end; end;
FSLPicker := TSLColorPicker.Create(Self); FSLPicker := TSLColorPicker.Create(Self);
InsertControl(FSLPicker); InsertControl(FSLPicker);
with FSLPicker do with FSLPicker do
begin begin
Height := 120; {$IFDEF DELPHI}
Width := 120; Left := 63;
Left := 63; Top := 63;
Top := 63; Width := 120;
Visible := true; Height := 120;
OnChange := SLPickerChange; {$ELSE}
OnMouseMove := DoMouseMove; SetInitialBounds(63, 63, 120, 120);
{$ENDIF}
Visible := true;
OnChange := SLPickerChange;
OnMouseMove := DoMouseMove;
end; end;
FHValue := 0; FHValue := 0;
FSValue := 255; FSValue := 255;
FLValue := 255; FLValue := 255;
FRValue := 255; FRValue := 255;
FGValue := 0; FGValue := 0;
FBValue := 0; FBValue := 0;
FRingHint := 'Hue: %h'; FRingHint := 'Hue: %h';
FSLHint := 'S: %hslS L: %l'#13'Hex: %hex'; FSLHint := 'S: %hslS L: %l'#13'Hex: %hex';
end; end;
destructor THSLRingPicker.Destroy; destructor THSLRingPicker.Destroy;
begin begin
PBack.Free; PBack.Free;
FRingPicker.Free; FRingPicker.Free;
FSLPicker.Free; FSLPicker.Free;
inherited Destroy; inherited Destroy;
end; end;
procedure THSLRingPicker.Resize; procedure THSLRingPicker.Resize;
@ -183,198 +195,191 @@ var
circ: TPoint; circ: TPoint;
ctr: double; ctr: double;
begin begin
inherited; inherited;
if (FRingPicker = nil) or (FSLPicker = nil) then if (FRingPicker = nil) or (FSLPicker = nil) then
exit; exit;
ctr := Min(Width, Height)/100; ctr := Min(Width, Height)/100;
circ.x := Min(Width, Height) div 2;
circ.y := circ.x;
circ.x := Min(Width, Height) div 2; FRingPicker.Radius := circ.x - round(12*ctr);
circ.y := circ.x;
FRingPicker.Radius := circ.x - round(12*ctr); FSLPicker.Left := circ.x - FSLPicker.Width div 2;
FSLPicker.Top := circ.y - FSLPicker.Height div 2;
FSLPicker.Width := round(50 * ctr);
FSLPicker.Height := FSLPicker.Width;
FSLPicker.Left := circ.x - FSLPicker.Width div 2; PaintParentBack(PBack);
FSLPicker.Top := circ.y - FSLPicker.Height div 2;
FSLPicker.Width := round(50*ctr);
FSLPicker.Height := FSLPicker.Width;
(*
FRingPicker.Radius := (Min(Width, Height)*30) div 245;
FSLPicker.Left := (21*FRingPicker.Radius) div 10;
FSLPicker.Top := (21*FRingPicker.Radius) div 10;
FSLPicker.Width := 4*FRingPicker.Radius;
FSLPicker.Height := 4*FRingPicker.Radius;
*)
PaintParentBack(PBack);
end; end;
procedure THSLRingPicker.RingPickerChange(Sender: TObject); procedure THSLRingPicker.RingPickerChange(Sender: TObject);
begin begin
if (FRingPicker = nil) or (FSLPicker = nil) then if (FRingPicker = nil) or (FSLPicker = nil) then
exit; exit;
FSLPicker.Hue := FRingPicker.Hue; FSLPicker.Hue := FRingPicker.Hue;
DoChange; DoChange;
end; end;
procedure THSLRingPicker.SLPickerChange(Sender: TObject); procedure THSLRingPicker.SLPickerChange(Sender: TObject);
begin begin
if FSLPicker = nil then if FSLPicker = nil then
exit; exit;
FSelectedColor := FSLPicker.SelectedColor; FSelectedColor := FSLPicker.SelectedColor;
DoChange; DoChange;
end; end;
procedure THSLRingPicker.DoChange; procedure THSLRingPicker.DoChange;
begin begin
if (FRingPicker = nil) or (FSLPicker = nil) then if (FRingPicker = nil) or (FSLPicker = nil) then
exit; exit;
FHValue := FRingPicker.Hue; FHValue := FRingPicker.Hue;
FSValue := FSLPicker.Saturation; FSValue := FSLPicker.Saturation;
FLValue := FSLPicker.Luminance; FLValue := FSLPicker.Luminance;
FRValue := GetRValue(FSLPicker.SelectedColor); FRValue := GetRValue(FSLPicker.SelectedColor);
FGValue := GetGValue(FSLPicker.SelectedColor); FGValue := GetGValue(FSLPicker.SelectedColor);
FBValue := GetBValue(FSLPicker.SelectedColor); FBValue := GetBValue(FSLPicker.SelectedColor);
if Assigned(FOnChange) then if Assigned(FOnChange) then
FOnChange(Self); FOnChange(Self);
end; end;
procedure THSLRingPicker.SelectColor(c: TColor); procedure THSLRingPicker.SelectColor(c: TColor);
begin begin
if (FRingPicker = nil) or (FSLPicker = nil) then if (FRingPicker = nil) or (FSLPicker = nil) then
exit; exit;
FRingPicker.Hue := GetHValue(c); FRingPicker.Hue := GetHValue(c);
FRingPicker.Saturation := 255; FRingPicker.Saturation := 255;
FRingPicker.Value := 255; FRingPicker.Value := 255;
FSLPicker.SelectedColor := c; FSLPicker.SelectedColor := c;
FSelectedColor := c; FSelectedColor := c;
end; end;
procedure THSLRingPicker.SetH(v: integer); procedure THSLRingPicker.SetH(v: integer);
begin begin
if (FRingPicker = nil) or (FSLPicker = nil) then if (FRingPicker = nil) or (FSLPicker = nil) then
exit; exit;
FHValue := v; FHValue := v;
FRingPicker.Hue := v; FRingPicker.Hue := v;
FSLPicker.Hue := v; FSLPicker.Hue := v;
end; end;
procedure THSLRingPicker.SetS(v: integer); procedure THSLRingPicker.SetS(v: integer);
begin begin
if (FSLPicker = nil) then if (FSLPicker = nil) then
exit; exit;
FSValue := v; FSValue := v;
FSLPicker.Saturation := v; FSLPicker.Saturation := v;
end; end;
procedure THSLRingPicker.SetL(v: integer); procedure THSLRingPicker.SetL(v: integer);
begin begin
if (FSLPicker = nil) then if (FSLPicker = nil) then
exit; exit;
FLValue := v; FLValue := v;
FSLPicker.Luminance := v; FSLPicker.Luminance := v;
end; end;
procedure THSLRingPicker.SetR(v: integer); procedure THSLRingPicker.SetR(v: integer);
begin begin
FRValue := v; FRValue := v;
SelectColor(RGB(FRValue, FGValue, FBValue)); SelectColor(RGB(FRValue, FGValue, FBValue));
end; end;
procedure THSLRingPicker.SetG(v: integer); procedure THSLRingPicker.SetG(v: integer);
begin begin
FGValue := v; FGValue := v;
SelectColor(RGB(FRValue, FGValue, FBValue)); SelectColor(RGB(FRValue, FGValue, FBValue));
end; end;
procedure THSLRingPicker.SetB(v: integer); procedure THSLRingPicker.SetB(v: integer);
begin begin
FBValue := v; FBValue := v;
SelectColor(RGB(FRValue, FGValue, FBValue)); SelectColor(RGB(FRValue, FGValue, FBValue));
end; end;
function THSLRingPicker.GetSelectedHexColor: string; function THSLRingPicker.GetSelectedHexColor: string;
begin begin
Result := ColorToHex(FSelectedColor); Result := ColorToHex(FSelectedColor);
end; end;
procedure THSLRingPicker.SetRingHint(h: string); procedure THSLRingPicker.SetRingHint(h: string);
begin begin
FRingHint := h; FRingHint := h;
FRingPicker.HintFormat := h; FRingPicker.HintFormat := h;
end; end;
procedure THSLRingPicker.SetSLHint(h: string); procedure THSLRingPicker.SetSLHint(h: string);
begin begin
FSLHint := h; FSLHint := h;
FSLPicker.HintFormat := h; FSLPicker.HintFormat := h;
end; end;
procedure THSLRingPicker.SetRingMenu(m: TPopupMenu); procedure THSLRingPicker.SetRingMenu(m: TPopupMenu);
begin begin
FRingMenu := m; FRingMenu := m;
FRingPicker.PopupMenu := m; FRingPicker.PopupMenu := m;
end; end;
procedure THSLRingPicker.SetSLMenu(m: TPopupMenu); procedure THSLRingPicker.SetSLMenu(m: TPopupMenu);
begin begin
FSLMenu := m; FSLMenu := m;
FSLPicker.PopupMenu := m; FSLPicker.PopupMenu := m;
end; end;
procedure THSLRingPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure THSLRingPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin begin
if Assigned(OnMouseMove) then if Assigned(OnMouseMove) then
OnMouseMove(Self, Shift, x, y); OnMouseMove(Self, Shift, x, y);
inherited; inherited;
end; end;
function THSLRingPicker.GetColorUnderCursor: TColor; function THSLRingPicker.GetColorUnderCursor: TColor;
begin begin
Result := FSLPicker.GetColorUnderCursor; Result := FSLPicker.GetColorUnderCursor;
end; end;
function THSLRingPicker.GetHexColorUnderCursor: string; function THSLRingPicker.GetHexColorUnderCursor: string;
begin begin
Result := FSLPicker.GetHexColorUnderCursor; Result := FSLPicker.GetHexColorUnderCursor;
end; end;
procedure THSLRingPicker.SetRingCursor(c: TCursor); procedure THSLRingPicker.SetRingCursor(c: TCursor);
begin begin
FRingCursor := c; FRingCursor := c;
FRingPicker.Cursor := c; FRingPicker.Cursor := c;
end; end;
procedure THSLRingPicker.SetSLCursor(c: TCursor); procedure THSLRingPicker.SetSLCursor(c: TCursor);
begin begin
FSLCursor := c; FSLCursor := c;
FSLPicker.Cursor := c; FSLPicker.Cursor := c;
end; end;
procedure THSLRingPicker.WMSetFocus( procedure THSLRingPicker.WMSetFocus(
var Message: {$IFDEF DELPHI}TWMSetFocus{$ELSE}TLMSetFocus{$ENDIF} ); var Message: {$IFDEF DELPHI}TWMSetFocus{$ELSE}TLMSetFocus{$ENDIF} );
begin begin
FRingPicker.SetFocus; FRingPicker.SetFocus;
Message.Result := 1; Message.Result := 1;
end; end;
function THSLRingPicker.GetManual:boolean; function THSLRingPicker.GetManual:boolean;
begin begin
Result := FRingPicker.Manual or FSLPicker.Manual; Result := FRingPicker.Manual or FSLPicker.Manual;
end; end;
procedure THSLRingPicker.Paint; procedure THSLRingPicker.Paint;
begin begin
PaintParentBack(PBack); PaintParentBack(PBack);
Canvas.Draw(0, 0, PBack); Canvas.Draw(0, 0, PBack);
end; end;
procedure THSLRingPicker.CreateWnd; procedure THSLRingPicker.CreateWnd;
begin begin
inherited; inherited;
PaintParentBack(PBack); PaintParentBack(PBack);
end; end;
end. end.

689
components/mbColorLib/HSVColorPicker.pas
View File

@ -13,70 +13,62 @@ uses
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, RGBHSVUtils, Scanlines, SysUtils, Classes, Controls, Graphics, Math, RGBHSVUtils, Scanlines,
Forms, {IFDEF DELPHI_7_UP Themes, $ENDIF} HTMLColors, SelPropUtils, Forms, {$IFDEF DELPHI_7_UP}Themes,{$ENDIF}
mbColorPickerControl; HTMLColors, mbColorPickerControl;
type type
THSVColorPicker = class(TmbColorPickerControl) THSVColorPicker = class(TmbColorPickerControl)
private private
FHue, FSat, FValue: integer; FHue, FSat, FValue: integer;
FSatCircColor, FHueLineColor: TColor; FSatCircColor, FHueLineColor: TColor;
FSelectedColor: TColor; FSelectedColor: TColor;
FOnChange: TNotifyEvent; FShowSatCirc: boolean;
FManual: boolean; FShowHueLine: boolean;
FShowSatCirc: boolean; FShowSelCirc: boolean;
FShowHueLine: boolean; FChange: boolean;
FShowSelCirc: boolean; FDoChange: boolean;
Fchange: boolean; function RadHue(New: integer): integer;
FHSVBmp: TBitmap; procedure SetValue(V: integer);
FDoChange: boolean; procedure SetHue(h: integer);
procedure SetSat(s: integer);
procedure CreateHSVCircle; procedure SetSatCircColor(c: TColor);
function RadHue(New: integer): integer; procedure SetHueLineColor(c: TColor);
procedure SetValue(V: integer); procedure DrawSatCirc;
procedure SetHue(h: integer); procedure DrawHueLine;
procedure SetSat(s: integer); procedure DrawMarker(x, y: integer);
procedure SetSatCircColor(c: TColor); procedure SelectionChanged(x, y: integer);
procedure SetHueLineColor(c: TColor); procedure SetShowSatCirc(s: boolean);
procedure DrawSatCirc; procedure SetShowSelCirc(s: boolean);
procedure DrawHueLine; procedure SetShowHueLine(s: boolean);
procedure DrawMarker(x, y: integer); procedure UpdateCoords;
procedure SelectionChanged(x, y: integer);
procedure SetShowSatCirc(s: boolean);
procedure SetShowSelCirc(s: boolean);
procedure SetShowHueLine(s: boolean);
procedure UpdateCoords;
protected protected
function GetSelectedColor: TColor; override; procedure CreateGradient; override;
procedure SetSelectedColor(c: TColor); override; function GetGradientColor2D(X, Y: Integer): TColor; override;
procedure WebSafeChanged; override; function GetSelectedColor: TColor; override;
procedure Paint; override; procedure SetSelectedColor(c: TColor); override;
procedure Resize; override; procedure Paint; override;
procedure CreateWnd; override; procedure Resize; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure CreateWnd; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
message CN_KEYDOWN; procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; function GetColorAtPoint(x, y: integer): TColor; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published published
property Hue: integer read FHue write SetHue default 0; property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 0; property Saturation: integer read FSat write SetSat default 0;
property Value: integer read FValue write SetValue default 255; property Value: integer read FValue write SetValue default 255;
property SaturationCircleColor: TColor read FSatCircColor write SetSatCircColor default clSilver; property SaturationCircleColor: TColor read FSatCircColor write SetSatCircColor default clSilver;
property HueLineColor: TColor read FHueLineColor write SetHueLineColor default clGray; property HueLineColor: TColor read FHueLineColor write SetHueLineColor default clGray;
property SelectedColor default clNone; property SelectedColor default clNone;
property ShowSaturationCircle: boolean read FShowSatCirc write SetShowSatCirc default true; property ShowSaturationCircle: boolean read FShowSatCirc write SetShowSatCirc default true;
property ShowHueLine: boolean read FShowHueLine write SetShowHueLine default true; property ShowHueLine: boolean read FShowHueLine write SetShowHueLine default true;
property ShowSelectionCircle: boolean read FShowSelCirc write SetShowSelCirc default true; property ShowSelectionCircle: boolean read FShowSelCirc write SetShowSelCirc default true;
property MarkerStyle default msCrossCirc; property MarkerStyle default msCrossCirc;
property OnChange;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end; end;
procedure Register; procedure Register;
@ -85,469 +77,423 @@ implementation
{$IFDEF FPC} {$IFDEF FPC}
{$R HSVColorPicker.dcr} {$R HSVColorPicker.dcr}
{$ENDIF}
uses uses
IntfGraphics, fpimage; mbUtils;
{$ENDIF}
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [THSVColorPicker]); RegisterComponents('mbColor Lib', [THSVColorPicker]);
end; end;
function PointInCirc(p: TPoint; size : integer): boolean;
var { THSVColorPicker }
r: integer;
begin
r := size div 2;
Result := (SQR(p.x - r) + SQR(p.y - r) <= SQR(r));
end;
constructor THSVColorPicker.Create(AOwner: TComponent); constructor THSVColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FHSVBmp := TBitmap.Create; {$IFDEF DELPHI}
FHSVBmp.PixelFormat := pf32bit; Width := 204;
Width := 204; Height := 204;
Height := 204; {$ELSE}
FValue := 255; SetInitialBounds(0, 0, 204, 204);
FHue := 0; {$ENDIF}
FSat := 0; FValue := 255;
FSatCircColor := clSilver; FHue := 0;
FHueLineColor := clGray; FSat := 0;
FSelectedColor := clNone; FSatCircColor := clSilver;
FManual := false; FHueLineColor := clGray;
FShowSatCirc := true; FSelectedColor := clNone;
FShowHueLine := true; FManual := false;
FShowSelCirc := true; FShowSatCirc := true;
Fchange := true; FShowHueLine := true;
FDoChange := false; FShowSelCirc := true;
MarkerStyle := msCrossCirc; FChange := true;
end; FDoChange := false;
MarkerStyle := msCrossCirc;
destructor THSVColorPicker.Destroy;
begin
FHSVBmp.Free;
inherited;
end; end;
procedure THSVColorPicker.Paint; procedure THSVColorPicker.Paint;
var var
rgn: HRGN; rgn: HRGN;
R: TRect; R: TRect;
begin begin
PaintParentBack(Canvas); PaintParentBack(Canvas);
R := ClientRect; R := ClientRect;
R.Right := R.Left + Min(Width, Height); R.Right := R.Left + Min(Width, Height);
R.Bottom := R.Top + Min(Width, Height); R.Bottom := R.Top + Min(Width, Height);
rgn := CreateEllipticRgnIndirect(R); InflateRect(R, -1, -1); // Avoid spurious black pixels at the border
SelectClipRgn(Canvas.Handle, rgn); rgn := CreateEllipticRgnIndirect(R);
Canvas.Draw(0, 0, FHSVBmp); SelectClipRgn(Canvas.Handle, rgn);
DeleteObject(rgn); Canvas.Draw(0, 0, FGradientBmp);
DrawSatCirc; DeleteObject(rgn);
DrawHueLine; DrawSatCirc;
DrawMarker(mdx, mdy); DrawHueLine;
if FDoChange then DrawMarker(mdx, mdy);
if FDoChange then
begin begin
if Assigned(FOnChange) then FOnChange(Self); if Assigned(FOnChange) then FOnChange(Self);
FDoChange := false; FDoChange := false;
end; end;
end; end;
procedure THSVColorPicker.CreateHSVCircle; procedure THSVColorPicker.CreateGradient;
var
dSquared, H, S, V, i, j, radius, radiusSquared, x, y, size: integer;
row: pRGBQuadArray;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin begin
if FHSVBmp = nil then FGradientWidth := Min(Width, Height);
begin FGradientHeight := FGradientWidth;
FHSVBmp := TBitmap.Create; inherited;
FHSVBmp.PixelFormat := pf32bit; end;
end;
size := Min(Width, Height);
FHSVBmp.Width := size;
FHSVBmp.Height := size;
PaintParentBack(FHSVBmp.Canvas);
{ Outer loop: Y, Inner loop: X }
function THSVColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
var
xcoord, ycoord: Integer;
dSq, radiusSq: Integer;
radius, size: Integer;
S, H, V: Integer;
q: TRGBQuad;
begin
size := FGradientWidth; // or Height, they are the same...
radius := size div 2; radius := size div 2;
radiusSquared := radius * radius; radiusSq := sqr(radius);
V := FValue; xcoord := X - radius;
ycoord := Y - radius;
{$IFDEF FPC} dSq := sqr(xcoord) + sqr(ycoord);
intfimg := TLazIntfImage.Create(FHSVBmp.Width, FHSVBmp.Height); if dSq <= radiusSq then
try begin
intfImg.LoadFromBitmap(FHSVBmp.Handle, FHSVBmp.MaskHandle); if radius <> 0 then
{$ENDIF} S := round((255 * sqrt(dSq)) / radius)
//S := trunc((255 * sqrt(dSq)) / radius)
for j := 0 to size - 1 do else
begin S := 0;
Y := size - 1 - j - Radius; H := round( 180 * (1 + arctan2(xcoord, ycoord) / pi)); // wp: order (x,y) is correct!
{$IFDEF FPC} H := H + 90;
row := intfImg.GetDataLineStart(size - 1 - j); if H > 360 then H := H - 360;
{$ELSE} Result := HSVtoColor(H, S, FValue);
row := FHSVBmp.Scanline(size - 1 - j); if WebSafe then
{$ENDIF} Result := GetWebSafe(Result);
for i := 0 to size - 1 do end else
begin Result := GetDefaultColor(dctBrush);
X := i - Radius;
dSquared := X*X + Y*Y;
if dSquared <= RadiusSquared then
begin
if Radius <> 0 then
S := round(255.0 * sqrt(dSquared) / radius)
else
S := 0;
H := round(180 * (1 + arctan2(X, Y) / pi)); // wp: order (x,y) is correct!
H := H + 90;
if H > 360 then H := H - 360;
{$IFDEF FPC}
c := HSVtoColor(H, S, V);
if WebSafe then
c := GetWebSafe(c);
row^[i].rgbRed := GetRValue(c);
row^[i].rgbGreen := GetGValue(c);
row^[i].rgbBlue := GetBValue(c);
{$ELSE}
if not WebSafe then
row[i] := HSVtoRGBQuad(H,S,V)
else
begin
c := GetWebSafe(HSVtoColor(H, S, V));
row[i] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
end;
{$ENDIF}
end;
end;
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FHSVBmp.Handle := imgHandle;
FHSVBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
{$ENDIF}
end; end;
procedure THSVColorPicker.Resize; procedure THSVColorPicker.Resize;
begin begin
inherited; inherited;
CreateHSVCircle; CreateGradient;
UpdateCoords; UpdateCoords;
end; end;
procedure THSVColorPicker.CreateWnd; procedure THSVColorPicker.CreateWnd;
begin begin
inherited; inherited;
CreateHSVCircle; CreateGradient;
UpdateCoords; UpdateCoords;
end; end;
procedure THSVColorPicker.UpdateCoords; procedure THSVColorPicker.UpdateCoords;
var var
r, angle: real; r, angle: double;
radius: integer; sinAngle, cosAngle: Double;
radius: integer;
begin begin
radius := Min(Width, Height) div 2; radius := Min(Width, Height) div 2;
r := -MulDiv(radius, FSat, 255); r := -MulDiv(radius, FSat, 255);
angle := -FHue*PI/180 - PI; angle := -FHue* pi / 180 - PI;
mdx := ROUND(COS(angle)*ROUND(r)) + radius; SinCos(angle, sinAngle, cosAngle);
mdy := ROUND(SIN(angle)*ROUND(r)) + radius; mdx := round(cosAngle * r) + radius;
mdy := round(sinAngle * r) + radius;
end; end;
procedure THSVColorPicker.SetHue(h: integer); procedure THSVColorPicker.SetHue(h: integer);
begin begin
if h > 360 then h := 360; Clamp(h, 0, 360);
if h < 0 then h := 0; if FHue <> h then
if FHue <> h then
begin begin
FHue := h; FHue := h;
FManual := false; FManual := false;
UpdateCoords; UpdateCoords;
Invalidate; Invalidate;
if Fchange then if FChange and Assigned(FOnChange) then FOnChange(Self);
if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure THSVColorPicker.SetSat(s: integer); procedure THSVColorPicker.SetSat(s: integer);
begin begin
if s > 255 then s := 255; Clamp(s, 0, 255);
if s < 0 then s := 0; if FSat <> s then
if FSat <> s then
begin begin
FSat := s; FSat := s;
FManual := false; FManual := false;
UpdateCoords; UpdateCoords;
Invalidate; Invalidate;
if Fchange then if FChange and Assigned(FOnChange) then FOnChange(Self);
if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure THSVColorPicker.SetValue(V: integer); procedure THSVColorPicker.SetValue(V: integer);
begin begin
if V > 255 then V := 255; Clamp(V, 0, 255);
if V < 0 then V := 0; if FValue <> V then
if FValue <> V then
begin begin
FValue := V; FValue := V;
FManual := false; FManual := false;
CreateHSVCircle; CreateGradient;
Invalidate; Invalidate;
if Fchange then if FChange and Assigned(FOnChange) then FOnChange(Self);
if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure THSVColorPicker.SetSatCircColor(c: TColor); procedure THSVColorPicker.SetSatCircColor(c: TColor);
begin begin
if FSatCircColor <> c then if FSatCircColor <> c then
begin begin
FSatCircColor := c; FSatCircColor := c;
Invalidate; Invalidate;
end; end;
end; end;
procedure THSVColorPicker.SetHueLineColor(c: TColor); procedure THSVColorPicker.SetHueLineColor(c: TColor);
begin begin
if FHueLineColor <> c then if FHueLineColor <> c then
begin begin
FHueLineColor := c; FHueLineColor := c;
Invalidate; Invalidate;
end; end;
end; end;
procedure THSVColorPicker.SetShowSatCirc(s: boolean); procedure THSVColorPicker.SetShowSatCirc(s: boolean);
begin begin
if FShowSatCirc <> s then if FShowSatCirc <> s then
begin begin
FShowSatCirc := s; FShowSatCirc := s;
Invalidate; Invalidate;
end; end;
end; end;
procedure THSVColorPicker.SetShowSelCirc(s: boolean); procedure THSVColorPicker.SetShowSelCirc(s: boolean);
begin begin
if FShowSelCirc <> s then if FShowSelCirc <> s then
begin begin
FShowSelCirc := s; FShowSelCirc := s;
Invalidate; Invalidate;
end; end;
end; end;
procedure THSVColorPicker.SetShowHueLine(s: boolean); procedure THSVColorPicker.SetShowHueLine(s: boolean);
begin begin
if FShowHueLine <> s then if FShowHueLine <> s then
begin begin
FShowHueLine := s; FShowHueLine := s;
Invalidate; Invalidate;
end; end;
end; end;
procedure THSVColorPicker.DrawSatCirc; procedure THSVColorPicker.DrawSatCirc;
var var
delta: integer; delta: integer;
Radius: integer; radius: integer;
begin begin
if not FShowSatCirc then Exit; if not FShowSatCirc then
if FSat in [1..254] then exit;
if (FSat > 0) and (FSat < 255) then
begin begin
Radius:= Min(Width, Height) div 2; radius := Min(Width, Height) div 2;
Canvas.Pen.Color := FSatCircColor; Canvas.Pen.Color := FSatCircColor;
Canvas.Brush.Style := bsClear; Canvas.Brush.Style := bsClear;
delta := MulDiv(Radius, FSat, 255); delta := MulDiv(radius, FSat, 255);
Canvas.Ellipse(Radius - delta, Radius - delta, Radius + delta, Radius + delta); Canvas.Ellipse(radius - delta, radius - delta, radius + delta, radius + delta);
end; end;
end; end;
procedure THSVColorPicker.DrawHueLine; procedure THSVColorPicker.DrawHueLine;
var var
angle: double; angle: double;
radius: integer; sinAngle, cosAngle: Double;
radius: integer;
begin begin
if not FShowHueLine then Exit; if not FShowHueLine then
Radius := Min(Width, Height) div 2; exit;
if (FHue >= 0) and (FHue <= 360) then radius := Min(Width, Height) div 2;
if (FHue >= 0) and (FHue <= 360) then
begin begin
Angle := -FHue*PI/180; angle := -FHue * pi / 180;
Canvas.Pen.Color := FHueLineColor; SinCos(angle, sinAngle, cosAngle);
Canvas.MoveTo(Radius,Radius); Canvas.Pen.Color := FHueLineColor;
Canvas.LineTo(Radius + Round(Radius*COS(angle)), Radius + Round(Radius*SIN(angle))); Canvas.MoveTo(radius, radius);
Canvas.LineTo(radius + round(radius*cosAngle), radius + round(radius*sinAngle));
end; end;
end; end;
procedure THSVColorPicker.DrawMarker(x, y: integer); procedure THSVColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
begin begin
if not FShowSelCirc then Exit; if not FShowSelCirc then
if Focused or (csDesigning in ComponentState) then exit;
c := clBlack if Focused or (csDesigning in ComponentState) then
else c := clBlack
c := clGray; else
case MarkerStyle of c := clGray;
msCircle: DrawSelCirc(x, y, Canvas); InternalDrawMarker(x, y, c);
msSquare: DrawSelSquare(x, y, Canvas);
msCross: DrawSelCross(x, y, Canvas, c);
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
end;
end; end;
procedure THSVColorPicker.SelectionChanged(x, y: integer); procedure THSVColorPicker.SelectionChanged(x, y: integer);
var var
Angle, Distance, xDelta, yDelta, Radius: integer; angle, distance, xDelta, yDelta, radius: integer;
begin begin
if not PointInCirc(Point(x, y), Min(Width, Height)) then if not PointInCircle(Point(x, y), Min(Width, Height)) then
begin begin
FChange := false; FChange := false;
SetSelectedColor(clNone); SetSelectedColor(clNone);
FChange := true; FChange := true;
Exit; exit;
end end
else else
FSelectedColor := clWhite; FSelectedColor := clWhite;
Radius := Min(Width, Height) div 2; radius := Min(Width, Height) div 2;
xDelta := x - Radius; xDelta := x - radius;
yDelta := y - Radius; yDelta := y - radius;
Angle := ROUND(360 + 180*ArcTan2(-yDelta,xDelta)/PI); angle := round(360 + 180*arctan2(-yDelta, xDelta) / pi);
if Angle < 0 then Inc(Angle, 360) if angle < 0 then
else if Angle > 360 then inc(angle, 360)
Dec(Angle, 360); else if angle > 360 then
Fchange := false; dec(angle, 360);
SetHue(Angle); FChange := false;
Distance := ROUND(SQRT(SQR(xDelta) + SQR(yDelta))); SetHue(Angle);
if Distance >= Radius then SetSat(255) distance := round(sqrt(sqr(xDelta) + sqr(yDelta)));
else SetSat(MulDiv(Distance, 255, Radius)); if distance >= radius then
Fchange := true; SetSat(255)
else
SetSat(MulDiv(distance, 255, radius));
FChange := true;
end; end;
procedure THSVColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; procedure THSVColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); X, Y: Integer);
begin begin
inherited; inherited;
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(nil); ClipCursor(nil);
{$ENDIF} {$ENDIF}
if csDesigning in ComponentState then Exit; if csDesigning in ComponentState then
if (Button = mbLeft) and PointInCirc(Point(x, y), Min(Width, Height)) then exit;
if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then
begin begin
mdx := x; mdx := x;
mdy := y; mdy := y;
FDoChange := true; FDoChange := true;
SelectionChanged(X, Y); SelectionChanged(X, Y);
FManual := true; FManual := true;
end; end;
end; end;
procedure THSVColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; procedure THSVColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); X, Y: Integer);
var var
R: TRect; R: TRect;
begin begin
inherited; inherited;
if csDesigning in ComponentState then Exit; if csDesigning in ComponentState then
if (Button = mbLeft) and PointInCirc(Point(x, y), Min(Width, Height)) then exit;
if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then
begin begin
mdx := x; mdx := x;
mdy := y; mdy := y;
R := ClientRect; R := ClientRect;
InflateRect(R, 1, 1); InflateRect(R, 1, 1);
R.TopLeft := ClientToScreen(R.TopLeft); R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight); R.BottomRight := ClientToScreen(R.BottomRight);
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(@R); ClipCursor(@R);
{$ENDIF} {$ENDIF}
FDoChange := true; FDoChange := true;
SelectionChanged(X, Y); SelectionChanged(X, Y);
FManual := true; FManual := true;
end; end;
SetFocus; SetFocus;
end; end;
procedure THSVColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure THSVColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
if csDesigning in ComponentState then Exit; if csDesigning in ComponentState then
if (ssLeft in Shift) and PointInCirc(Point(x, y), Min(Width, Height)) then exit;
if (ssLeft in Shift) and PointInCircle(Point(x, y), Min(Width, Height)) then
begin begin
mdx := x; mdx := x;
mdy := y; mdy := y;
FDoChange := true; FDoChange := true;
SelectionChanged(X, Y); SelectionChanged(X, Y);
FManual := true; FManual := true;
end; end;
end; end;
function THSVColorPicker.GetSelectedColor: TColor; function THSVColorPicker.GetSelectedColor: TColor;
begin begin
if FSelectedColor <> clNone then if FSelectedColor <> clNone then
begin begin
if not WebSafe then if not WebSafe then
Result := HSVtoColor(FHue, FSat, FValue) Result := HSVtoColor(FHue, FSat, FValue)
else else
Result := GetWebSafe(HSVtoColor(FHue, FSat, FValue)); Result := GetWebSafe(HSVtoColor(FHue, FSat, FValue));
end end
else else
Result := clNone; Result := clNone;
end; end;
function THSVColorPicker.GetColorAtPoint(x, y: integer): TColor; function THSVColorPicker.GetColorAtPoint(x, y: integer): TColor;
var var
Angle, Distance, xDelta, yDelta, Radius: integer; angle, distance, xDelta, yDelta, radius: integer;
h, s: integer; h, s: integer;
begin begin
Radius := Min(Width, Height) div 2; radius := Min(Width, Height) div 2;
xDelta := x - Radius; xDelta := x - Radius;
yDelta := y - Radius; yDelta := y - Radius;
Angle := ROUND(360 + 180*ArcTan2(-yDelta,xDelta)/PI); angle := round(360 + 180*arctan2(-yDelta, xDelta) / pi);
if Angle < 0 then Inc(Angle, 360) if angle < 0 then
else if Angle > 360 then inc(angle, 360)
Dec(Angle, 360); else if angle > 360 then
h := Angle; dec(angle, 360);
Distance := ROUND(SQRT(SQR(xDelta) + SQR(yDelta))); h := angle;
if Distance >= Radius then s := 255 distance := round(sqrt(sqr(xDelta) + sqr(yDelta)));
else s := MulDiv(Distance, 255, Radius); if distance >= radius then
if PointInCirc(Point(mx, my), Min(Width, Height)) then s := 255
else
s := MulDiv(distance, 255, radius);
if PointInCircle(Point(mx, my), Min(Width, Height)) then
begin begin
if not WebSafe then if not WebSafe then
Result := HSVtoColor(h, s, FValue) Result := HSVtoColor(h, s, FValue)
else else
Result := GetWebSafe(HSVtoColor(h, s, FValue)); Result := GetWebSafe(HSVtoColor(h, s, FValue));
end end
else else
Result := clNone; Result := clNone;
end; end;
procedure THSVColorPicker.SetSelectedColor(c: TColor); procedure THSVColorPicker.SetSelectedColor(c: TColor);
var var
changeSave: boolean; changeSave: boolean;
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
changeSave := FChange; changeSave := FChange;
FManual := false; FManual := false;
Fchange := false; Fchange := false;
SetValue(GetVValue(c)); SetValue(GetVValue(c));
SetHue(GetHValue(c)); SetHue(GetHValue(c));
SetSat(GetSValue(c)); SetSat(GetSValue(c));
FSelectedColor := c; FSelectedColor := c;
Fchange := changeSave; FChange := changeSave;
if Fchange then if FChange and Assigned(FOnChange) then FOnChange(Self);
if Assigned(FOnChange) then FOnChange(Self); FChange := true;
FChange := true;
end; end;
function THSVColorPicker.RadHue(New: integer): integer; function THSVColorPicker.RadHue(New: integer): integer;
begin begin
if New < 0 then New := New + 360; if New < 0 then New := New + 360;
if New > 360 then New := New - 360; if New > 360 then New := New - 360;
Result := New; Result := New;
end; end;
procedure THSVColorPicker.CNKeyDown( procedure THSVColorPicker.CNKeyDown(
@ -647,11 +593,4 @@ begin
OnKeyDown(Self, Message.CharCode, Shift); OnKeyDown(Self, Message.CharCode, Shift);
end; end;
procedure THSVColorPicker.WebSafeChanged;
begin
inherited;
CreateHSVCircle;
Invalidate;
end;
end. end.

350
components/mbColorLib/RAxisColorPicker.pas
View File

@ -7,57 +7,45 @@ unit RAxisColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms, SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines; HTMLColors, mbColorPickerControl;
type type
TRAxisColorPicker = class(TmbColorPickerControl) TRAxisColorPicker = class(TmbColorPickerControl)
private private
FSelected: TColor; FR, FG, FB: integer;
FBmp: TBitmap; dx, dy, mxx, myy: integer;
FOnChange: TNotifyEvent; procedure SetRValue(r: integer);
FR, FG, FB: integer; procedure SetGValue(g: integer);
FManual: boolean; procedure SetBValue(b: integer);
dx, dy, mxx, myy: integer; protected
function GetGradientColor2D(x, y: Integer): TColor; override;
procedure SetRValue(r: integer); procedure SetSelectedColor(c: TColor); override;
procedure SetGValue(g: integer); procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
procedure SetBValue(b: integer); message CN_KEYDOWN;
protected procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
function GetSelectedColor: TColor; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure WebSafeChanged; override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure SetSelectedColor(c: TColor); override; procedure DrawMarker(x, y: integer);
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); procedure Paint; override;
message CN_KEYDOWN; procedure Resize; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure CreateWnd; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure CorrectCoords(var x, y: integer);
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; public
procedure DrawMarker(x, y: integer); constructor Create(AOwner: TComponent); override;
procedure Paint; override; published
procedure CreateRGBGradient; property SelectedColor default clRed;
procedure Resize; override; property RValue: integer read FR write SetRValue default 255;
procedure CreateWnd; override; property GValue: integer read FG write SetGValue default 0;
procedure CorrectCoords(var x, y: integer); property BValue: integer read FB write SetBValue default 0;
public property MarkerStyle default msCircle;
constructor Create(AOwner: TComponent); override; property OnChange;
destructor Destroy; override; end;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property SelectedColor default clRed;
property RValue: integer read FR write SetRValue default 255;
property GValue: integer read FG write SetGValue default 0;
property BValue: integer read FB write SetBValue default 0;
property MarkerStyle default msCircle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
procedure Register; procedure Register;
@ -67,196 +55,165 @@ implementation
{$R RAxisColorPicker.dcr} {$R RAxisColorPicker.dcr}
{$ENDIF} {$ENDIF}
uses
mbUtils;
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TRAxisColorPicker]); RegisterComponents('mbColor Lib', [TRAxisColorPicker]);
end; end;
{TRAxisColorPicker} {TRAxisColorPicker}
constructor TRAxisColorPicker.Create(AOwner: TComponent); constructor TRAxisColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FBmp := TBitmap.Create; FGradientWidth := 256;
FBmp.PixelFormat := pf32bit; FGradientHeight := 256;
FBmp.SetSize(256, 256); {$IFDEF DELPHI}
Width := 256; Width := 256;
Height := 256; Height := 256;
HintFormat := 'G: %g B: %b'#13'Hex: %hex'; {$ELSE}
FG := 0; SetInitialBounds(0, 0, 256, 256);
FB := 0; {$ENDIF}
FR := 255; HintFormat := 'G: %g B: %b'#13'Hex: %hex';
FSelected := clRed; FG := 0;
FManual := false; FB := 0;
dx := 0; FR := 255;
dy := 0; FSelected := clRed;
mxx := 0; FManual := false;
myy := 0; dx := 0;
MarkerStyle := msCircle; dy := 0;
end; mxx := 0;
myy := 0;
destructor TRAxisColorPicker.Destroy; MarkerStyle := msCircle;
begin
FBmp.Free;
inherited Destroy;
end; end;
procedure TRAxisColorPicker.CreateWnd; procedure TRAxisColorPicker.CreateWnd;
begin begin
inherited; inherited;
CreateRGBGradient; CreateGradient;
end; end;
procedure TRAxisColorPicker.CreateRGBGradient; { x is BLUE, y is GREEN }
var function TRAxisColorPicker.GetGradientColor2D(x, y: Integer): TColor;
g, b : integer;
row: pRGBQuadArray;
begin begin
if FBmp = nil then Result := RGB(FR, FGradientBmp.Height - 1 - y, x);
begin
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.Width := 256;
FBmp.Height := 256;
end;
for g := 255 downto 0 do
begin
row := FBmp.Scanline[255-g];
for b := 0 to 255 do
if not WebSafe then
row[b] := RGBtoRGBQuad(FR, g, b)
// FBmp.Canvas.Pixels[b,255-g] := RGB(FR, g, b)
else
row[b] := RGBtoRGBQuad(GetWebSafe(RGB(FR, g, b)));
// FBmp.Canvas.Pixels[b,255-g] := GetWebSafe(RGB(FR, g, b));
end;
end; end;
procedure TRAxisColorPicker.CorrectCoords(var x, y: integer); procedure TRAxisColorPicker.CorrectCoords(var x, y: integer);
begin begin
if x < 0 then x := 0; Clamp(x, 0, Width - 1);
if y < 0 then y := 0; Clamp(y, 0, Height - 1);
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
end; end;
procedure TRAxisColorPicker.DrawMarker(x, y: integer); procedure TRAxisColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
begin begin
CorrectCoords(x, y); CorrectCoords(x, y);
FR := GetRValue(FSelected); FR := GetRValue(FSelected);
FG := GetGValue(FSelected); FG := GetGValue(FSelected);
FB := GetBValue(FSelected); FB := GetBValue(FSelected);
if Assigned(FOnChange) then if Assigned(FOnChange) then
FOnChange(Self); FOnChange(Self);
dx := x; dx := x;
dy := y; dy := y;
if Focused or (csDesigning in ComponentState) then if Focused or (csDesigning in ComponentState) then
c := clBlack c := clBlack
else else
c := clWhite; c := clWhite;
case MarkerStyle of InternalDrawMarker(x, y, c);
msCircle: DrawSelCirc(x, y, Canvas);
msSquare: DrawSelSquare(x, y, Canvas);
msCross: DrawSelCross(x, y, Canvas, c);
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
end;
end;
function TRAxisColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
end; end;
procedure TRAxisColorPicker.SetSelectedColor(c: TColor); procedure TRAxisColorPicker.SetSelectedColor(c: TColor);
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
FR := GetRValue(c); FR := GetRValue(c);
FG := GetGValue(c); FG := GetGValue(c);
FB := GetBValue(c); FB := GetBValue(c);
FSelected := c; FSelected := c;
FManual := false; FManual := false;
myy := Round((255-FG)*(Height/255)); myy := Round((255-FG)*(Height/255));
mxx := Round(FB*(Width/255)); mxx := Round(FB*(Width/255));
CreateRGBGradient; CreateGradient;
Invalidate; Invalidate;
end; end;
procedure TRAxisColorPicker.Paint; procedure TRAxisColorPicker.Paint;
begin begin
Canvas.StretchDraw(ClientRect, FBmp); Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy); CorrectCoords(mxx, myy);
DrawMarker(mxx, myy); DrawMarker(mxx, myy);
end; end;
procedure TRAxisColorPicker.Resize; procedure TRAxisColorPicker.Resize;
begin begin
FManual := false; FManual := false;
myy := Round((255-FG)*(Height/255)); myy := Round((255-FG)*(Height/255));
mxx := Round(FB*(Width/255)); mxx := Round(FB*(Width/255));
inherited; inherited;
end; end;
procedure TRAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TRAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var var
R: TRect; R: TRect;
begin begin
inherited; inherited;
mxx := x; mxx := x;
myy := y; myy := y;
if Button = mbLeft then if Button = mbLeft then
begin begin
R := ClientRect; R := ClientRect;
R.TopLeft := ClientToScreen(R.TopLeft); R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight); R.BottomRight := ClientToScreen(R.BottomRight);
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(@R); ClipCursor(@R);
{$ENDIF} {$ENDIF}
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
SetFocus; SetFocus;
end; end;
procedure TRAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TRAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(nil); ClipCursor(nil);
{$ENDIF} {$ENDIF}
mxx := x; mxx := x;
myy := y; myy := y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
procedure TRAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TRAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
if ssLeft in Shift then if ssLeft in Shift then
begin begin
mxx := x; mxx := x;
myy := y; myy := y;
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
end; end;
end; end;
procedure TRAxisColorPicker.CNKeyDown( procedure TRAxisColorPicker.CNKeyDown(
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} );
var var
Shift: TShiftState; Shift: TShiftState;
FInherited: boolean; FInherited: boolean;
begin begin
FInherited := false; FInherited := false;
Shift := KeyDataToShiftState(Message.KeyData); Shift := KeyDataToShiftState(Message.KeyData);
if not (ssCtrl in Shift) then if not (ssCtrl in Shift) then
case Message.CharCode of case Message.CharCode of
VK_LEFT: VK_LEFT:
begin begin
mxx := dx - 1; mxx := dx - 1;
myy := dy; myy := dy;
@ -345,38 +302,23 @@ end;
procedure TRAxisColorPicker.SetRValue(r: integer); procedure TRAxisColorPicker.SetRValue(r: integer);
begin begin
if r > 255 then r := 255; Clamp(r, 0, 255);
if r < 0 then r := 0; FR := r;
FR := r; SetSelectedColor(RGB(FR, FG, FB));
SetSelectedColor(RGB(FR, FG, FB));
end; end;
procedure TRAxisColorPicker.SetGValue(g: integer); procedure TRAxisColorPicker.SetGValue(g: integer);
begin begin
if g > 255 then g := 255; Clamp(g, 0, 255);
if g < 0 then g := 0; FG := g;
FG := g; SetSelectedColor(RGB(FR, FG, FB));
SetSelectedColor(RGB(FR, FG, FB));
end; end;
procedure TRAxisColorPicker.SetBValue(b: integer); procedure TRAxisColorPicker.SetBValue(b: integer);
begin begin
if b > 255 then b := 255; Clamp(b, 0, 255);
if b < 0 then b := 0; FB := b;
FB := b; SetSelectedColor(RGB(FR, FG, FB));
SetSelectedColor(RGB(FR, FG, FB));
end;
function TRAxisColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure TRAxisColorPicker.WebSafeChanged;
begin
inherited;
CreateRGBGradient;
Invalidate;
end; end;
end. end.

59
components/mbColorLib/RGBHSLUtils.pas
View File

@ -25,13 +25,16 @@ procedure RGBtoHSLRange (RGB: TColor; var H1, S1, L1 : integer);
function GetHValue(AColor: TColor): integer; function GetHValue(AColor: TColor): integer;
function GetSValue(AColor: TColor): integer; function GetSValue(AColor: TColor): integer;
function GetLValue(AColor: TColor): integer; function GetLValue(AColor: TColor): integer;
procedure Clamp(var Input: integer; Min, Max: integer); //procedure Clamp(var Input: integer; Min, Max: integer);
function HSLToRGBTriple(H, S, L : integer) : TRGBTriple; function HSLToRGBTriple(H, S, L : integer) : TRGBTriple;
function HSLToRGBQuad(H, S, L: integer): TRGBQuad; function HSLToRGBQuad(H, S, L: integer): TRGBQuad;
procedure RGBTripleToHSL(RGBTriple : TRGBTriple; var h, s, l: integer); procedure RGBTripleToHSL(RGBTriple : TRGBTriple; var h, s, l: integer);
implementation implementation
uses
mbUtils;
function HSLtoRGB(H, S, L: double): TColor; function HSLtoRGB(H, S, L: double): TColor;
var var
M1, M2: double; M1, M2: double;
@ -156,12 +159,12 @@ begin
RGBToHSLRange(AColor, d, d, l); RGBToHSLRange(AColor, d, d, l);
Result := l; Result := l;
end; end;
{
procedure Clamp(var Input: integer; Min, Max: integer); procedure Clamp(var Input: integer; Min, Max: integer);
begin begin
if (Input < Min) then Input := Min; if (Input < Min) then Input := Min;
if (Input > Max) then Input := Max; if (Input > Max) then Input := Max;
end; end; }
function HSLToRGBTriple(H, S, L: integer): TRGBTriple; function HSLToRGBTriple(H, S, L: integer): TRGBTriple;
const const
@ -198,34 +201,34 @@ end;
function HSLToRGBQuad(H, S, L: integer): TRGBQuad; function HSLToRGBQuad(H, S, L: integer): TRGBQuad;
const const
Divisor = 255*60; Divisor = 255*60;
var var
hTemp, f, LS, p, q, r: integer; hTemp, f, LS, p, q, r: integer;
begin begin
Clamp(H, 0, MaxHue); Clamp(H, 0, MaxHue);
Clamp(S, 0, MaxSat); Clamp(S, 0, MaxSat);
Clamp(L, 0, MaxLum); Clamp(L, 0, MaxLum);
if (S = 0) then if (S = 0) then
Result := RGBToRGBQuad(L, L, L) Result := RGBToRGBQuad(L, L, L)
else else
begin begin
hTemp := H mod MaxHue; hTemp := H mod MaxHue;
f := hTemp mod 60; f := hTemp mod 60;
hTemp := hTemp div 60; hTemp := hTemp div 60;
LS := L*S; LS := L*S;
p := L - LS div MaxLum; p := L - LS div MaxLum;
q := L - (LS*f) div Divisor; q := L - (LS*f) div Divisor;
r := L - (LS*(60 - f)) div Divisor; r := L - (LS*(60 - f)) div Divisor;
case hTemp of case hTemp of
0: Result := RGBToRGBQuad(L, r, p); 0: Result := RGBToRGBQuad(L, r, p);
1: Result := RGBToRGBQuad(q, L, p); 1: Result := RGBToRGBQuad(q, L, p);
2: Result := RGBToRGBQuad(p, L, r); 2: Result := RGBToRGBQuad(p, L, r);
3: Result := RGBToRGBQuad(p, q, L); 3: Result := RGBToRGBQuad(p, q, L);
4: Result := RGBToRGBQuad(r, p, L); 4: Result := RGBToRGBQuad(r, p, L);
5: Result := RGBToRGBQuad(L, p, q); 5: Result := RGBToRGBQuad(L, p, q);
else else
Result := RGBToRGBQuad(0, 0, 0); Result := RGBToRGBQuad(0, 0, 0);
end; end;
end; end;
end; end;

423
components/mbColorLib/SLColorPicker.pas
View File

@ -12,51 +12,42 @@ uses
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, RGBHSLUtils, SysUtils, Classes, Controls, Graphics, Math, Forms,
Forms, HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines; mbColorPickerControl;
type type
TSLColorPicker = class(TmbColorPickerControl) TSLColorPicker = class(TmbColorPickerControl)
private private
FManual: boolean; FHue, FSat, FLum: integer;
FHue, FSat, FLum: integer; FChange: boolean;
FOnChange: TNotifyEvent; procedure DrawMarker(x, y: integer);
FChange: boolean; procedure SelectionChanged(x, y: integer);
FBMP: TBitmap; procedure UpdateCoords;
procedure SetHue(h: integer);
procedure CreateSLGradient; procedure SetSat(s: integer);
procedure DrawMarker(x, y: integer); procedure SetLum(l: integer);
procedure SelectionChanged(x, y: integer);
procedure UpdateCoords;
procedure SetHue(h: integer);
procedure SetSat(s: integer);
procedure SetLum(l: integer);
protected protected
procedure WebSafeChanged; override; function GetGradientColor2D(X, Y: Integer): TColor; override;
function GetSelectedColor: TColor; override; function GetSelectedColor: TColor; override;
procedure SetSelectedColor(c: TColor); override; procedure SetSelectedColor(c: TColor); override;
procedure Paint; override; procedure Paint; override;
procedure Resize; override; procedure Resize; override;
procedure CreateWnd; override; procedure CreateWnd; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; 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 MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN; message CN_KEYDOWN;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; function GetColorAtPoint(x, y: integer): TColor; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published published
property Hue: integer read FHue write SetHue default 0; property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 0; property Saturation: integer read FSat write SetSat default 0;
property Luminance: integer read FLum write SetLum default 255; property Luminance: integer read FLum write SetLum default 255;
property SelectedColor default clWhite; property SelectedColor default clWhite;
property MarkerStyle default msCircle; property MarkerStyle default msCircle;
property OnChange;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end; end;
procedure Register; procedure Register;
@ -65,10 +56,10 @@ implementation
{$IFDEF FPC} {$IFDEF FPC}
{$R SLColorPicker.dcr} {$R SLColorPicker.dcr}
{$ENDIF}
uses uses
IntfGraphics, fpimage; ScanLines, RGBHSLUtils, HTMLColors, mbUtils;
{$ENDIF}
procedure Register; procedure Register;
begin begin
@ -77,306 +68,211 @@ end;
constructor TSLColorPicker.Create(AOwner: TComponent); constructor TSLColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FBMP := TBitmap.Create; FGradientWidth := 256;
FBMP.PixelFormat := pf32bit; FGradientHeight := 256;
FBMP.SetSize(256, 256); {$IFDEF DELPHI}
Width := 255; Width := 255;
Height := 255; Height := 255;
MaxHue := 360; {$ELSE}
MaxSat := 255; SetInitialBounds(0, 0, 256, 256);
MaxLum := 255;
FHue := 0;
FSat := 0;
FLum := 255;
FChange := true;
MarkerStyle := msCircle;
end;
destructor TSLColorPicker.Destroy;
begin
FBMP.Free;
inherited;
end;
//{$IFDEF DELPHI}
procedure TSLColorPicker.CreateSLGradient;
var
x, y, skip: integer;
row: pRGBQuadArray;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF} {$ENDIF}
begin MaxHue := 360;
if FBmp = nil then MaxSat := 255;
begin MaxLum := 255;
FBmp := TBitmap.Create; FHue := 0;
FBmp.PixelFormat := pf32bit; FSat := 0;
FBmp.Width := 256; FLum := 255;
FBmp.Height := 256; FChange := true;
end; MarkerStyle := msCircle;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(FBmp.Width, FBmp.Height);
try
intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle);
{$ENDIF}
{
row := FBMP.ScanLine[0];
skip := integer(FBMP.ScanLine[1]) - Integer(row);
}
for y := 0 to 255 do
begin
{$IFDEF FPC}
row := intfImg.GetDataLineStart(y);
{$ELSE}
row := FHSVBmp.Scanline(y);
{$ENDIF}
for x := 0 to 255 do
if not WebSafe then
row[x] := HSLtoRGBQuad(FHue, x, 255 - y)
else
begin
c := GetWebSafe(RGBTripleToTColor(HSLToRGBTriple(FHue, x, 255 - y)));
row[x] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
end;
// row := pRGBQuadArray(Integer(row) + skip);
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBmp.Handle := imgHandle;
FBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
{$ENDIF}
end; end;
(* { This picker has Saturation along the X and Luminance along the Y axis. }
{$ELSE} function TSLColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
procedure TSLColorPicker.CreateSLGradient;
var var
x, y: Integer; q: TRGBQuad;
c: TColor;
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
begin begin
if FBmp = nil then q := HSLtoRGBQuad(FHue, x, 255-y);
begin Result := RGB(q.rgbRed, q.rgbGreen, q.rgbBlue);
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32Bit;
FBmp.Width := 256;
FBmp.Height := 256;
end;
intfimg := TLazIntfImage.Create(FBmp.Width, FBmp.Height);
try
intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle);
for y := 0 to 255 do // y = L
for x := 0 to 255 do // x = S
begin
c := HSLRangeToRGB(FHue, x, 255-y);
if WebSafe then
c := GetWebSafe(c);
intfImg.Colors[x, y] := TColorToFPColor(c);
end;
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBmp.Handle := imgHandle;
FBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
end; end;
{$ENDIF}
*)
procedure TSLColorPicker.Resize; procedure TSLColorPicker.Resize;
begin begin
inherited; inherited;
UpdateCoords; UpdateCoords;
end; end;
procedure TSLColorPicker.CreateWnd; procedure TSLColorPicker.CreateWnd;
begin begin
inherited; inherited;
CreateSLGradient; CreateGradient;
UpdateCoords; UpdateCoords;
end; end;
procedure TSLColorPicker.UpdateCoords; procedure TSLColorPicker.UpdateCoords;
begin begin
mdx := MulDiv(FSat, Width, 255); mdx := MulDiv(FSat, Width, 255);
mdy := MulDiv(255-FLum, Height, 255); mdy := MulDiv(255-FLum, Height, 255);
end; end;
procedure TSLColorPicker.DrawMarker(x, y: integer); procedure TSLColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
begin begin
c := not GetColorAtPoint(x, y); c := not GetColorAtPoint(x, y);
case MarkerStyle of InternalDrawMarker(x, y, c);
msCircle: DrawSelCirc(x, y, Canvas);
msSquare: DrawSelSquare(x, y, Canvas);
msCross: DrawSelCross(x, y, Canvas, c);
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
end;
end; end;
procedure TSLColorPicker.Paint; procedure TSLColorPicker.Paint;
begin begin
Canvas.StretchDraw(ClientRect, FBMP); Canvas.StretchDraw(ClientRect, FGradientBMP);
DrawMarker(mdx, mdy); UpdateCoords;
DrawMarker(mdx, mdy);
end; end;
procedure TSLColorPicker.SetHue(h: integer); procedure TSLColorPicker.SetHue(h: integer);
begin begin
if h > 360 then h := 360; Clamp(h, 0, 360);
if h < 0 then h := 0; if FHue <> h then
if FHue <> h then
begin begin
FHue := h; FHue := h;
FManual := false; FManual := false;
CreateSLGradient; CreateGradient;
UpdateCoords; UpdateCoords;
Invalidate; Invalidate;
if Fchange then if FChange and Assigned(FOnChange) then FOnChange(Self);
if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure TSLColorPicker.SetSat(s: integer); procedure TSLColorPicker.SetSat(s: integer);
begin begin
if s > 255 then s := 255; Clamp(s, 0, 255);
if s < 0 then s := 0; if FSat <> s then
if FSat <> s then
begin begin
FSat := s; FSat := s;
FManual := false; FManual := false;
UpdateCoords; UpdateCoords;
Invalidate; Invalidate;
if Fchange then if FChange and Assigned(FOnChange) then FOnChange(Self);
if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure TSLColorPicker.SetLum(l: integer); procedure TSLColorPicker.SetLum(L: integer);
begin begin
if l > 255 then l := 255; Clamp(L, 0, 255);
if l < 0 then l := 0; if FLum <> L then
if FLum <> l then
begin begin
FLum := l; FLum := L;
FManual := false; FManual := false;
UpdateCoords; UpdateCoords;
Invalidate; Invalidate;
if Fchange then if FChange and Assigned(FOnChange) then FOnChange(Self);
if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure TSLColorPicker.SelectionChanged(x, y: integer); procedure TSLColorPicker.SelectionChanged(x, y: integer);
begin begin
FChange := false; FChange := false;
// SetSat(MulDiv(255, x, Width)); // SetSat(MulDiv(255, x, Width));
// SetLum(MulDiv(255, Height - y, Height)); // SetLum(MulDiv(255, Height - y, Height));
SetSat(MulDiv(255, x, Width - 1)); SetSat(MulDiv(255, x, Width - 1));
SetLum(MulDiv(255, Height - y -1, Height - 1)); SetLum(MulDiv(255, Height - y -1, Height - 1));
FChange := true; FChange := true;
end; end;
procedure TSLColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; procedure TSLColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); X, Y: Integer);
begin begin
inherited; inherited;
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(nil); ClipCursor(nil);
{$ENDIF} {$ENDIF}
if csDesigning in ComponentState then Exit; if csDesigning in ComponentState then Exit;
if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then
begin begin
mdx := x; mdx := x;
mdy := y; mdy := y;
SelectionChanged(X, Y); SelectionChanged(X, Y);
FManual := true; FManual := true;
if Assigned(FOnChange) then FOnChange(Self); if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure TSLColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; procedure TSLColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); X, Y: Integer);
var var
R: TRect; R: TRect;
begin begin
inherited; inherited;
if csDesigning in ComponentState then Exit; if csDesigning in ComponentState then
if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then Exit;
if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then
begin begin
mdx := x; mdx := x;
mdy := y; mdy := y;
R := ClientRect; R := ClientRect;
R.TopLeft := ClientToScreen(R.TopLeft); R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight); R.BottomRight := ClientToScreen(R.BottomRight);
{$IFDEF DELPHI} {$IFDEF DELPHI}
ClipCursor(@R); ClipCursor(@R);
{$ENDIF} {$ENDIF}
SelectionChanged(X, Y); SelectionChanged(X, Y);
FManual := true; FManual := true;
if Assigned(FOnChange) then FOnChange(Self); if Assigned(FOnChange) then FOnChange(Self);
end; end;
SetFocus; SetFocus;
end; end;
procedure TSLColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TSLColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
if csDesigning in ComponentState then Exit; if csDesigning in ComponentState then
if (ssLeft in Shift) and PtInRect(ClientRect, Point(x, y)) then Exit;
if (ssLeft in Shift) and PtInRect(ClientRect, Point(x, y)) then
begin begin
mdx := x; mdx := x;
mdy := y; mdy := y;
SelectionChanged(X, Y); SelectionChanged(X, Y);
FManual := true; FManual := true;
if Assigned(FOnChange) then FOnChange(Self); if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure TSLColorPicker.SetSelectedColor(c: TColor); procedure TSLColorPicker.SetSelectedColor(c: TColor);
var var
h, s, l: integer; h, s, l: integer;
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
FManual := false; FManual := false;
Fchange := false; FChange := false;
RGBTripleToHSL(RGBtoRGBTriple(GetRValue(c), GetGValue(c), GetBValue(c)), h, s, l); RGBTripleToHSL(RGBtoRGBTriple(GetRValue(c), GetGValue(c), GetBValue(c)), h, s, l);
SetHue(h); SetHue(h);
SetSat(s); SetSat(s);
SetLum(l); SetLum(l);
if Fchange then if FChange and Assigned(FOnChange) then FOnChange(Self);
if Assigned(FOnChange) then FOnChange(Self); FChange := true;
FChange := true;
end; end;
function TSLColorPicker.GetSelectedColor: TColor; function TSLColorPicker.GetSelectedColor: TColor;
var var
triple: TRGBTriple; triple: TRGBTriple;
begin begin
triple := HSLToRGBTriple(FHue, FSat, FLum); triple := HSLToRGBTriple(FHue, FSat, FLum);
if not WebSafe then if not WebSafe then
Result := RGBTripleToTColor(triple) Result := RGBTripleToTColor(triple)
else else
Result := GetWebSafe(RGBTripleToTColor(triple)); Result := GetWebSafe(RGBTripleToTColor(triple));
end; end;
function TSLColorPicker.GetColorAtPoint(x, y: integer): TColor; function TSLColorPicker.GetColorAtPoint(x, y: integer): TColor;
var var
triple: TRGBTriple; triple: TRGBTriple;
begin begin
triple := HSLToRGBTriple(FHue, MulDiv(255, x, Width), MulDiv(255, Height - y, Height)); triple := HSLToRGBTriple(FHue, MulDiv(255, x, Width), MulDiv(255, Height - y, Height));
if not WebSafe then if not WebSafe then
Result := RGBTripleToTColor(triple) Result := RGBTripleToTColor(triple)
else else
Result := GetWebSafe(RGBTripleToTColor(triple)); Result := GetWebSafe(RGBTripleToTColor(triple));
end; end;
procedure TSLColorPicker.CNKeyDown( procedure TSLColorPicker.CNKeyDown(
@ -472,11 +368,4 @@ begin
OnKeyDown(Self, Message.CharCode, Shift); OnKeyDown(Self, Message.CharCode, Shift);
end; end;
procedure TSLColorPicker.WebSafeChanged;
begin
inherited;
CreateSLGradient;
Invalidate;
end;
end. end.

335
components/mbColorLib/SLHColorPicker.pas
View File

@ -9,94 +9,91 @@ interface
{$I mxs.inc} {$I mxs.inc}
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
RGBHSLUtils, mbTrackBarPicker, SLColorPicker, HColorPicker, Menus, RGBHSLUtils, mbTrackBarPicker, SLColorPicker, HColorPicker, Menus,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, mbBasicPicker; {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, mbBasicPicker;
type type
TSLHColorPicker = class(TmbBasicPicker) TSLHColorPicker = class(TmbBasicPicker)
private private
FOnChange: TNotifyEvent; FOnChange: TNotifyEvent;
FSLPicker: TSLColorPicker; FSLPicker: TSLColorPicker;
FHPicker: THColorPicker; FHPicker: THColorPicker;
FSelectedColor: TColor; FSelectedColor: TColor;
FHValue, FSValue, FLValue: integer; FHValue, FSValue, FLValue: integer;
FRValue, FGValue, FBValue: integer; FRValue, FGValue, FBValue: integer;
FSLHint, FHHint: string; FSLHint, FHHint: string;
FSLMenu, FHMenu: TPopupMenu; FSLMenu, FHMenu: TPopupMenu;
FSLCursor, FHCursor: TCursor; FSLCursor, FHCursor: TCursor;
PBack: TBitmap; PBack: TBitmap;
function GetManual: boolean;
function GetManual: boolean; procedure SelectColor(c: TColor);
procedure SelectColor(c: TColor); procedure SetH(v: integer);
procedure SetH(v: integer); procedure SetS(v: integer);
procedure SetS(v: integer); procedure SetL(v: integer);
procedure SetL(v: integer); procedure SetR(v: integer);
procedure SetR(v: integer); procedure SetG(v: integer);
procedure SetG(v: integer); procedure SetB(v: integer);
procedure SetB(v: integer); procedure SetHHint(h: string);
procedure SetHHint(h: string); procedure SetSLHint(h: string);
procedure SetSLHint(h: string); procedure SetSLMenu(m: TPopupMenu);
procedure SetSLMenu(m: TPopupMenu); procedure SetHMenu(m: TPopupMenu);
procedure SetHMenu(m: TPopupMenu); procedure SetHCursor(c: TCursor);
procedure SetHCursor(c: TCursor); procedure SetSLCursor(c: TCursor);
procedure SetSLCursor(c: TCursor); procedure HPickerChange(Sender: TObject);
protected procedure SLPickerChange(Sender: TObject);
procedure CreateWnd; override; protected
procedure Resize; override; procedure CreateWnd; override;
procedure Paint; override; procedure DoChange;
procedure PaintParentBack; override; procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF}); procedure Paint; override;
message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF}; procedure PaintParentBack; override;
procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure Resize; override;
procedure HPickerChange(Sender: TObject); procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF});
procedure SLPickerChange(Sender: TObject); message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
procedure DoChange; public
public constructor Create(AOwner: TComponent); override;
constructor Create(AOwner: TComponent); override; destructor Destroy; override;
destructor Destroy; override; function GetColorUnderCursor: TColor;
function GetHexColorUnderCursor: string;
function GetColorUnderCursor: TColor; function GetSelectedHexColor: string;
function GetHexColorUnderCursor: string; property ColorUnderCursor: TColor read GetColorUnderCursor;
function GetSelectedHexColor: string; property HValue: integer read FHValue write SetH default 0;
property ColorUnderCursor: TColor read GetColorUnderCursor; property SValue: integer read FSValue write SetS default 240;
property HValue: integer read FHValue write SetH default 0; property LValue: integer read FLValue write SetL default 120;
property SValue: integer read FSValue write SetS default 240; property RValue: integer read FRValue write SetR default 255;
property LValue: integer read FLValue write SetL default 120; property GValue: integer read FGValue write SetG default 0;
property RValue: integer read FRValue write SetR default 255; property BValue: integer read FBValue write SetB default 0;
property GValue: integer read FGValue write SetG default 0; property Manual: boolean read GetManual;
property BValue: integer read FBValue write SetB default 0; published
property Manual: boolean read GetManual; property SelectedColor: TColor read FSelectedColor write SelectColor default clRed;
published property HPickerPopupMenu: TPopupMenu read FHMenu write SetHMenu;
property SelectedColor: TColor read FSelectedColor write SelectColor default clRed; property SLPickerPopupMenu: TPopupMenu read FSLMenu write SetSLMenu;
property HPickerPopupMenu: TPopupMenu read FHMenu write SetHMenu; property HPickerHintFormat: string read FHHint write SetHHint;
property SLPickerPopupMenu: TPopupMenu read FSLMenu write SetSLMenu; property SLPickerHintFormat: string read FSLHint write SetSLHint;
property HPickerHintFormat: string read FHHint write SetHHint; property HPickerCursor: TCursor read FHCursor write SetHCursor default crDefault;
property SLPickerHintFormat: string read FSLHint write SetSLHint; property SLPickerCursor: TCursor read FSLCursor write SetSLCursor default crDefault;
property HPickerCursor: TCursor read FHCursor write SetHCursor default crDefault; property TabStop default true;
property SLPickerCursor: TCursor read FSLCursor write SetSLCursor default crDefault; property ShowHint;
property TabStop default true; property ParentShowHint;
property ShowHint; property Anchors;
property ParentShowHint; property Align;
property Anchors; property Visible;
property Align; property Enabled;
property Visible; property TabOrder;
property Enabled; property Color;
property TabOrder; property ParentColor default true;
property Color; {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
property ParentColor default true; property ParentBackground default true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} {$ENDIF}{$ENDIF}
property ParentBackground default true; property OnChange: TNotifyEvent read FOnChange write FOnChange;
{$ENDIF}{$ENDIF} property OnMouseMove;
end;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnMouseMove;
end;
procedure Register; procedure Register;
@ -106,9 +103,16 @@ implementation
{$R SLHColorPicker.dcr} {$R SLHColorPicker.dcr}
{$ENDIF} {$ENDIF}
const
WSL = 255;
HSL = 255;
WH = 40;
DIST = 2;
VDELTA = 8;
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TSLHColorPicker]); RegisterComponents('mbColor Lib', [TSLHColorPicker]);
end; end;
{TSLHColorPicker} {TSLHColorPicker}
@ -124,9 +128,12 @@ begin
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true; ParentBackground := true;
{$ENDIF}{$ENDIF} {$ENDIF}{$ENDIF}
SetInitialBounds(0, 0, 297, 271); {$IFDEF DELPHI}
// Width := 297; Width := 297;
// Height := 271; Height := 271;
{$ELSE}
SetInitialBounds(0, 0, WSL + DIST + WH, HSL + 2*VDELTA);
{$ENDIF}
TabStop := true; TabStop := true;
FSelectedColor := clRed; FSelectedColor := clRed;
FHPicker := THColorPicker.Create(Self); FHPicker := THColorPicker.Create(Self);
@ -137,14 +144,15 @@ begin
// Hue picker // Hue picker
with FHPicker do with FHPicker do
begin begin
SetInitialBounds(257, 0, 40, 271); {$IFDEF DELPHI}
{
Height := 271;
Width := 40;
Top := 0;
Left := 257; Left := 257;
} Top := 0;
Anchors := [akTop, akRight, akBottom]; Width := 40;
Height := 271;
{$ELSE}
SetInitialBounds(WSL + DIST, 0, WH, HSL + 2*VDELTA);
{$ENDIF}
// Anchors := [akTop, akRight, akBottom];
Visible := true; Visible := true;
Layout := lyVertical; Layout := lyVertical;
ArrowPlacement := spBoth; ArrowPlacement := spBoth;
@ -158,14 +166,15 @@ begin
InsertControl(FSLPicker); InsertControl(FSLPicker);
with FSLPicker do with FSLPicker do
begin begin
SetInitialBounds(0, 0, 255, 271); {$IFDEF DELPHI}
{
Width := 255;
Height := 271; //255;
Top := 0; //8;
Left := 0; Left := 0;
} Top := DELTA;
Anchors := [akLeft, akRight, akTop, akBottom]; Width := 255;
Height := self.Height - 2 * VDELTA;
{$ELSE}
SetInitialBounds(0, VDELTA, WSL, HSL);
{$ENDIF}
//Anchors := [akLeft, akRight, akTop, akBottom];
Visible := true; Visible := true;
SelectedColor := clRed; SelectedColor := clRed;
OnChange := SLPickerChange; OnChange := SLPickerChange;
@ -183,10 +192,10 @@ end;
destructor TSLHColorPicker.Destroy; destructor TSLHColorPicker.Destroy;
begin begin
PBack.Free; PBack.Free;
FHPicker.Free; FHPicker.Free;
FSLPicker.Free; FSLPicker.Free;
inherited Destroy; inherited Destroy;
end; end;
procedure TSLHColorPicker.HPickerChange(Sender: TObject); procedure TSLHColorPicker.HPickerChange(Sender: TObject);
@ -197,134 +206,134 @@ end;
procedure TSLHColorPicker.SLPickerChange(Sender: TObject); procedure TSLHColorPicker.SLPickerChange(Sender: TObject);
begin begin
FSelectedColor := FSLPicker.SelectedColor; FSelectedColor := FSLPicker.SelectedColor;
DoChange; DoChange;
end; end;
procedure TSLHColorPicker.DoChange; procedure TSLHColorPicker.DoChange;
begin begin
FHValue := FHPicker.Hue; FHValue := FHPicker.Hue;
FSValue := FSLPicker.Saturation; FSValue := FSLPicker.Saturation;
FLValue := FSLPicker.Luminance; FLValue := FSLPicker.Luminance;
FRValue := GetRValue(FSLPicker.SelectedColor); FRValue := GetRValue(FSLPicker.SelectedColor);
FGValue := GetGValue(FSLPicker.SelectedColor); FGValue := GetGValue(FSLPicker.SelectedColor);
FBValue := GetBValue(FSLPicker.SelectedColor); FBValue := GetBValue(FSLPicker.SelectedColor);
if Assigned(FOnChange) then if Assigned(FOnChange) then
FOnChange(Self); FOnChange(Self);
end; end;
procedure TSLHColorPicker.SelectColor(c: TColor); procedure TSLHColorPicker.SelectColor(c: TColor);
begin begin
FSelectedColor := c; FSelectedColor := c;
FHPicker.Hue := GetHValue(c); FHPicker.Hue := GetHValue(c);
FSLPicker.SelectedColor := c; FSLPicker.SelectedColor := c;
end; end;
procedure TSLHColorPicker.SetH(v: integer); procedure TSLHColorPicker.SetH(v: integer);
begin begin
FHValue := v; FHValue := v;
FSLPicker.Hue := v; FSLPicker.Hue := v;
FHPicker.Hue := v; FHPicker.Hue := v;
end; end;
procedure TSLHColorPicker.SetS(v: integer); procedure TSLHColorPicker.SetS(v: integer);
begin begin
FSValue := v; FSValue := v;
FSLPicker.Saturation := v; FSLPicker.Saturation := v;
end; end;
procedure TSLHColorPicker.SetL(v: integer); procedure TSLHColorPicker.SetL(v: integer);
begin begin
FLValue := v; FLValue := v;
FSLPicker.Luminance := v; FSLPicker.Luminance := v;
end; end;
procedure TSLHColorPicker.SetR(v: integer); procedure TSLHColorPicker.SetR(v: integer);
begin begin
FRValue := v; FRValue := v;
SelectColor(RGB(FRValue, FGValue, FBValue)); SelectColor(RGB(FRValue, FGValue, FBValue));
end; end;
procedure TSLHColorPicker.SetG(v: integer); procedure TSLHColorPicker.SetG(v: integer);
begin begin
FGValue := v; FGValue := v;
SelectColor(RGB(FRValue, FGValue, FBValue)); SelectColor(RGB(FRValue, FGValue, FBValue));
end; end;
procedure TSLHColorPicker.SetB(v: integer); procedure TSLHColorPicker.SetB(v: integer);
begin begin
FBValue := v; FBValue := v;
SelectColor(RGB(FRValue, FGValue, FBValue)); SelectColor(RGB(FRValue, FGValue, FBValue));
end; end;
function TSLHColorPicker.GetSelectedHexColor: string; function TSLHColorPicker.GetSelectedHexColor: string;
begin begin
Result := ColorToHex(FSelectedColor); Result := ColorToHex(FSelectedColor);
end; end;
procedure TSLHColorPicker.SetHHint(h: string); procedure TSLHColorPicker.SetHHint(h: string);
begin begin
FHHint := h; FHHint := h;
FHPicker.HintFormat := h; FHPicker.HintFormat := h;
end; end;
procedure TSLHColorPicker.SetSLHint(h: string); procedure TSLHColorPicker.SetSLHint(h: string);
begin begin
FSLHint := h; FSLHint := h;
FSLPicker.HintFormat := h; FSLPicker.HintFormat := h;
end; end;
procedure TSLHColorPicker.SetSLMenu(m: TPopupMenu); procedure TSLHColorPicker.SetSLMenu(m: TPopupMenu);
begin begin
FSLMenu := m; FSLMenu := m;
FSLPicker.PopupMenu := m; FSLPicker.PopupMenu := m;
end; end;
procedure TSLHColorPicker.SetHMenu(m: TPopupMenu); procedure TSLHColorPicker.SetHMenu(m: TPopupMenu);
begin begin
FHMenu := m; FHMenu := m;
FHPicker.PopupMenu := m; FHPicker.PopupMenu := m;
end; end;
procedure TSLHColorPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure TSLHColorPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin begin
if Assigned(OnMouseMove) then if Assigned(OnMouseMove) then
OnMouseMove(Self, Shift, x, y); OnMouseMove(Self, Shift, x, y);
inherited; inherited;
end; end;
function TSLHColorPicker.GetColorUnderCursor: TColor; function TSLHColorPicker.GetColorUnderCursor: TColor;
begin begin
Result := FSLPicker.GetColorUnderCursor; Result := FSLPicker.GetColorUnderCursor;
end; end;
function TSLHColorPicker.GetHexColorUnderCursor: string; function TSLHColorPicker.GetHexColorUnderCursor: string;
begin begin
Result := FSLPicker.GetHexColorUnderCursor; Result := FSLPicker.GetHexColorUnderCursor;
end; end;
procedure TSLHColorPicker.SetHCursor(c: TCursor); procedure TSLHColorPicker.SetHCursor(c: TCursor);
begin begin
FHCursor := c; FHCursor := c;
FHPicker.Cursor := c; FHPicker.Cursor := c;
end; end;
procedure TSLHColorPicker.SetSLCursor(c: TCursor); procedure TSLHColorPicker.SetSLCursor(c: TCursor);
begin begin
FSLCursor := c; FSLCursor := c;
FSLPicker.Cursor := c; FSLPicker.Cursor := c;
end; end;
procedure TSLHColorPicker.WMSetFocus( procedure TSLHColorPicker.WMSetFocus(
var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF} ); var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF} );
begin begin
FHPicker.SetFocus; FHPicker.SetFocus;
Message.Result := 1; Message.Result := 1;
end; end;
function TSLHColorPicker.GetManual:boolean; function TSLHColorPicker.GetManual:boolean;
begin begin
Result := FHPicker.Manual or FSLPicker.Manual; Result := FHPicker.Manual or FSLPicker.Manual;
end; end;
procedure TSLHColorPicker.Resize; procedure TSLHColorPicker.Resize;
@ -332,16 +341,14 @@ begin
inherited; inherited;
PaintParentBack; PaintParentBack;
if FSLPicker = nil then if (FSLPicker = nil) or (FHPicker = nil) then
exit; exit;
if FHPicker = nil then
exit;
FSLPicker.Width := Width - FHPicker.Width - 10; FSLPicker.Width := Width - FHPicker.Width - DIST;
FSLPicker.Height := Height - 2; FSLPicker.Height := Height - 2*VDELTA;
FHPicker.Left := Width - FHPicker.Width - 2; FHPicker.Left := Width - FHPicker.Width;
FHPicker.Height := Height - 2; FHPicker.Height := Height;
end; end;
procedure TSLHColorPicker.PaintParentBack; procedure TSLHColorPicker.PaintParentBack;
@ -364,8 +371,8 @@ end;
procedure TSLHColorPicker.CreateWnd; procedure TSLHColorPicker.CreateWnd;
begin begin
inherited; inherited;
PaintParentBack; PaintParentBack;
end; end;
end. end.

24
components/mbColorLib/mbBasicPicker.pas
View File

@ -13,8 +13,17 @@ uses
Classes, SysUtils, Graphics, Controls; Classes, SysUtils, Graphics, Controls;
type type
{ TmbBasicPicker }
TmbBasicPicker = class(TCustomControl) TmbBasicPicker = class(TCustomControl)
protected protected
FGradientBmp: TBitmap;
FGradientWidth: Integer;
FGradientHeight: Integer;
procedure CreateGradient; virtual;
function GetGradientColor(AValue: Integer): TColor; virtual;
function GetGradientColor2D(X, Y: Integer): TColor; virtual;
procedure PaintParentBack; virtual; overload; procedure PaintParentBack; virtual; overload;
procedure PaintParentBack(ACanvas: TCanvas); overload; procedure PaintParentBack(ACanvas: TCanvas); overload;
procedure PaintParentBack(ABitmap: TBitmap); overload; procedure PaintParentBack(ABitmap: TBitmap); overload;
@ -50,11 +59,26 @@ begin
inherited; inherited;
end; end;
procedure TmbBasicPicker.CreateGradient;
begin
// to be implemented by descendants
end;
function TmbBasicPicker.GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; function TmbBasicPicker.GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor;
begin begin
result := inherited GetDefaultColor(DefaultColorType); result := inherited GetDefaultColor(DefaultColorType);
end; end;
function TmbBasicPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := clNone;
end;
function TmbBasicPicker.GetGradientColor2D(X, Y: Integer): TColor;
begin
Result := clNone;
end;
procedure TmbBasicPicker.PaintParentBack; procedure TmbBasicPicker.PaintParentBack;
begin begin
PaintParentBack(Canvas); PaintParentBack(Canvas);

360
components/mbColorLib/mbColorPickerControl.pas
View File

@ -9,238 +9,308 @@ interface
{$I mxs.inc} {$I mxs.inc}
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
{$IFDEF DELPHI_7_UP} Themes,{$ENDIF} {$IFDEF DELPHI_7_UP} Themes,{$ENDIF}
RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors, mbBasicPicker; RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors, mbBasicPicker;
type type
TMarkerStyle = (msCircle, msSquare, msCross, msCrossCirc); TMarkerStyle = (msCircle, msSquare, msCross, msCrossCirc);
TmbCustomPicker = class(TmbBasicPicker) TmbCustomPicker = class(TmbBasicPicker)
private private
FHintFormat: string; FHintFormat: string;
FMarkerStyle: TMarkerStyle; FMarkerStyle: TMarkerStyle;
FWebSafe: boolean; FWebSafe: boolean;
procedure SetMarkerStyle(s: TMarkerStyle); procedure SetMarkerStyle(s: TMarkerStyle);
procedure SetWebSafe(s: boolean); procedure SetWebSafe(s: boolean);
protected protected
mx, my, mdx, mdy: integer; FManual: Boolean;
function GetSelectedColor: TColor; virtual; FSelected: TColor;
procedure SetSelectedColor(C: TColor); virtual; mx, my, mdx, mdy: integer;
procedure WebSafeChanged; dynamic; FOnChange: TNotifyEvent;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure CreateGradient; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; function GetSelectedColor: TColor; virtual;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure SetSelectedColor(C: TColor); virtual;
procedure CreateWnd; override; procedure InternalDrawMarker(X, Y: Integer; C: TColor);
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
{$IFDEF DELPHI} procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CMLostFocus(var Message: TCMLostFocus); message CM_EXIT; procedure CreateWnd; override;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; procedure WebSafeChanged; dynamic;
{$ELSE} procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
procedure CMGotFocus(var Message: TLMessage); message CM_ENTER; {$IFDEF DELPHI}
procedure CMLostFocus(var Message: TLMessage); message CM_EXIT; procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER;
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE; procedure CMLostFocus(var Message: TCMLostFocus); message CM_EXIT;
{$ENDIF} procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle; {$ELSE}
public procedure CMGotFocus(var Message: TLMessage); message CM_ENTER;
constructor Create(AOwner: TComponent); override; procedure CMLostFocus(var Message: TLMessage); message CM_EXIT;
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
{$ENDIF}
property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
public
constructor Create(AOwner: TComponent); override;
function GetColorAtPoint(x, y: integer): TColor; dynamic;
function GetHexColorAtPoint(X, Y: integer): string;
function GetColorUnderCursor: TColor;
function GetHexColorUnderCursor: string;
property ColorUnderCursor: TColor read GetColorUnderCursor;
property Manual: boolean read FManual;
published
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor;
property HintFormat: string read FHintFormat write FHintFormat;
property WebSafe: boolean read FWebSafe write SetWebSafe default false;
end;
function GetColorAtPoint(x, y: integer): TColor; dynamic; TmbColorPickerControl = class(TmbCustomPicker)
function GetHexColorAtPoint(X, Y: integer): string; published
function GetColorUnderCursor: TColor; property Anchors;
function GetHexColorUnderCursor: string; property Align;
property ShowHint;
property ColorUnderCursor: TColor read GetColorUnderCursor; property ParentShowHint;
published property Visible;
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor; property Enabled;
property HintFormat: string read FHintFormat write FHintFormat; property PopupMenu;
property WebSafe: boolean read FWebSafe write SetWebSafe default false; property TabOrder;
end; property TabStop default true;
property Color;
TmbColorPickerControl = class(TmbCustomPicker) property ParentColor;
published {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
property Anchors; property ParentBackground default true;
property Align; {$ENDIF}{$ENDIF}
property ShowHint; property DragCursor;
property ParentShowHint; property DragMode;
property Visible; property DragKind;
property Enabled; property Constraints;
property PopupMenu; property OnContextPopup;
property TabOrder; property OnMouseDown;
property TabStop default true; property OnMouseMove;
property Color; property OnMouseUp;
property ParentColor; property OnKeyDown;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} property OnKeyPress;
property ParentBackground default true; property OnKeyUp;
{$ENDIF}{$ENDIF} property OnDragDrop;
property DragCursor; property OnDragOver;
property DragMode; property OnEndDrag;
property DragKind; property OnEnter;
property Constraints; property OnExit;
property OnResize;
property OnContextPopup; property OnStartDrag;
property OnMouseDown; end;
property OnMouseMove;
property OnMouseUp;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnResize;
property OnStartDrag;
end;
implementation implementation
uses PalUtils; uses
{$IFDEF FPC}
IntfGraphics, fpimage,
{$ENDIF}
ScanLines, PalUtils, SelPropUtils;
constructor TmbCustomPicker.Create(AOwner: TComponent); constructor TmbCustomPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls]; ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls];
DoubleBuffered := true; DoubleBuffered := true;
TabStop := true; TabStop := true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true; ParentBackground := true;
{$ENDIF}{$ENDIF} {$ENDIF}{$ENDIF}
mx := 0; mx := 0;
my := 0; my := 0;
mdx := 0; mdx := 0;
mdy := 0; mdy := 0;
FHintFormat := 'Hex #%hex'#10#13'RGB[%r, %g, %b]'#10#13'HSL[%hslH, %hslS, %hslL]'#10#13'HSV[%hsvH, %hsvS, %hsvV]'#10#13'CMYK[%c, %m, %y, %k]'#10#13'L*a*b*[%cieL, %cieA, %cieB]'#10#13'XYZ[%cieX, %cieY, %cieZ]'; FHintFormat := 'Hex #%hex'#10#13'RGB[%r, %g, %b]'#10#13'HSL[%hslH, %hslS, %hslL]'#10#13'HSV[%hsvH, %hsvS, %hsvV]'#10#13'CMYK[%c, %m, %y, %k]'#10#13'L*a*b*[%cieL, %cieA, %cieB]'#10#13'XYZ[%cieX, %cieY, %cieZ]';
FWebSafe := false; FWebSafe := false;
end; end;
procedure TmbCustomPicker.CreateWnd; procedure TmbCustomPicker.CreateWnd;
begin begin
inherited; inherited;
end; end;
procedure TmbCustomPicker.CMGotFocus( procedure TmbCustomPicker.CMGotFocus(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF} ); var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF} );
begin begin
inherited; inherited;
Invalidate; Invalidate;
end; end;
procedure TmbCustomPicker.CMLostFocus( procedure TmbCustomPicker.CMLostFocus(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF} ); var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF} );
begin begin
inherited; inherited;
Invalidate; Invalidate;
end; end;
procedure TmbCustomPicker.CMMouseLeave( procedure TmbCustomPicker.CMMouseLeave(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF}); var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
begin begin
mx := 0; mx := 0;
my := 0; my := 0;
inherited; inherited;
end;
procedure TmbCustomPicker.CreateGradient;
var
// x, y, skip: integer;
x, y: Integer;
row: pRGBQuadArray;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin
if FGradientBmp = nil then
begin
FGradientBmp := TBitmap.Create;
FGradientBmp.PixelFormat := pf32bit;
end;
FGradientBmp.Width := FGradientWidth;
FGradientBmp.Height := FGradientHeight;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(FGradientBmp.Width, FGradientBmp.Height);
try
intfImg.LoadFromBitmap(FGradientBmp.Handle, FGradientBmp.MaskHandle);
{$ENDIF}
for y := 0 to FGradientBmp.Height - 1 do
begin
{$IFDEF FPC}
row := intfImg.GetDataLineStart(y); //FGradientBmp.Height - 1 - y);
{$ELSE}
row := FHSVBmp.Scanline(y); //FGradientBmp.Height - 1 - y);
{$ENDIF}
for x := 0 to FGradientBmp.Width - 1 do
begin
c := GetGradientColor2D(x, y);
if WebSafe then
c := GetWebSafe(c);
row[x] := RGBToRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
end;
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FGradientBmp.Handle := imgHandle;
FGradientBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
{$ENDIF}
end; end;
function TmbCustomPicker.GetSelectedColor: TColor; function TmbCustomPicker.GetSelectedColor: TColor;
begin begin
Result := clNone; Result := FSelected; // valid for most descendents
//handled in descendents
end; end;
procedure TmbCustomPicker.SetSelectedColor(C: TColor); procedure TmbCustomPicker.SetSelectedColor(C: TColor);
begin begin
//handled in descendents FSelected := C;
//handled in descendents
end; end;
function TmbCustomPicker.GetColorAtPoint(x, y: integer): TColor; function TmbCustomPicker.GetColorAtPoint(x, y: integer): TColor;
begin begin
Result := clNone; Result := Canvas.Pixels[x, y]; // valid for most descendents
//handled in descendents
end; end;
function TmbCustomPicker.GetHexColorAtPoint(X, Y: integer): string; function TmbCustomPicker.GetHexColorAtPoint(X, Y: integer): string;
begin begin
Result := ColorToHex(GetColorAtPoint(x, y)); Result := ColorToHex(GetColorAtPoint(x, y));
end; end;
function TmbCustomPicker.GetColorUnderCursor: TColor; function TmbCustomPicker.GetColorUnderCursor: TColor;
begin begin
Result := GetColorAtPoint(mx, my); Result := GetColorAtPoint(mx, my);
end; end;
function TmbCustomPicker.GetHexColorUnderCursor: string; function TmbCustomPicker.GetHexColorUnderCursor: string;
begin begin
Result := ColorToHex(GetColorAtPoint(mx, my)); Result := ColorToHex(GetColorAtPoint(mx, my));
end;
procedure TmbCustomPicker.InternalDrawMarker(X, Y: Integer; C: TColor);
begin
case MarkerStyle of
msCircle: DrawSelCirc(x, y, Canvas);
msSquare: DrawSelSquare(x, y, Canvas);
msCross: DrawSelCross(x, y, Canvas, c);
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
end;
end; end;
procedure TmbCustomPicker.CMHintShow(var Message: TCMHintShow); procedure TmbCustomPicker.CMHintShow(var Message: TCMHintShow);
begin begin
if GetColorUnderCursor <> clNone then if GetColorUnderCursor <> clNone then
with TCMHintShow(Message) do with TCMHintShow(Message) do
if not ShowHint then if not ShowHint then
Message.Result := 1 Message.Result := 1
else else
with HintInfo^ do with HintInfo^ do
begin begin
Result := 0; Result := 0;
ReshowTimeout := 1; ReshowTimeout := 1;
HideTimeout := 5000; HideTimeout := 5000;
HintStr := FormatHint(FHintFormat, GetColorUnderCursor);; HintStr := FormatHint(FHintFormat, GetColorUnderCursor);;
end; end;
inherited; inherited;
end; end;
procedure TmbCustomPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TmbCustomPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
mx := x; mx := x;
my := y; my := y;
end; end;
procedure TmbCustomPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; procedure TmbCustomPicker.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); X, Y: Integer);
begin begin
inherited; inherited;
mx := x; mx := x;
my := y; my := y;
end; end;
procedure TmbCustomPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; procedure TmbCustomPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); X, Y: Integer);
begin begin
inherited; inherited;
mx := x; mx := x;
my := y; my := y;
end; end;
procedure TmbCustomPicker.SetMarkerStyle(s: TMarkerStyle); procedure TmbCustomPicker.SetMarkerStyle(s: TMarkerStyle);
begin begin
if FMarkerStyle <> s then if FMarkerStyle <> s then
begin begin
FMarkerStyle := s; FMarkerStyle := s;
invalidate; Invalidate;
end; end;
end; end;
procedure TmbCustomPicker.SetWebSafe(s: boolean); procedure TmbCustomPicker.SetWebSafe(s: boolean);
begin begin
if FWebSafe <> s then if FWebSafe <> s then
begin begin
FWebSafe := s; FWebSafe := s;
WebSafeChanged; WebSafeChanged;
end; end;
end; end;
procedure TmbCustomPicker.WebSafeChanged; procedure TmbCustomPicker.WebSafeChanged;
begin begin
//handled in descendents CreateGradient;
Invalidate;
end; end;
end. end.

26
components/mbColorLib/mbTrackBarPicker.pas
View File

@ -75,12 +75,8 @@ type
FChange: boolean; FChange: boolean;
FPickRect: TRect; FPickRect: TRect;
FLimit: integer; FLimit: integer;
FGradientBmp: TBitmap;
FGradientWidth: Integer;
FGradientHeight: Integer;
procedure CreateGradient; procedure CreateGradient; override;
function GetGradientColor(AValue: Integer): TColor; virtual;
procedure Paint; override; procedure Paint; override;
procedure DrawFrames; dynamic; procedure DrawFrames; dynamic;
procedure Resize; override; procedure Resize; override;
@ -249,17 +245,13 @@ begin
inherited; inherited;
end; end;
function TmbTrackbarPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := clDefault;
end;
{ AWidth and AHeight are seen for horizontal arrangement of the bar } { AWidth and AHeight are seen for horizontal arrangement of the bar }
procedure TmbTrackbarPicker.CreateGradient; procedure TmbTrackbarPicker.CreateGradient;
var var
i,j: integer; i,j: integer;
row: pRGBQuadArray; row: pRGBQuadArray;
c: TColor; c: TColor;
q: TRGBQuad;
{$IFDEF FPC} {$IFDEF FPC}
intfimg: TLazIntfImage; intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap; imgHandle, imgMaskHandle: HBitmap;
@ -283,6 +275,8 @@ begin
for i := 0 to FGradientBmp.Width-1 do for i := 0 to FGradientBmp.Width-1 do
begin begin
c := GetGradientColor(i); c := GetGradientColor(i);
if WebSafe then c := GetWebSafe(c);
q := RGBToRGBQuad(c);
for j := 0 to FGradientBmp.Height-1 do for j := 0 to FGradientBmp.Height-1 do
begin begin
{$IFDEF FPC} {$IFDEF FPC}
@ -290,10 +284,7 @@ begin
{$ELSE} {$ELSE}
row := FGradientBmp.ScanLine[j]; row := FGradientBmp.ScanLine[j];
{$ENDIF} {$ENDIF}
if not WebSafe then row[i] := q;
row[i] := RGBtoRGBQuad(c)
else
row[i] := RGBtoRGBQuad(GetWebSafe(c));
end; end;
end; end;
end end
@ -312,11 +303,10 @@ begin
row := FGradientBmp.ScanLine[i]; row := FGradientBmp.ScanLine[i];
{$ENDIF} {$ENDIF}
c := GetGradientColor(FGradientBmp.Height - 1 - i); c := GetGradientColor(FGradientBmp.Height - 1 - i);
if WebSafe then c := GetWebSafe(c);
q := RGBtoRGBQuad(c);
for j := 0 to FGradientBmp.Width-1 do for j := 0 to FGradientBmp.Width-1 do
if not WebSafe then row[j] := q;
row[j] := RGBtoRGBQuad(c)
else
row[j] := RGBtoRGBQuad(GetWebSafe(c));
end; end;
end; end;

9
components/mbColorLib/mbutils.pas
View File

@ -8,6 +8,7 @@ uses
Classes, SysUtils; Classes, SysUtils;
procedure Clamp(var AValue:Integer; AMin, AMax: Integer); procedure Clamp(var AValue:Integer; AMin, AMax: Integer);
function PointInCircle(p: TPoint; Size: integer): boolean;
implementation implementation
@ -17,6 +18,14 @@ begin
if AValue > AMax then AValue := AMax; if AValue > AMax then AValue := AMax;
end; end;
function PointInCircle(p: TPoint; Size: integer): boolean;
var
r: integer;
begin
r := size div 2;
Result := (sqr(p.x - r) + sqr(p.y - r) <= sqr(r));
end;
end. end.