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

112
components/mbColorLib/BAxisColorPicker.pas
View File

@ -13,24 +13,18 @@ uses
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;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FR, FG, FB: integer; FR, FG, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer; dx, dy, mxx, myy: integer;
procedure SetRValue(r: integer); procedure SetRValue(r: integer);
procedure SetGValue(g: integer); procedure SetGValue(g: integer);
procedure SetBValue(b: integer); procedure SetBValue(b: integer);
protected protected
function GetSelectedColor: TColor; override; function GetGradientColor2D(x, y: Integer): TColor; override;
procedure WebSafeChanged; override;
procedure SetSelectedColor(c: TColor); override; procedure SetSelectedColor(c: TColor); 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;
@ -39,24 +33,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer); procedure DrawMarker(x, y: integer);
procedure Paint; override; procedure Paint; override;
procedure CreateRGBGradient;
procedure Resize; override; procedure Resize; override;
procedure CreateWnd; override; procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer); procedure CorrectCoords(var x, y: integer);
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published published
property SelectedColor default clBlue; property SelectedColor default clBlue;
property RValue: integer read FR write SetRValue default 0; property RValue: integer read FR write SetRValue default 0;
property GValue: integer read FG write SetGValue default 0; property GValue: integer read FG write SetGValue default 0;
property BValue: integer read FB write SetBValue default 255; property BValue: integer read FB write SetBValue default 255;
property MarkerStyle default msCircle; property MarkerStyle default msCircle;
property OnChange;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end; end;
procedure Register; procedure Register;
@ -67,6 +55,9 @@ 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]);
@ -77,11 +68,14 @@ end;
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;
{$ELSE}
SetInitialBounds(0, 0, 255, 255);
{$ENDIF}
HintFormat := 'R: %r G: %g'#13'Hex: %hex'; HintFormat := 'R: %r G: %g'#13'Hex: %hex';
FG := 0; FG := 0;
FB := 255; FB := 255;
@ -95,48 +89,22 @@ begin
MarkerStyle := msCircle; MarkerStyle := msCircle;
end; end;
destructor TBAxisColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
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);
@ -155,17 +123,7 @@ begin
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);
@ -178,13 +136,13 @@ 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));
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;
@ -192,12 +150,13 @@ 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
@ -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; 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.

107
components/mbColorLib/CIEAColorPicker.pas
View File

@ -13,24 +13,18 @@ uses
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;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FL, FA, FB: integer; FL, FA, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer; dx, dy, mxx, myy: integer;
procedure SetLValue(l: integer); procedure SetLValue(l: integer);
procedure SetAValue(a: integer); procedure SetAValue(a: integer);
procedure SetBValue(b: integer); procedure SetBValue(b: integer);
protected protected
function GetSelectedColor: TColor; override; function GetGradientColor2D(x, y: Integer): TColor; override;
procedure WebSafeChanged; override;
procedure SetSelectedColor(c: TColor); override; procedure SetSelectedColor(c: TColor); 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;
@ -39,24 +33,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer); procedure DrawMarker(x, y: integer);
procedure Paint; override; procedure Paint; override;
procedure CreateLABGradient;
procedure Resize; override; procedure Resize; override;
procedure CreateWnd; override; procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer); procedure CorrectCoords(var x, y: integer);
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published published
property SelectedColor default clFuchsia; property SelectedColor default clFuchsia;
property LValue: integer read FL write SetLValue default 100; property LValue: integer read FL write SetLValue default 100;
property AValue: integer read FA write SetAValue default 127; property AValue: integer read FA write SetAValue default 127;
property BValue: integer read FB write SetBValue default -128; property BValue: integer read FB write SetBValue default -128;
property MarkerStyle default msCircle; property MarkerStyle default msCircle;
property OnChange;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end; end;
procedure Register; procedure Register;
@ -67,6 +55,9 @@ 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]);
@ -77,11 +68,19 @@ end;
constructor TCIEAColorPicker.Create(AOwner: TComponent); constructor TCIEAColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
{
FBmp := TBitmap.Create; FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit; FBmp.PixelFormat := pf32bit;
FBmp.SetSize(256, 256); FBmp.SetSize(256, 256);
}
FGradientWidth := 256;
FGradientHeight := 256;
{$IFDEF DELPHI}
Width := 256; Width := 256;
Height := 256; Height := 256;
{$ELSE}
SetInitialBounds(0, 0, 256, 256);
{$ENDIF}
HintFormat := 'L: %cieL B: %cieB'#13'Hex: %hex'; HintFormat := 'L: %cieL B: %cieB'#13'Hex: %hex';
FSelected := clFuchsia; FSelected := clFuchsia;
FL := 100; FL := 100;
@ -95,48 +94,23 @@ begin
MarkerStyle := msCircle; MarkerStyle := msCircle;
end; end;
destructor TCIEAColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
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);
@ -155,17 +129,7 @@ begin
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);
@ -178,13 +142,13 @@ 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));
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;
@ -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; 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.

113
components/mbColorLib/CIEBColorPicker.pas
View File

@ -13,24 +13,21 @@ uses
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 }
TCIEBColorPicker = class(TmbColorPickerControl) TCIEBColorPicker = class(TmbColorPickerControl)
private private
FSelected: TColor;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FL, FA, FB: integer; FL, FA, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer; dx, dy, mxx, myy: integer;
procedure SetLValue(l: integer); procedure SetLValue(l: integer);
procedure SetAValue(a: integer); procedure SetAValue(a: integer);
procedure SetBValue(b: integer); procedure SetBValue(b: integer);
protected protected
function GetSelectedColor: TColor; override; function GetGradientColor2D(x, y: Integer): TColor; override;
procedure WebSafeChanged; override;
procedure SetSelectedColor(c: TColor); override; procedure SetSelectedColor(c: TColor); 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;
@ -39,24 +36,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer); procedure DrawMarker(x, y: integer);
procedure Paint; override; procedure Paint; override;
procedure CreateLABGradient;
procedure Resize; override; procedure Resize; override;
procedure CreateWnd; override; procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer); procedure CorrectCoords(var x, y: integer);
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published published
property SelectedColor default clLime; property SelectedColor default clLime;
property LValue: integer read FL write SetLValue default 100; property LValue: integer read FL write SetLValue default 100;
property AValue: integer read FA write SetAValue default -128; property AValue: integer read FA write SetAValue default -128;
property BValue: integer read FB write SetBValue default 127; property BValue: integer read FB write SetBValue default 127;
property MarkerStyle default msCircle; property MarkerStyle default msCircle;
property OnChange;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end; end;
procedure Register; procedure Register;
@ -67,6 +58,9 @@ 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]);
@ -77,11 +71,14 @@ end;
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;
{$ELSE}
SetInitialBounds(0, 0, 256, 256);
{$ENDIF}
HintFormat := 'L: %cieL A: %cieA'#13'Hex: %hex'; HintFormat := 'L: %cieL A: %cieA'#13'Hex: %hex';
FSelected := clLime; FSelected := clLime;
FL := 100; FL := 100;
@ -95,48 +92,23 @@ begin
MarkerStyle := msCircle; MarkerStyle := msCircle;
end; end;
destructor TCIEBColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
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);
@ -155,17 +127,7 @@ begin
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);
@ -178,13 +140,13 @@ 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));
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;
@ -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; 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.

109
components/mbColorLib/CIELColorPicker.pas
View File

@ -13,24 +13,18 @@ uses
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;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FL, FA, FB: integer; FL, FA, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer; dx, dy, mxx, myy: integer;
procedure SetLValue(l: integer); procedure SetLValue(l: integer);
procedure SetAValue(a: integer); procedure SetAValue(a: integer);
procedure SetBValue(b: integer); procedure SetBValue(b: integer);
protected protected
function GetSelectedColor: TColor; override; function GetGradientColor2D(x, y: Integer): TColor; override;
procedure WebSafeChanged; override;
procedure SetSelectedColor(c: TColor); override; procedure SetSelectedColor(c: TColor); 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;
@ -39,24 +33,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer); procedure DrawMarker(x, y: integer);
procedure Paint; override; procedure Paint; override;
procedure CreateLABGradient;
procedure Resize; override; procedure Resize; override;
procedure CreateWnd; override; procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer); procedure CorrectCoords(var x, y: integer);
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published published
property SelectedColor default clAqua; property SelectedColor default clAqua;
property LValue: integer read FL write SetLValue default 100; property LValue: integer read FL write SetLValue default 100;
property AValue: integer read FA write SetAValue default -128; property AValue: integer read FA write SetAValue default -128;
property BValue: integer read FB write SetBValue default 127; property BValue: integer read FB write SetBValue default 127;
property MarkerStyle default msCircle; property MarkerStyle default msCircle;
property OnChange;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end; end;
procedure Register; procedure Register;
@ -67,6 +55,9 @@ 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]);
@ -77,11 +68,14 @@ end;
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;
{$ELSE}
SetInitialBounds(0, 0, 256, 256);
{$ENDIF}
HintFormat := 'A: %cieA B: %cieB'#13'Hex: %hex'; HintFormat := 'A: %cieA B: %cieB'#13'Hex: %hex';
FSelected := clAqua; FSelected := clAqua;
FL := 100; FL := 100;
@ -95,50 +89,22 @@ begin
MarkerStyle := msCircle; MarkerStyle := msCircle;
end; end;
destructor TCIELColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
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);
@ -157,17 +123,7 @@ begin
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);
@ -180,13 +136,13 @@ 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));
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;
@ -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; 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.

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

9
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;

115
components/mbColorLib/GAxisColorPicker.pas
View File

@ -13,24 +13,18 @@ uses
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;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FR, FG, FB: integer; FR, FG, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer; dx, dy, mxx, myy: integer;
procedure SetRValue(r: integer); procedure SetRValue(r: integer);
procedure SetGValue(g: integer); procedure SetGValue(g: integer);
procedure SetBValue(b: integer); procedure SetBValue(b: integer);
protected protected
function GetSelectedColor: TColor; override; function GetGradientColor2D(x, y: Integer): TColor; override;
procedure WebSafeChanged; override;
procedure SetSelectedColor(c: TColor); override; procedure SetSelectedColor(c: TColor); 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;
@ -39,24 +33,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer); procedure DrawMarker(x, y: integer);
procedure Paint; override; procedure Paint; override;
procedure CreateRGBGradient;
procedure Resize; override; procedure Resize; override;
procedure CreateWnd; override; procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer); procedure CorrectCoords(var x, y: integer);
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published published
property SelectedColor default clLime; property SelectedColor default clLime;
property RValue: integer read FR write SetRValue default 0; property RValue: integer read FR write SetRValue default 0;
property GValue: integer read FG write SetGValue default 255; property GValue: integer read FG write SetGValue default 255;
property BValue: integer read FB write SetBValue default 0; property BValue: integer read FB write SetBValue default 0;
property MarkerStyle default msCircle; property MarkerStyle default msCircle;
property OnChange;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end; end;
procedure Register; procedure Register;
@ -67,6 +55,9 @@ 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]);
@ -77,11 +68,14 @@ end;
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;
{$ELSE}
SetInitialBounds(0, 0, 256, 256);
{$ENDIF}
HintFormat := 'R: %r B: %b'#13'Hex: %hex'; HintFormat := 'R: %r B: %b'#13'Hex: %hex';
FG := 255; FG := 255;
FB := 0; FB := 0;
@ -95,47 +89,21 @@ begin
MarkerStyle := msCircle; MarkerStyle := msCircle;
end; end;
destructor TGAxisColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
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);
@ -154,17 +122,7 @@ begin
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);
@ -177,13 +135,13 @@ 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));
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;
@ -224,9 +182,9 @@ begin
{$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;
@ -236,9 +194,9 @@ 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;
@ -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; 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.

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;

248
components/mbColorLib/HRingPicker.pas
View File

@ -13,8 +13,7 @@ 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)
@ -22,15 +21,11 @@ type
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;
FBMP: TBitmap;
FDoChange: boolean; FDoChange: boolean;
procedure CreateHSVCircle;
function RadHue(New: integer): integer; function RadHue(New: integer): integer;
procedure SetRadius(r: integer); procedure SetRadius(r: integer);
procedure SetValue(v: integer); procedure SetValue(v: integer);
@ -41,8 +36,9 @@ type
procedure SelectionChanged(x, y: integer); procedure SelectionChanged(x, y: integer);
procedure UpdateCoords; procedure UpdateCoords;
protected protected
procedure CreateGradient; override;
function GetGradientColor2D(X, Y: Integer): TColor; override;
function GetSelectedColor: TColor; override; function GetSelectedColor: TColor; override;
procedure WebSafeChanged; override;
procedure SetSelectedColor(c: TColor); override; procedure SetSelectedColor(c: TColor); override;
procedure Paint; override; procedure Paint; override;
procedure Resize; override; procedure Resize; override;
@ -54,19 +50,15 @@ type
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 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,133 +67,88 @@ 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}
SetInitialBounds(0, 0, 204, 204);
{$ENDIF}
FValue := 255; FValue := 255;
FHue := 0; FHue := 0;
FSat := 0; FSat := 0;
FHueLineColor := clGray; FHueLineColor := clGray;
FSelectedColor := clNone; FSelectedColor := clNone;
FManual := false; FManual := false;
Fchange := true; FChange := true;
FRadius := 30; FRadius := 40;
FDoChange := false; FDoChange := false;
end; end;
destructor THRingPicker.Destroy; procedure THRingPicker.CreateGradient;
begin begin
FBMP.Free; FGradientWidth := Min(Width, Height);
FGradientHeight := FGradientWidth;
inherited; inherited;
end; end;
procedure THRingPicker.CreateHSVCircle; { Outer loop: Y, Inner loop: X }
function THRingPicker.GetGradientColor2D(X, Y: Integer): TColor;
var var
dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer; xcoord, ycoord: Integer;
row: pRGBQuadArray; dSq, radiusSq: Integer;
c: TColor; radius, size: Integer;
{$IFDEF FPC} S, H, V: Integer;
intfimg: TLazIntfImage; q: TRGBQuad;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin begin
if FBmp = nil then size := FGradientWidth; // or Height, they are the same...
begin
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
end;
size := Min(Width, Height);
FBmp.Width := size;
FBmp.Height := size;
PaintParentBack(FBmp);
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
intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle);
{$ENDIF}
for j := 0 to size - 1 do
begin begin
Y := Size - 1 - j - radius; if radius <> 0 then
S := round((255 * sqrt(dSq)) / radius)
{$IFDEF FPC}
row := intfImg.GetDataLineStart(size - 1 - j);
{$ELSE}
row := FBmp.Scanline(size - 1 - j);
{$ENDIF}
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 else
S := 0; S := 0;
H := round( 180 * (1 + arctan2(X, Y) / PI)); // wp: order (x,y) is correct! H := round( 180 * (1 + arctan2(xcoord, ycoord) / pi)); // wp: order (x,y) is correct!
H := H + 90; H := H + 90;
if H > 360 then H := H - 360; if H > 360 then H := H - 360;
if not WebSafe then Result := HSVtoColor(H, S, FValue);
row[i] := HSVtoRGBQuad(H,S,V) if WebSafe then
else Result := GetWebSafe(Result);
begin end else
c := GetWebSafe(HSVtoColor(H, S, V)); Result := GetDefaultColor(dctBrush);
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;
@ -209,56 +156,52 @@ 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;
@ -283,15 +226,17 @@ end;
procedure THRingPicker.DrawHueLine; procedure THRingPicker.DrawHueLine;
var var
angle: double; angle: double;
sinAngle, cosAngle: Double;
radius: integer; 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;
SinCos(angle, sinAngle, cosAngle);
Canvas.Pen.Color := FHueLineColor; Canvas.Pen.Color := FHueLineColor;
Canvas.MoveTo(Radius,Radius); Canvas.MoveTo(radius, radius);
Canvas.LineTo(Radius + Round(Radius*COS(angle)), Radius + Round(Radius*SIN(angle))); 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,9 +275,9 @@ 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);
@ -343,16 +289,19 @@ 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
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;
@ -363,7 +312,7 @@ begin
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;
@ -380,7 +329,7 @@ var
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;
@ -402,7 +351,7 @@ 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;
@ -427,21 +376,24 @@ 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)
@ -464,9 +416,8 @@ begin
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;
@ -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.

144
components/mbColorLib/HSColorPicker.pas
View File

@ -13,24 +13,22 @@ uses
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 }
THSColorPicker = class(TmbColorPickerControl) THSColorPicker = class(TmbColorPickerControl)
private private
FSelected: TColor;
FHSLBmp: TBitmap;
FOnChange: TNotifyEvent;
FHue, FSaturation, FLuminance: integer; FHue, FSaturation, FLuminance: integer;
FLum: integer; FLum: integer;
FManual: boolean;
dx, dy, mxx, myy: integer; dx, dy, mxx, myy: integer;
procedure SetHValue(h: integer); procedure SetHValue(h: integer);
procedure SetSValue(s: integer); procedure SetSValue(s: integer);
protected protected
function GetSelectedColor: TColor; override; procedure CorrectCoords(var x, y: integer);
procedure WebSafeChanged; override; function GetGradientColor2D(X, Y: Integer): TColor; override;
procedure SetSelectedColor(c: TColor); override; procedure SetSelectedColor(c: TColor); 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;
@ -39,25 +37,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer); procedure DrawMarker(x, y: integer);
procedure Paint; override; procedure Paint; override;
procedure CreateHSLGradient;
procedure Resize; override; procedure Resize; override;
procedure CreateWnd; override; procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer);
function PredictColor: TColor; function PredictColor: TColor;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Lum: integer read FLum write FLum default 120; property Lum: integer read FLum write FLum default 120;
property Manual: boolean read FManual;
published published
property SelectedColor default clRed; property SelectedColor default clRed;
property HueValue: integer read FHue write SetHValue default 0; property HueValue: integer read FHue write SetHValue default 0;
property SaturationValue: integer read FSaturation write SetSValue default 240; property SaturationValue: integer read FSaturation write SetSValue default 240;
property MarkerStyle default msCross; property MarkerStyle default msCross;
property OnChange;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end; end;
procedure Register; procedure Register;
@ -66,10 +57,10 @@ implementation
{$IFDEF FPC} {$IFDEF FPC}
{$R HSColorPicker.dcr} {$R HSColorPicker.dcr}
{$ENDIF}
uses uses
IntfGraphics, fpimage; mbUtils;
{$ENDIF}
procedure Register; procedure Register;
begin begin
@ -81,11 +72,14 @@ end;
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;
{$ELSE}
SetInitialBounds(0, 0, 239, 240);
{$ENDIF}
HintFormat := 'H: %h S: %hslS'#13'Hex: %hex'; HintFormat := 'H: %h S: %hslS'#13'Hex: %hex';
FHue := 0; FHue := 0;
FSaturation := 240; FSaturation := 240;
@ -100,85 +94,21 @@ begin
MarkerStyle := msCross; MarkerStyle := msCross;
end; end;
destructor THSColorPicker.Destroy;
begin
FHSLBmp.Free;
inherited Destroy;
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; 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;
{$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);
@ -195,17 +125,7 @@ begin
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);
@ -221,7 +141,7 @@ 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;
@ -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)); SetSelectedColor(HSLRangeToRGB(FHue, FSaturation, 120)); // why hard-coded 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; 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.

31
components/mbColorLib/HSLRingPicker.pas
View File

@ -125,8 +125,12 @@ begin
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
ParentBackground := true; ParentBackground := true;
{$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF}
{$IFDEF DELPHI}
Width := 245; Width := 245;
Height := 245; Height := 245;
{$ELSE}
SetInitialBounds(0, 0, 245, 245);
{$ENDIF}
TabStop := true; TabStop := true;
FSelectedColor := clRed; FSelectedColor := clRed;
FRingPicker := THRingPicker.Create(Self); FRingPicker := THRingPicker.Create(Self);
@ -135,10 +139,14 @@ begin
FSLCursor := crDefault; FSLCursor := crDefault;
with FRingPicker do with FRingPicker do
begin begin
Height := 246; {$IFDEF DELPHI}
Width := 246;
Top := 0;
Left := 0; Left := 0;
Top := 0;
Width := 246;
Height := 246;
{$ELSE}
SetInitialBounds(0, 0, 246, 246);
{$ENDIF}
Radius := 100; Radius := 100;
Align := alClient; Align := alClient;
Visible := true; Visible := true;
@ -152,10 +160,14 @@ begin
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;
Height := 120;
{$ELSE}
SetInitialBounds(63, 63, 120, 120);
{$ENDIF}
Visible := true; Visible := true;
OnChange := SLPickerChange; OnChange := SLPickerChange;
OnMouseMove := DoMouseMove; OnMouseMove := DoMouseMove;
@ -188,7 +200,6 @@ begin
exit; exit;
ctr := Min(Width, Height)/100; ctr := Min(Width, Height)/100;
circ.x := Min(Width, Height) div 2; circ.x := Min(Width, Height) div 2;
circ.y := circ.x; circ.y := circ.x;
@ -198,13 +209,7 @@ begin
FSLPicker.Top := circ.y - FSLPicker.Height div 2; FSLPicker.Top := circ.y - FSLPicker.Height div 2;
FSLPicker.Width := round(50 * ctr); FSLPicker.Width := round(50 * ctr);
FSLPicker.Height := FSLPicker.Width; 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); PaintParentBack(PBack);
end; end;

301
components/mbColorLib/HSVColorPicker.pas
View File

@ -13,8 +13,8 @@ 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)
@ -22,16 +22,11 @@ type
FHue, FSat, FValue: integer; FHue, FSat, FValue: integer;
FSatCircColor, FHueLineColor: TColor; FSatCircColor, FHueLineColor: TColor;
FSelectedColor: TColor; FSelectedColor: TColor;
FOnChange: TNotifyEvent;
FManual: boolean;
FShowSatCirc: boolean; FShowSatCirc: boolean;
FShowHueLine: boolean; FShowHueLine: boolean;
FShowSelCirc: boolean; FShowSelCirc: boolean;
Fchange: boolean; FChange: boolean;
FHSVBmp: TBitmap;
FDoChange: boolean; FDoChange: boolean;
procedure CreateHSVCircle;
function RadHue(New: integer): integer; function RadHue(New: integer): integer;
procedure SetValue(V: integer); procedure SetValue(V: integer);
procedure SetHue(h: integer); procedure SetHue(h: integer);
@ -47,9 +42,10 @@ type
procedure SetShowHueLine(s: boolean); procedure SetShowHueLine(s: boolean);
procedure UpdateCoords; procedure UpdateCoords;
protected protected
procedure CreateGradient; 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 WebSafeChanged; override;
procedure Paint; override; procedure Paint; override;
procedure Resize; override; procedure Resize; override;
procedure CreateWnd; override; procedure CreateWnd; override;
@ -60,10 +56,7 @@ type
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;
@ -75,8 +68,7 @@ type
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,31 +77,28 @@ 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}
SetInitialBounds(0, 0, 204, 204);
{$ENDIF}
FValue := 255; FValue := 255;
FHue := 0; FHue := 0;
FSat := 0; FSat := 0;
@ -120,17 +109,11 @@ begin
FShowSatCirc := true; FShowSatCirc := true;
FShowHueLine := true; FShowHueLine := true;
FShowSelCirc := true; FShowSelCirc := true;
Fchange := true; FChange := true;
FDoChange := false; FDoChange := false;
MarkerStyle := msCrossCirc; MarkerStyle := msCrossCirc;
end; end;
destructor THSVColorPicker.Destroy;
begin
FHSVBmp.Free;
inherited;
end;
procedure THSVColorPicker.Paint; procedure THSVColorPicker.Paint;
var var
rgn: HRGN; rgn: HRGN;
@ -140,9 +123,10 @@ begin
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);
InflateRect(R, -1, -1); // Avoid spurious black pixels at the border
rgn := CreateEllipticRgnIndirect(R); rgn := CreateEllipticRgnIndirect(R);
SelectClipRgn(Canvas.Handle, rgn); SelectClipRgn(Canvas.Handle, rgn);
Canvas.Draw(0, 0, FHSVBmp); Canvas.Draw(0, 0, FGradientBmp);
DeleteObject(rgn); DeleteObject(rgn);
DrawSatCirc; DrawSatCirc;
DrawHueLine; DrawHueLine;
@ -154,155 +138,109 @@ begin
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); { Outer loop: Y, Inner loop: X }
FHSVBmp.Width := size; function THSVColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
FHSVBmp.Height := size; var
PaintParentBack(FHSVBmp.Canvas); 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
intfImg.LoadFromBitmap(FHSVBmp.Handle, FHSVBmp.MaskHandle);
{$ENDIF}
for j := 0 to size - 1 do
begin begin
Y := size - 1 - j - Radius; if radius <> 0 then
{$IFDEF FPC} S := round((255 * sqrt(dSq)) / radius)
row := intfImg.GetDataLineStart(size - 1 - j); //S := trunc((255 * sqrt(dSq)) / radius)
{$ELSE}
row := FHSVBmp.Scanline(size - 1 - j);
{$ENDIF}
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.0 * sqrt(dSquared) / radius)
else else
S := 0; S := 0;
H := round(180 * (1 + arctan2(X, Y) / pi)); // wp: order (x,y) is correct! H := round( 180 * (1 + arctan2(xcoord, ycoord) / pi)); // wp: order (x,y) is correct!
H := H + 90; H := H + 90;
if H > 360 then H := H - 360; if H > 360 then H := H - 360;
{$IFDEF FPC} Result := HSVtoColor(H, S, FValue);
c := HSVtoColor(H, S, V);
if WebSafe then if WebSafe then
c := GetWebSafe(c); Result := GetWebSafe(Result);
row^[i].rgbRed := GetRValue(c); end else
row^[i].rgbGreen := GetGValue(c); Result := GetDefaultColor(dctBrush);
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;
sinAngle, cosAngle: Double;
radius: integer; 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;
@ -354,32 +292,36 @@ 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;
sinAngle, cosAngle: Double;
radius: integer; radius: integer;
begin begin
if not FShowHueLine then Exit; if not FShowHueLine then
Radius := Min(Width, Height) div 2; exit;
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;
SinCos(angle, sinAngle, cosAngle);
Canvas.Pen.Color := FHueLineColor; Canvas.Pen.Color := FHueLineColor;
Canvas.MoveTo(Radius,Radius); Canvas.MoveTo(radius, radius);
Canvas.LineTo(Radius + Round(Radius*COS(angle)), Radius + Round(Radius*SIN(angle))); Canvas.LineTo(radius + round(radius*cosAngle), radius + round(radius*sinAngle));
end; end;
end; end;
@ -387,45 +329,44 @@ procedure THSVColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
begin begin
if not FShowSelCirc then Exit; if not FShowSelCirc then
exit;
if Focused or (csDesigning in ComponentState) then if Focused or (csDesigning in ComponentState) then
c := clBlack c := clBlack
else else
c := clGray; c := clGray;
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 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);
FChange := false;
SetHue(Angle); SetHue(Angle);
Distance := ROUND(SQRT(SQR(xDelta) + SQR(yDelta))); distance := round(sqrt(sqr(xDelta) + sqr(yDelta)));
if Distance >= Radius then SetSat(255) if distance >= radius then
else SetSat(MulDiv(Distance, 255, Radius)); SetSat(255)
Fchange := true; else
SetSat(MulDiv(distance, 255, radius));
FChange := true;
end; end;
procedure THSVColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; procedure THSVColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
@ -435,8 +376,9 @@ begin
{$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;
@ -452,8 +394,9 @@ 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;
@ -474,8 +417,9 @@ 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;
@ -500,21 +444,24 @@ 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)
@ -537,9 +484,8 @@ begin
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;
@ -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.

106
components/mbColorLib/RAxisColorPicker.pas
View File

@ -13,24 +13,18 @@ uses
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;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FR, FG, FB: integer; FR, FG, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer; dx, dy, mxx, myy: integer;
procedure SetRValue(r: integer); procedure SetRValue(r: integer);
procedure SetGValue(g: integer); procedure SetGValue(g: integer);
procedure SetBValue(b: integer); procedure SetBValue(b: integer);
protected protected
function GetSelectedColor: TColor; override; function GetGradientColor2D(x, y: Integer): TColor; override;
procedure WebSafeChanged; override;
procedure SetSelectedColor(c: TColor); override; procedure SetSelectedColor(c: TColor); 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;
@ -39,24 +33,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer); procedure DrawMarker(x, y: integer);
procedure Paint; override; procedure Paint; override;
procedure CreateRGBGradient;
procedure Resize; override; procedure Resize; override;
procedure CreateWnd; override; procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer); procedure CorrectCoords(var x, y: integer);
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published published
property SelectedColor default clRed; property SelectedColor default clRed;
property RValue: integer read FR write SetRValue default 255; property RValue: integer read FR write SetRValue default 255;
property GValue: integer read FG write SetGValue default 0; property GValue: integer read FG write SetGValue default 0;
property BValue: integer read FB write SetBValue default 0; property BValue: integer read FB write SetBValue default 0;
property MarkerStyle default msCircle; property MarkerStyle default msCircle;
property OnChange;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end; end;
procedure Register; procedure Register;
@ -67,6 +55,9 @@ 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]);
@ -77,11 +68,14 @@ end;
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;
{$ELSE}
SetInitialBounds(0, 0, 256, 256);
{$ENDIF}
HintFormat := 'G: %g B: %b'#13'Hex: %hex'; HintFormat := 'G: %g B: %b'#13'Hex: %hex';
FG := 0; FG := 0;
FB := 0; FB := 0;
@ -95,49 +89,22 @@ begin
MarkerStyle := msCircle; MarkerStyle := msCircle;
end; end;
destructor TRAxisColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
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);
@ -156,17 +123,7 @@ begin
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);
@ -179,13 +136,13 @@ 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));
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;
@ -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; 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.

9
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

185
components/mbColorLib/SLColorPicker.pas
View File

@ -12,19 +12,14 @@ 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;
FOnChange: TNotifyEvent;
FChange: boolean; FChange: boolean;
FBMP: TBitmap;
procedure CreateSLGradient;
procedure DrawMarker(x, y: integer); procedure DrawMarker(x, y: integer);
procedure SelectionChanged(x, y: integer); procedure SelectionChanged(x, y: integer);
procedure UpdateCoords; procedure UpdateCoords;
@ -32,7 +27,7 @@ type
procedure SetSat(s: integer); procedure SetSat(s: integer);
procedure SetLum(l: 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;
@ -45,18 +40,14 @@ type
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
@ -78,11 +69,14 @@ 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;
{$ELSE}
SetInitialBounds(0, 0, 256, 256);
{$ENDIF}
MaxHue := 360; MaxHue := 360;
MaxSat := 255; MaxSat := 255;
MaxLum := 255; MaxLum := 255;
@ -93,104 +87,15 @@ begin
MarkerStyle := msCircle; MarkerStyle := msCircle;
end; end;
destructor TSLColorPicker.Destroy; { This picker has Saturation along the X and Luminance along the Y axis. }
begin function TSLColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
FBMP.Free;
inherited;
end;
//{$IFDEF DELPHI}
procedure TSLColorPicker.CreateSLGradient;
var var
x, y, skip: integer; q: TRGBQuad;
row: pRGBQuadArray;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
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; end;
{$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;
(*
{$ELSE}
procedure TSLColorPicker.CreateSLGradient;
var
x, y: Integer;
c: TColor;
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
begin
if FBmp = nil then
begin
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;
{$ENDIF}
*)
procedure TSLColorPicker.Resize; procedure TSLColorPicker.Resize;
begin begin
inherited; inherited;
@ -200,7 +105,7 @@ end;
procedure TSLColorPicker.CreateWnd; procedure TSLColorPicker.CreateWnd;
begin begin
inherited; inherited;
CreateSLGradient; CreateGradient;
UpdateCoords; UpdateCoords;
end; end;
@ -215,63 +120,53 @@ 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);
UpdateCoords;
DrawMarker(mdx, mdy); 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;
@ -309,7 +204,8 @@ 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 PtInRect(ClientRect, Point(x, y)) then if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then
begin begin
mdx := x; mdx := x;
@ -330,7 +226,8 @@ 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
Exit;
if (ssLeft in Shift) and PtInRect(ClientRect, Point(x, y)) then if (ssLeft in Shift) and PtInRect(ClientRect, Point(x, y)) then
begin begin
mdx := x; mdx := x;
@ -347,13 +244,12 @@ var
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;
@ -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.

77
components/mbColorLib/SLHColorPicker.pas
View File

@ -31,7 +31,6 @@ type
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);
@ -46,21 +45,20 @@ type
procedure SetHMenu(m: TPopupMenu); procedure SetHMenu(m: TPopupMenu);
procedure SetHCursor(c: TCursor); procedure SetHCursor(c: TCursor);
procedure SetSLCursor(c: TCursor); procedure SetSLCursor(c: TCursor);
protected
procedure CreateWnd; override;
procedure Resize; override;
procedure Paint; override;
procedure PaintParentBack; override;
procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF});
message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure HPickerChange(Sender: TObject); procedure HPickerChange(Sender: TObject);
procedure SLPickerChange(Sender: TObject); procedure SLPickerChange(Sender: TObject);
protected
procedure CreateWnd; override;
procedure DoChange; procedure DoChange;
procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure Paint; override;
procedure PaintParentBack; override;
procedure Resize; override;
procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF});
message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; destructor Destroy; override;
function GetColorUnderCursor: TColor; function GetColorUnderCursor: TColor;
function GetHexColorUnderCursor: string; function GetHexColorUnderCursor: string;
function GetSelectedHexColor: string; function GetSelectedHexColor: string;
@ -93,7 +91,6 @@ type
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
property ParentBackground default true; property ParentBackground default true;
{$ENDIF}{$ENDIF} {$ENDIF}{$ENDIF}
property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnMouseMove; property OnMouseMove;
end; end;
@ -106,6 +103,13 @@ 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]);
@ -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;
@ -332,16 +341,14 @@ begin
inherited; inherited;
PaintParentBack; PaintParentBack;
if FSLPicker = nil then if (FSLPicker = nil) or (FHPicker = nil) then
exit;
if FHPicker = nil then
exit; 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;

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);

92
components/mbColorLib/mbColorPickerControl.pas
View File

@ -29,14 +29,19 @@ type
procedure SetMarkerStyle(s: TMarkerStyle); procedure SetMarkerStyle(s: TMarkerStyle);
procedure SetWebSafe(s: boolean); procedure SetWebSafe(s: boolean);
protected protected
FManual: Boolean;
FSelected: TColor;
mx, my, mdx, mdy: integer; mx, my, mdx, mdy: integer;
FOnChange: TNotifyEvent;
procedure CreateGradient; override;
function GetSelectedColor: TColor; virtual; function GetSelectedColor: TColor; virtual;
procedure SetSelectedColor(C: TColor); virtual; procedure SetSelectedColor(C: TColor); virtual;
procedure WebSafeChanged; dynamic; procedure InternalDrawMarker(X, Y: Integer; C: TColor);
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 CreateWnd; override; procedure CreateWnd; override;
procedure WebSafeChanged; dynamic;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
{$IFDEF DELPHI} {$IFDEF DELPHI}
procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER; procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER;
@ -48,15 +53,15 @@ type
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE; procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
{$ENDIF} {$ENDIF}
property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle; property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
function GetColorAtPoint(x, y: integer): TColor; dynamic; function GetColorAtPoint(x, y: integer): TColor; dynamic;
function GetHexColorAtPoint(X, Y: integer): string; function GetHexColorAtPoint(X, Y: integer): string;
function GetColorUnderCursor: TColor; function GetColorUnderCursor: TColor;
function GetHexColorUnderCursor: string; function GetHexColorUnderCursor: string;
property ColorUnderCursor: TColor read GetColorUnderCursor; property ColorUnderCursor: TColor read GetColorUnderCursor;
property Manual: boolean read FManual;
published published
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor; property SelectedColor: TColor read GetSelectedColor write SetSelectedColor;
property HintFormat: string read FHintFormat write FHintFormat; property HintFormat: string read FHintFormat write FHintFormat;
@ -83,7 +88,6 @@ type
property DragMode; property DragMode;
property DragKind; property DragKind;
property Constraints; property Constraints;
property OnContextPopup; property OnContextPopup;
property OnMouseDown; property OnMouseDown;
property OnMouseMove; property OnMouseMove;
@ -102,7 +106,11 @@ type
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
@ -148,21 +156,72 @@ begin
inherited; inherited;
end; 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;
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
FSelected := C;
//handled in descendents //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;
@ -180,6 +239,16 @@ begin
Result := ColorToHex(GetColorAtPoint(mx, my)); Result := ColorToHex(GetColorAtPoint(mx, my));
end; 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;
procedure TmbCustomPicker.CMHintShow(var Message: TCMHintShow); procedure TmbCustomPicker.CMHintShow(var Message: TCMHintShow);
begin begin
if GetColorUnderCursor <> clNone then if GetColorUnderCursor <> clNone then
@ -225,7 +294,7 @@ begin
if FMarkerStyle <> s then if FMarkerStyle <> s then
begin begin
FMarkerStyle := s; FMarkerStyle := s;
invalidate; Invalidate;
end; end;
end; end;
@ -240,7 +309,8 @@ 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.