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,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines;
HTMLColors, mbColorPickerControl;
type
TBAxisColorPicker = class(TmbColorPickerControl)
private
FSelected: TColor;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FR, FG, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer;
procedure SetRValue(r: integer);
procedure SetGValue(g: integer);
procedure SetBValue(b: integer);
protected
function GetSelectedColor: TColor; override;
procedure WebSafeChanged; override;
function GetGradientColor2D(x, y: Integer): TColor; override;
procedure SetSelectedColor(c: TColor); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
@ -39,24 +33,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer);
procedure Paint; override;
procedure CreateRGBGradient;
procedure Resize; override;
procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property SelectedColor default clBlue;
property RValue: integer read FR write SetRValue default 0;
property GValue: integer read FG write SetGValue default 0;
property BValue: integer read FB write SetBValue default 255;
property MarkerStyle default msCircle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChange;
end;
procedure Register;
@ -67,6 +55,9 @@ implementation
{$R BAxisColorPicker.dcr}
{$ENDIF}
uses
mbUtils;
procedure Register;
begin
RegisterComponents('mbColor Lib', [TBAxisColorPicker]);
@ -77,11 +68,14 @@ end;
constructor TBAxisColorPicker.Create(AOwner: TComponent);
begin
inherited;
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.SetSize(256, 256);
FGradientWidth := 256;
FGradientHeight := 256;
{$IFDEF DELPHI}
Width := 256;
Height := 256;
{$ELSE}
SetInitialBounds(0, 0, 255, 255);
{$ENDIF}
HintFormat := 'R: %r G: %g'#13'Hex: %hex';
FG := 0;
FB := 255;
@ -95,48 +89,22 @@ begin
MarkerStyle := msCircle;
end;
destructor TBAxisColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
end;
procedure TBAxisColorPicker.CreateWnd;
begin
inherited;
CreateRGBGradient;
CreateGradient;
end;
procedure TBAxisColorPicker.CreateRGBGradient;
var
r, g: integer;
row: pRGBQuadArray;
{ x is RED, y is GREEN }
function TBAxisColorPicker.GetGradientColor2D(x, y: Integer): TColor;
begin
if FBmp = nil then
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;
Result := RGB(x, FGradientBmp.Height - 1 - y, FB);
end;
procedure TBAxisColorPicker.CorrectCoords(var x, y: integer);
begin
if x < 0 then x := 0;
if y < 0 then y := 0;
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
Clamp(x, 0, Width - 1);
Clamp(y, 0, Height - 1);
end;
procedure TBAxisColorPicker.DrawMarker(x, y: integer);
@ -155,17 +123,7 @@ begin
c := clBlack
else
c := clWhite;
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;
function TBAxisColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
InternalDrawMarker(x, y, c);
end;
procedure TBAxisColorPicker.SetSelectedColor(c: TColor);
@ -178,13 +136,13 @@ begin
FManual := false;
mxx := Round(FR*(Width/255));
myy := Round((255-FG)*(Height/255));
CreateRGBGradient;
CreateGradient;
Invalidate;
end;
procedure TBAxisColorPicker.Paint;
begin
Canvas.StretchDraw(ClientRect, FBmp);
Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy);
DrawMarker(mxx, myy);
end;
@ -192,12 +150,13 @@ end;
procedure TBAxisColorPicker.Resize;
begin
FManual := false;
mxx := Round(FR*(Width/255));
myy := Round((255-FG)*(Height/255));
mxx := round(FR * (Width / 255));
myy := round((255 - FG) * (Height / 255));
inherited;
end;
procedure TBAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure TBAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
R: TRect;
begin
@ -344,38 +303,23 @@ end;
procedure TBAxisColorPicker.SetRValue(r: integer);
begin
if r > 255 then r := 255;
if r < 0 then r := 0;
Clamp(r, 0, 255);
FR := r;
SetSelectedColor(RGB(FR, FG, FB));
end;
procedure TBAxisColorPicker.SetGValue(g: integer);
begin
if g > 255 then g := 255;
if g < 0 then g := 0;
Clamp(g, 0, 255);
FG := g;
SetSelectedColor(RGB(FR, FG, FB));
end;
procedure TBAxisColorPicker.SetBValue(b: integer);
begin
if b > 255 then b := 255;
if b < 0 then b := 0;
Clamp(b, 0, 255);
FB := b;
SetSelectedColor(RGB(FR, FG, FB));
end;
function TBAxisColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure TBAxisColorPicker.WebSafeChanged;
begin
inherited;
CreateRGBGradient;
Invalidate;
end;
end.

107
components/mbColorLib/CIEAColorPicker.pas
View File

@ -13,24 +13,18 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, SelPropUtils, mbColorPickerControl, RGBCIEUtils, Scanlines;
HTMLColors, RGBCIEUtils, mbColorPickerControl;
type
TCIEAColorPicker = class(TmbColorPickerControl)
private
FSelected: TColor;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FL, FA, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer;
procedure SetLValue(l: integer);
procedure SetAValue(a: integer);
procedure SetBValue(b: integer);
protected
function GetSelectedColor: TColor; override;
procedure WebSafeChanged; override;
function GetGradientColor2D(x, y: Integer): TColor; override;
procedure SetSelectedColor(c: TColor); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
@ -39,24 +33,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer);
procedure Paint; override;
procedure CreateLABGradient;
procedure Resize; override;
procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property SelectedColor default clFuchsia;
property LValue: integer read FL write SetLValue default 100;
property AValue: integer read FA write SetAValue default 127;
property BValue: integer read FB write SetBValue default -128;
property MarkerStyle default msCircle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChange;
end;
procedure Register;
@ -67,6 +55,9 @@ implementation
{$R CIEAColorPicker.dcr}
{$ENDIF}
uses
mbUtils;
procedure Register;
begin
RegisterComponents('mbColor Lib', [TCIEAColorPicker]);
@ -77,11 +68,19 @@ end;
constructor TCIEAColorPicker.Create(AOwner: TComponent);
begin
inherited;
{
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.SetSize(256, 256);
}
FGradientWidth := 256;
FGradientHeight := 256;
{$IFDEF DELPHI}
Width := 256;
Height := 256;
{$ELSE}
SetInitialBounds(0, 0, 256, 256);
{$ENDIF}
HintFormat := 'L: %cieL B: %cieB'#13'Hex: %hex';
FSelected := clFuchsia;
FL := 100;
@ -95,48 +94,23 @@ begin
MarkerStyle := msCircle;
end;
destructor TCIEAColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
end;
procedure TCIEAColorPicker.CreateWnd;
begin
inherited;
CreateLABGradient;
CreateGradient;
end;
procedure TCIEAColorPicker.CreateLABGradient;
var
l, b: integer;
row: pRGBQuadArray;
// In the original code: for L ... for B ... LabToRGB(Round(100-L*100/255), FA, B-128);
// --> x is B, y is L
function TCIEAColorPicker.GetGradientColor2D(x, y: Integer): TColor;
begin
if FBmp = nil then
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;
Result := LabToRGB(Round(100 - y*100/255), FA, x - 128);
end;
procedure TCIEAColorPicker.CorrectCoords(var x, y: integer);
begin
if x < 0 then x := 0;
if y < 0 then y := 0;
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
Clamp(x, 0, Width - 1);
Clamp(y, 0, Height - 1);
end;
procedure TCIEAColorPicker.DrawMarker(x, y: integer);
@ -155,17 +129,7 @@ begin
c := clBlack
else
c := clWhite;
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;
function TCIEAColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
InternalDrawMarker(x, y, c);
end;
procedure TCIEAColorPicker.SetSelectedColor(c: TColor);
@ -178,13 +142,13 @@ begin
FManual := false;
mxx := Round((FB+128)*(Width/255));
myy := Round(((100-FL)*255/100)*(Height/255));
CreateLABGradient;
CreateGradient;
Invalidate;
end;
procedure TCIEAColorPicker.Paint;
begin
Canvas.StretchDraw(ClientRect, FBmp);
Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy);
DrawMarker(mxx, myy);
end;
@ -344,38 +308,23 @@ end;
procedure TCIEAColorPicker.SetLValue(l: integer);
begin
if l > 100 then l := 100;
if l < 0 then l := 0;
FL := l;
Clamp(L, 0, 100);
FL := L;
SetSelectedColor(LabToRGB(FL, FA, FB));
end;
procedure TCIEAColorPicker.SetAValue(a: integer);
begin
if a > 127 then a := 127;
if a < -128 then a := -128;
Clamp(a, -128, 127);
FA := a;
SetSelectedColor(LabToRGB(FL, FA, FB));
end;
procedure TCIEAColorPicker.SetBValue(b: integer);
begin
if b > 127 then b := 127;
if b < -128 then b := -128;
Clamp(b, -128, 127);
FB := b;
SetSelectedColor(LabToRGB(FL, FA, FB));
end;
function TCIEAColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure TCIEAColorPicker.WebSafeChanged;
begin
inherited;
CreateLABGradient;
Invalidate;
end;
end.

117
components/mbColorLib/CIEBColorPicker.pas
View File

@ -13,24 +13,21 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, SelPropUtils, mbColorPickerControl, RGBCIEUtils, Scanlines;
HTMLColors, RGBCIEUtils, mbColorPickerControl;
type
{ TCIEBColorPicker }
TCIEBColorPicker = class(TmbColorPickerControl)
private
FSelected: TColor;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FL, FA, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer;
procedure SetLValue(l: integer);
procedure SetAValue(a: integer);
procedure SetBValue(b: integer);
protected
function GetSelectedColor: TColor; override;
procedure WebSafeChanged; override;
function GetGradientColor2D(x, y: Integer): TColor; override;
procedure SetSelectedColor(c: TColor); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
@ -39,24 +36,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer);
procedure Paint; override;
procedure CreateLABGradient;
procedure Resize; override;
procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property SelectedColor default clLime;
property LValue: integer read FL write SetLValue default 100;
property AValue: integer read FA write SetAValue default -128;
property BValue: integer read FB write SetBValue default 127;
property MarkerStyle default msCircle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChange;
end;
procedure Register;
@ -67,6 +58,9 @@ implementation
{$R CIEBColorPicker.dcr}
{$ENDIF}
uses
mbUtils;
procedure Register;
begin
RegisterComponents('mbColor Lib', [TCIEBColorPicker]);
@ -77,11 +71,14 @@ end;
constructor TCIEBColorPicker.Create(AOwner: TComponent);
begin
inherited;
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.SetSize(256, 256);
FGradientWidth := 256;
FGradientHeight := 256;
{$IFDEF DELPHI}
Width := 256;
Height := 256;
{$ELSE}
SetInitialBounds(0, 0, 256, 256);
{$ENDIF}
HintFormat := 'L: %cieL A: %cieA'#13'Hex: %hex';
FSelected := clLime;
FL := 100;
@ -95,48 +92,23 @@ begin
MarkerStyle := msCircle;
end;
destructor TCIEBColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
end;
procedure TCIEBColorPicker.CreateWnd;
begin
inherited;
CreateLABGradient;
CreateGradient;
end;
procedure TCIEBColorPicker.CreateLABGradient;
var
l, a: integer;
row: pRGBQuadArray;
{ In the original code: for L ... for A ... LabToRGB(Round(100-L*100/244), A-128, FB)
--> x is A, y is L}
function TCIEBColorPicker.GetGradientColor2D(x, y: Integer): TColor;
begin
if FBmp = nil then
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;
Result := LabToRGB(Round(100 - y*100/255), x - 128, FB);
end;
procedure TCIEBColorPicker.CorrectCoords(var x, y: integer);
begin
if x < 0 then x := 0;
if y < 0 then y := 0;
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
Clamp(x, 0, Width - 1);
Clamp(y, 0, Height - 1);
end;
procedure TCIEBColorPicker.DrawMarker(x, y: integer);
@ -155,17 +127,7 @@ begin
c := clBlack
else
c := clWhite;
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;
function TCIEBColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
InternalDrawMarker(x, y, c);
end;
procedure TCIEBColorPicker.SetSelectedColor(c: TColor);
@ -178,13 +140,13 @@ begin
FManual := false;
mxx := Round((FA+128)*(Width/255));
myy := Round(((100-FL)*255/100)*(Height/255));
CreateLABGradient;
CreateGradient;
Invalidate;
end;
procedure TCIEBColorPicker.Paint;
begin
Canvas.StretchDraw(ClientRect, FBmp);
Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy);
DrawMarker(mxx, myy);
end;
@ -192,8 +154,8 @@ end;
procedure TCIEBColorPicker.Resize;
begin
FManual := false;
mxx := Round((FA+128)*(Width/255));
myy := Round(((100-FL)*255/100)*(Height/255));
mxx := Round((FA + 128) * (Width / 255));
myy := Round(((100 - FL) * 255 / 100) * (Height / 255));
inherited;
end;
@ -342,40 +304,25 @@ begin
OnKeyDown(Self, Message.CharCode, Shift);
end;
procedure TCIEBColorPicker.SetLValue(l: integer);
procedure TCIEBColorPicker.SetLValue(L: integer);
begin
if l > 100 then l := 100;
if l < 0 then l := 0;
FL := l;
Clamp(L, 0, 100);
FL := L;
SetSelectedColor(LabToRGB(FL, FA, FB));
end;
procedure TCIEBColorPicker.SetAValue(a: integer);
begin
if a > 127 then a := 127;
if a < -128 then a := -128;
Clamp(a, -128, 127);
FA := a;
SetSelectedColor(LabToRGB(FL, FA, FB));
end;
procedure TCIEBColorPicker.SetBValue(b: integer);
begin
if b > 127 then b := 127;
if b < -128 then b := -128;
Clamp(b, -128, 127);
FB := b;
SetSelectedColor(LabToRGB(FL, FA, FB));
end;
function TCIEBColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure TCIEBColorPicker.WebSafeChanged;
begin
inherited;
CreateLABGradient;
Invalidate;
end;
end.

109
components/mbColorLib/CIELColorPicker.pas
View File

@ -13,24 +13,18 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, SelPropUtils, mbColorPickerControl, RGBCIEUtils, Scanlines;
HTMLColors, RGBCIEUtils, mbColorPickerControl;
type
TCIELColorPicker = class(TmbColorPickerControl)
private
FSelected: TColor;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FL, FA, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer;
procedure SetLValue(l: integer);
procedure SetAValue(a: integer);
procedure SetBValue(b: integer);
protected
function GetSelectedColor: TColor; override;
procedure WebSafeChanged; override;
function GetGradientColor2D(x, y: Integer): TColor; override;
procedure SetSelectedColor(c: TColor); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
@ -39,24 +33,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer);
procedure Paint; override;
procedure CreateLABGradient;
procedure Resize; override;
procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property SelectedColor default clAqua;
property LValue: integer read FL write SetLValue default 100;
property AValue: integer read FA write SetAValue default -128;
property BValue: integer read FB write SetBValue default 127;
property MarkerStyle default msCircle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChange;
end;
procedure Register;
@ -67,6 +55,9 @@ implementation
{$R CIELColorPicker.dcr}
{$ENDIF}
uses
mbUtils;
procedure Register;
begin
RegisterComponents('mbColor Lib', [TCIELColorPicker]);
@ -77,11 +68,14 @@ end;
constructor TCIELColorPicker.Create(AOwner: TComponent);
begin
inherited;
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.SetSize(256, 256);
FGradientWidth := 256;
FGradientHeight := 256;
{$IFDEF DELPHI}
Width := 256;
Height := 256;
{$ELSE}
SetInitialBounds(0, 0, 256, 256);
{$ENDIF}
HintFormat := 'A: %cieA B: %cieB'#13'Hex: %hex';
FSelected := clAqua;
FL := 100;
@ -95,50 +89,22 @@ begin
MarkerStyle := msCircle;
end;
destructor TCIELColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
end;
procedure TCIELColorPicker.CreateWnd;
begin
inherited;
CreateLABGradient;
CreateGradient;
end;
procedure TCIELColorPicker.CreateLABGradient;
var
a, b: integer;
row: pRGBQuadArray;
{ Original code: for A ... for B ---> LabToRGB(FL, A - 128, B - 128) }
function TCIELColorPicker.GetGradientColor2D(x, y: Integer): TColor;
begin
if FBmp = nil then
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;
Result := LabToRGB(FL, y - 128, x - 128);
end;
procedure TCIELColorPicker.CorrectCoords(var x, y: integer);
begin
if x < 0 then x := 0;
if y < 0 then y := 0;
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
Clamp(x, 0, Width - 1);
clamp(y, 0, Height - 1);
end;
procedure TCIELColorPicker.DrawMarker(x, y: integer);
@ -157,17 +123,7 @@ begin
c := clBlack
else
c := clWhite;
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;
function TCIELColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
InternalDrawMarker(x, y, c);
end;
procedure TCIELColorPicker.SetSelectedColor(c: TColor);
@ -180,13 +136,13 @@ begin
FManual := false;
mxx := Round((FA+128)*(Width/255));
myy := Round((255-(FB+128))*(Height/255));
CreateLABGradient;
CreateGradient;
Invalidate;
end;
procedure TCIELColorPicker.Paint;
begin
Canvas.StretchDraw(ClientRect, FBmp);
Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy);
DrawMarker(mxx, myy);
end;
@ -346,38 +302,23 @@ end;
procedure TCIELColorPicker.SetLValue(l: integer);
begin
if l > 100 then l := 100;
if l < 0 then l := 0;
FL := l;
Clamp(L, 0, 100);
FL := L;
SetSelectedColor(LabToRGB(FL, FA, FB));
end;
procedure TCIELColorPicker.SetAValue(a: integer);
begin
if a > 127 then a := 127;
if a < -128 then a := -128;
Clamp(A, -128, 127);
FA := a;
SetSelectedColor(LabToRGB(FL, FA, FB));
end;
procedure TCIELColorPicker.SetBValue(b: integer);
begin
if b > 127 then b := 127;
if b < -128 then b := -128;
Clamp(b, -128, 127);
FB := b;
SetSelectedColor(LabToRGB(FL, FA, FB));
end;
function TCIELColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure TCIELColorPicker.WebSafeChanged;
begin
inherited;
CreateLABGradient;
Invalidate;
end;
end.

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

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

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

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

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

@ -16,7 +16,16 @@ uses
mbColorTree, mbColorList {for internet shortcuts};
type
{ TForm1 }
TForm1 = class(TForm)
Label10: TLabel;
Label11: TLabel;
Label12: TLabel;
Label13: TLabel;
Label14: TLabel;
Label15: TLabel;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;

115
components/mbColorLib/GAxisColorPicker.pas
View File

@ -13,24 +13,18 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines;
HTMLColors, mbColorPickerControl;
type
TGAxisColorPicker = class(TmbColorPickerControl)
private
FSelected: TColor;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FR, FG, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer;
procedure SetRValue(r: integer);
procedure SetGValue(g: integer);
procedure SetBValue(b: integer);
protected
function GetSelectedColor: TColor; override;
procedure WebSafeChanged; override;
function GetGradientColor2D(x, y: Integer): TColor; override;
procedure SetSelectedColor(c: TColor); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
@ -39,24 +33,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer);
procedure Paint; override;
procedure CreateRGBGradient;
procedure Resize; override;
procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property SelectedColor default clLime;
property RValue: integer read FR write SetRValue default 0;
property GValue: integer read FG write SetGValue default 255;
property BValue: integer read FB write SetBValue default 0;
property MarkerStyle default msCircle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChange;
end;
procedure Register;
@ -67,6 +55,9 @@ implementation
{$R GAxisColorPicker.dcr}
{$ENDIF}
uses
mbUtils;
procedure Register;
begin
RegisterComponents('mbColor Lib', [TGAxisColorPicker]);
@ -77,11 +68,14 @@ end;
constructor TGAxisColorPicker.Create(AOwner: TComponent);
begin
inherited;
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.SetSize(256, 256);
FGradientWidth := 256;
FGradientHeight := 256;
{$IFDEF DELPHI}
Width := 256;
Height := 256;
{$ELSE}
SetInitialBounds(0, 0, 256, 256);
{$ENDIF}
HintFormat := 'R: %r B: %b'#13'Hex: %hex';
FG := 255;
FB := 0;
@ -95,47 +89,21 @@ begin
MarkerStyle := msCircle;
end;
destructor TGAxisColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
end;
procedure TGAxisColorPicker.CreateWnd;
begin
inherited;
CreateRGBGradient;
CreateGradient;
end;
procedure TGAxisColorPicker.CreateRGBGradient;
var
r, b : integer;
row: pRGBQuadArray;
function TGAxisColorPicker.GetGradientColor2D(x, y: Integer): TColor;
begin
if FBmp = nil then
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;
Result := RGB(FGradientBmp.Height - 1 - y, FG, x);
end;
procedure TGAxisColorPicker.CorrectCoords(var x, y: integer);
begin
if x < 0 then x := 0;
if y < 0 then y := 0;
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
Clamp(x, 0, Width-1);
Clamp(y, 0, Height-1);
end;
procedure TGAxisColorPicker.DrawMarker(x, y: integer);
@ -154,17 +122,7 @@ begin
c := clBlack
else
c := clWhite;
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;
function TGAxisColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
InternalDrawMarker(x, y, c);
end;
procedure TGAxisColorPicker.SetSelectedColor(c: TColor);
@ -177,13 +135,13 @@ begin
FManual := false;
myy := Round((255-FR)*(Height/255));
mxx := Round(FB*(Width/255));
CreateRGBGradient;
CreateGradient;
Invalidate;
end;
procedure TGAxisColorPicker.Paint;
begin
Canvas.StretchDraw(ClientRect, FBmp);
Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy);
DrawMarker(mxx, myy);
end;
@ -224,9 +182,9 @@ begin
{$IFDEF DELPHI}
ClipCursor(nil);
{$ENDIF}
mxx := x;
myy := y;
FSelected := GetColorAtPoint(x, y);
mxx := X;
myy := Y;
FSelected := GetColorAtPoint(X, Y);
FManual := true;
Invalidate;
end;
@ -236,9 +194,9 @@ begin
inherited;
if ssLeft in Shift then
begin
mxx := x;
myy := y;
FSelected := GetColorAtPoint(x, y);
mxx := X;
myy := Y;
FSelected := GetColorAtPoint(X, Y);
FManual := true;
Invalidate;
end;
@ -343,38 +301,23 @@ end;
procedure TGAxisColorPicker.SetRValue(r: integer);
begin
if r > 255 then r := 255;
if r < 0 then r := 0;
Clamp(r, 0, 255);
FR := r;
SetSelectedColor(RGB(FR, FG, FB));
end;
procedure TGAxisColorPicker.SetGValue(g: integer);
begin
if g > 255 then g := 255;
if g < 0 then g := 0;
Clamp(g, 0, 255);
FG := g;
SetSelectedColor(RGB(FR, FG, FB));
end;
procedure TGAxisColorPicker.SetBValue(b: integer);
begin
if b > 255 then b := 255;
if b < 0 then b := 0;
Clamp(b, 0, 255);
FB := b;
SetSelectedColor(RGB(FR, FG, FB));
end;
function TGAxisColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure TGAxisColorPicker.WebSafeChanged;
begin
inherited;
CreateRGBGradient;
Invalidate;
end;
end.

10
components/mbColorLib/HColorPicker.pas
View File

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

248
components/mbColorLib/HRingPicker.pas
View File

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

144
components/mbColorLib/HSColorPicker.pas
View File

@ -13,24 +13,22 @@ uses
Windows, Messages, Scanlines,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
RGBHSLUtils, HTMLColors, SelPropUtils, mbColorPickerControl;
RGBHSLUtils, HTMLColors, mbColorPickerControl;
type
{ THSColorPicker }
THSColorPicker = class(TmbColorPickerControl)
private
FSelected: TColor;
FHSLBmp: TBitmap;
FOnChange: TNotifyEvent;
FHue, FSaturation, FLuminance: integer;
FLum: integer;
FManual: boolean;
dx, dy, mxx, myy: integer;
procedure SetHValue(h: integer);
procedure SetSValue(s: integer);
protected
function GetSelectedColor: TColor; override;
procedure WebSafeChanged; override;
procedure CorrectCoords(var x, y: integer);
function GetGradientColor2D(X, Y: Integer): TColor; override;
procedure SetSelectedColor(c: TColor); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
@ -39,25 +37,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer);
procedure Paint; override;
procedure CreateHSLGradient;
procedure Resize; override;
procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer);
function PredictColor: TColor;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Lum: integer read FLum write FLum default 120;
property Manual: boolean read FManual;
published
property SelectedColor default clRed;
property HueValue: integer read FHue write SetHValue default 0;
property SaturationValue: integer read FSaturation write SetSValue default 240;
property MarkerStyle default msCross;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChange;
end;
procedure Register;
@ -66,10 +57,10 @@ implementation
{$IFDEF FPC}
{$R HSColorPicker.dcr}
{$ENDIF}
uses
IntfGraphics, fpimage;
{$ENDIF}
mbUtils;
procedure Register;
begin
@ -81,11 +72,14 @@ end;
constructor THSColorPicker.Create(AOwner: TComponent);
begin
inherited;
FHSLBmp := TBitmap.Create;
FHSLBmp.PixelFormat := pf32bit;
FHSLBmp.SetSize(240, 241);
FGradientWidth := 240;
FGradientHeight := 241;
{$IFDEF DELPHI}
Width := 239;
Height := 240;
{$ELSE}
SetInitialBounds(0, 0, 239, 240);
{$ENDIF}
HintFormat := 'H: %h S: %hslS'#13'Hex: %hex';
FHue := 0;
FSaturation := 240;
@ -100,85 +94,21 @@ begin
MarkerStyle := msCross;
end;
destructor THSColorPicker.Destroy;
begin
FHSLBmp.Free;
inherited Destroy;
end;
procedure THSColorPicker.CreateWnd;
begin
inherited;
CreateHSLGradient;
CreateGradient;
end;
{$IFDEF DELPHI}
procedure THSColorPicker.CreateHSLGradient;
var
Hue, Sat : integer;
row: pRGBQuadArray;
function THSColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
begin
if FHSLBmp = nil then
begin
FHSLBmp := TBitmap.Create;
FHSLBmp.PixelFormat := pf32bit;
FHSLBmp.Width := 240;
FHSLBmp.Height := 241;
end;
for Hue := 0 to 239 do
for Sat := 0 to 240 do
begin
row := FHSLBmp.ScanLine[240 - Sat];
if not WebSafe then
row[Hue] := RGBToRGBQuad(HSLRangeToRGB(Hue, Sat, 120))
// FHSLBmp.Canvas.Pixels[Hue, 240 - Sat] := HSLRangeToRGB(Hue, Sat, 120)
else
row[Hue] := RGBToRGBQuad(GetWebSafe(HSLRangeToRGB(Hue, Sat, 120)));
// FHSLBmp.Canvas.Pixels[Hue, 240 - Sat] := GetWebSafe(HSLRangeToRGB(Hue, Sat, 120));
end;
Result := HSLRangeToRGB(x, FGradientBmp.Height - 1 - y, 120);
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);
begin
if x < 0 then x := 0;
if y < 0 then y := 0;
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
Clamp(x, 0, Width - 1);
Clamp(y, 0, Height - 1);
end;
procedure THSColorPicker.DrawMarker(x, y: integer);
@ -195,17 +125,7 @@ begin
c := clBlack
else
c := clWhite;
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;
function THSColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
InternalDrawMarker(x, y, c);
end;
procedure THSColorPicker.SetSelectedColor(c: TColor);
@ -221,7 +141,7 @@ end;
procedure THSColorPicker.Paint;
begin
Canvas.StretchDraw(ClientRect, FHSLBmp);
Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy);
DrawMarker(mxx, myy);
end;
@ -387,30 +307,16 @@ end;
procedure THSColorPicker.SetHValue(h: integer);
begin
if h > 239 then h := 239;
if h < 0 then h := 0;
Clamp(h, 0, 239);
FHue := h;
SetSelectedColor(HSLRangeToRGB(FHue, FSaturation, 120));
SetSelectedColor(HSLRangeToRGB(FHue, FSaturation, 120)); // why hard-coded 120?
end;
procedure THSColorPicker.SetSValue(s: integer);
begin
if s > 240 then s := 240;
if s < 0 then s := 0;
Clamp(s, 0, 240);
FSaturation := s;
SetSelectedColor(HSLRangeToRGB(FHue, FSaturation, 120));
end;
function THSColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure THSColorPicker.WebSafeChanged;
begin
inherited;
CreateHSLGradient;
Invalidate;
end;
end.

33
components/mbColorLib/HSLRingPicker.pas
View File

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

303
components/mbColorLib/HSVColorPicker.pas
View File

@ -13,8 +13,8 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, RGBHSVUtils, Scanlines,
Forms, {IFDEF DELPHI_7_UP Themes, $ENDIF} HTMLColors, SelPropUtils,
mbColorPickerControl;
Forms, {$IFDEF DELPHI_7_UP}Themes,{$ENDIF}
HTMLColors, mbColorPickerControl;
type
THSVColorPicker = class(TmbColorPickerControl)
@ -22,16 +22,11 @@ type
FHue, FSat, FValue: integer;
FSatCircColor, FHueLineColor: TColor;
FSelectedColor: TColor;
FOnChange: TNotifyEvent;
FManual: boolean;
FShowSatCirc: boolean;
FShowHueLine: boolean;
FShowSelCirc: boolean;
Fchange: boolean;
FHSVBmp: TBitmap;
FChange: boolean;
FDoChange: boolean;
procedure CreateHSVCircle;
function RadHue(New: integer): integer;
procedure SetValue(V: integer);
procedure SetHue(h: integer);
@ -47,9 +42,10 @@ type
procedure SetShowHueLine(s: boolean);
procedure UpdateCoords;
protected
procedure CreateGradient; override;
function GetGradientColor2D(X, Y: Integer): TColor; override;
function GetSelectedColor: TColor; override;
procedure SetSelectedColor(c: TColor); override;
procedure WebSafeChanged; override;
procedure Paint; override;
procedure Resize; override;
procedure CreateWnd; override;
@ -60,10 +56,7 @@ type
message CN_KEYDOWN;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property Hue: integer read FHue write SetHue 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 ShowSelectionCircle: boolean read FShowSelCirc write SetShowSelCirc default true;
property MarkerStyle default msCrossCirc;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChange;
end;
procedure Register;
@ -85,31 +77,28 @@ implementation
{$IFDEF FPC}
{$R HSVColorPicker.dcr}
{$ENDIF}
uses
IntfGraphics, fpimage;
{$ENDIF}
mbUtils;
procedure Register;
begin
RegisterComponents('mbColor Lib', [THSVColorPicker]);
end;
function PointInCirc(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;
{ THSVColorPicker }
constructor THSVColorPicker.Create(AOwner: TComponent);
begin
inherited;
FHSVBmp := TBitmap.Create;
FHSVBmp.PixelFormat := pf32bit;
{$IFDEF DELPHI}
Width := 204;
Height := 204;
{$ELSE}
SetInitialBounds(0, 0, 204, 204);
{$ENDIF}
FValue := 255;
FHue := 0;
FSat := 0;
@ -120,17 +109,11 @@ begin
FShowSatCirc := true;
FShowHueLine := true;
FShowSelCirc := true;
Fchange := true;
FChange := true;
FDoChange := false;
MarkerStyle := msCrossCirc;
end;
destructor THSVColorPicker.Destroy;
begin
FHSVBmp.Free;
inherited;
end;
procedure THSVColorPicker.Paint;
var
rgn: HRGN;
@ -140,9 +123,10 @@ begin
R := ClientRect;
R.Right := R.Left + Min(Width, Height);
R.Bottom := R.Top + Min(Width, Height);
InflateRect(R, -1, -1); // Avoid spurious black pixels at the border
rgn := CreateEllipticRgnIndirect(R);
SelectClipRgn(Canvas.Handle, rgn);
Canvas.Draw(0, 0, FHSVBmp);
Canvas.Draw(0, 0, FGradientBmp);
DeleteObject(rgn);
DrawSatCirc;
DrawHueLine;
@ -154,155 +138,109 @@ begin
end;
end;
procedure THSVColorPicker.CreateHSVCircle;
var
dSquared, H, S, V, i, j, radius, radiusSquared, x, y, size: integer;
row: pRGBQuadArray;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
procedure THSVColorPicker.CreateGradient;
begin
if FHSVBmp = nil then
begin
FHSVBmp := TBitmap.Create;
FHSVBmp.PixelFormat := pf32bit;
end;
size := Min(Width, Height);
FHSVBmp.Width := size;
FHSVBmp.Height := size;
PaintParentBack(FHSVBmp.Canvas);
FGradientWidth := Min(Width, Height);
FGradientHeight := FGradientWidth;
inherited;
end;
{ Outer loop: Y, Inner loop: X }
function THSVColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
var
xcoord, ycoord: Integer;
dSq, radiusSq: Integer;
radius, size: Integer;
S, H, V: Integer;
q: TRGBQuad;
begin
size := FGradientWidth; // or Height, they are the same...
radius := size div 2;
radiusSquared := radius * radius;
V := FValue;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(FHSVBmp.Width, FHSVBmp.Height);
try
intfImg.LoadFromBitmap(FHSVBmp.Handle, FHSVBmp.MaskHandle);
{$ENDIF}
for j := 0 to size - 1 do
radiusSq := sqr(radius);
xcoord := X - radius;
ycoord := Y - radius;
dSq := sqr(xcoord) + sqr(ycoord);
if dSq <= radiusSq then
begin
Y := size - 1 - j - Radius;
{$IFDEF FPC}
row := intfImg.GetDataLineStart(size - 1 - j);
{$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)
if radius <> 0 then
S := round((255 * sqrt(dSq)) / radius)
//S := trunc((255 * sqrt(dSq)) / radius)
else
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;
if H > 360 then H := H - 360;
{$IFDEF FPC}
c := HSVtoColor(H, S, V);
Result := HSVtoColor(H, S, FValue);
if WebSafe then
c := GetWebSafe(c);
row^[i].rgbRed := GetRValue(c);
row^[i].rgbGreen := GetGValue(c);
row^[i].rgbBlue := GetBValue(c);
{$ELSE}
if not WebSafe then
row[i] := HSVtoRGBQuad(H,S,V)
else
begin
c := GetWebSafe(HSVtoColor(H, S, V));
row[i] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
end;
{$ENDIF}
end;
end;
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FHSVBmp.Handle := imgHandle;
FHSVBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
{$ENDIF}
Result := GetWebSafe(Result);
end else
Result := GetDefaultColor(dctBrush);
end;
procedure THSVColorPicker.Resize;
begin
inherited;
CreateHSVCircle;
CreateGradient;
UpdateCoords;
end;
procedure THSVColorPicker.CreateWnd;
begin
inherited;
CreateHSVCircle;
CreateGradient;
UpdateCoords;
end;
procedure THSVColorPicker.UpdateCoords;
var
r, angle: real;
r, angle: double;
sinAngle, cosAngle: Double;
radius: integer;
begin
radius := Min(Width, Height) div 2;
r := -MulDiv(radius, FSat, 255);
angle := -FHue*PI/180 - PI;
mdx := ROUND(COS(angle)*ROUND(r)) + radius;
mdy := ROUND(SIN(angle)*ROUND(r)) + radius;
angle := -FHue* pi / 180 - PI;
SinCos(angle, sinAngle, cosAngle);
mdx := round(cosAngle * r) + radius;
mdy := round(sinAngle * r) + radius;
end;
procedure THSVColorPicker.SetHue(h: integer);
begin
if h > 360 then h := 360;
if h < 0 then h := 0;
Clamp(h, 0, 360);
if FHue <> h then
begin
FHue := h;
FManual := false;
UpdateCoords;
Invalidate;
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure THSVColorPicker.SetSat(s: integer);
begin
if s > 255 then s := 255;
if s < 0 then s := 0;
Clamp(s, 0, 255);
if FSat <> s then
begin
FSat := s;
FManual := false;
UpdateCoords;
Invalidate;
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure THSVColorPicker.SetValue(V: integer);
begin
if V > 255 then V := 255;
if V < 0 then V := 0;
Clamp(V, 0, 255);
if FValue <> V then
begin
FValue := V;
FManual := false;
CreateHSVCircle;
CreateGradient;
Invalidate;
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
@ -354,32 +292,36 @@ end;
procedure THSVColorPicker.DrawSatCirc;
var
delta: integer;
Radius: integer;
radius: integer;
begin
if not FShowSatCirc then Exit;
if FSat in [1..254] then
if not FShowSatCirc then
exit;
if (FSat > 0) and (FSat < 255) then
begin
Radius:= Min(Width, Height) div 2;
radius := Min(Width, Height) div 2;
Canvas.Pen.Color := FSatCircColor;
Canvas.Brush.Style := bsClear;
delta := MulDiv(Radius, FSat, 255);
Canvas.Ellipse(Radius - delta, Radius - delta, Radius + delta, Radius + delta);
delta := MulDiv(radius, FSat, 255);
Canvas.Ellipse(radius - delta, radius - delta, radius + delta, radius + delta);
end;
end;
procedure THSVColorPicker.DrawHueLine;
var
angle: double;
sinAngle, cosAngle: Double;
radius: integer;
begin
if not FShowHueLine then Exit;
Radius := Min(Width, Height) div 2;
if not FShowHueLine then
exit;
radius := Min(Width, Height) div 2;
if (FHue >= 0) and (FHue <= 360) then
begin
Angle := -FHue*PI/180;
angle := -FHue * pi / 180;
SinCos(angle, sinAngle, cosAngle);
Canvas.Pen.Color := FHueLineColor;
Canvas.MoveTo(Radius,Radius);
Canvas.LineTo(Radius + Round(Radius*COS(angle)), Radius + Round(Radius*SIN(angle)));
Canvas.MoveTo(radius, radius);
Canvas.LineTo(radius + round(radius*cosAngle), radius + round(radius*sinAngle));
end;
end;
@ -387,45 +329,44 @@ procedure THSVColorPicker.DrawMarker(x, y: integer);
var
c: TColor;
begin
if not FShowSelCirc then Exit;
if not FShowSelCirc then
exit;
if Focused or (csDesigning in ComponentState) then
c := clBlack
else
c := clGray;
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;
InternalDrawMarker(x, y, c);
end;
procedure THSVColorPicker.SelectionChanged(x, y: integer);
var
Angle, Distance, xDelta, yDelta, Radius: integer;
angle, distance, xDelta, yDelta, radius: integer;
begin
if not PointInCirc(Point(x, y), Min(Width, Height)) then
if not PointInCircle(Point(x, y), Min(Width, Height)) then
begin
FChange := false;
SetSelectedColor(clNone);
FChange := true;
Exit;
exit;
end
else
FSelectedColor := clWhite;
Radius := Min(Width, Height) div 2;
xDelta := x - Radius;
yDelta := y - Radius;
Angle := ROUND(360 + 180*ArcTan2(-yDelta,xDelta)/PI);
if Angle < 0 then Inc(Angle, 360)
else if Angle > 360 then
Dec(Angle, 360);
Fchange := false;
radius := Min(Width, Height) div 2;
xDelta := x - radius;
yDelta := y - radius;
angle := round(360 + 180*arctan2(-yDelta, xDelta) / pi);
if angle < 0 then
inc(angle, 360)
else if angle > 360 then
dec(angle, 360);
FChange := false;
SetHue(Angle);
Distance := ROUND(SQRT(SQR(xDelta) + SQR(yDelta)));
if Distance >= Radius then SetSat(255)
else SetSat(MulDiv(Distance, 255, Radius));
Fchange := true;
distance := round(sqrt(sqr(xDelta) + sqr(yDelta)));
if distance >= radius then
SetSat(255)
else
SetSat(MulDiv(distance, 255, radius));
FChange := true;
end;
procedure THSVColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
@ -435,8 +376,9 @@ begin
{$IFDEF DELPHI}
ClipCursor(nil);
{$ENDIF}
if csDesigning in ComponentState then Exit;
if (Button = mbLeft) and PointInCirc(Point(x, y), Min(Width, Height)) then
if csDesigning in ComponentState then
exit;
if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then
begin
mdx := x;
mdy := y;
@ -452,8 +394,9 @@ var
R: TRect;
begin
inherited;
if csDesigning in ComponentState then Exit;
if (Button = mbLeft) and PointInCirc(Point(x, y), Min(Width, Height)) then
if csDesigning in ComponentState then
exit;
if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then
begin
mdx := x;
mdy := y;
@ -474,8 +417,9 @@ end;
procedure THSVColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
if csDesigning in ComponentState then Exit;
if (ssLeft in Shift) and PointInCirc(Point(x, y), Min(Width, Height)) then
if csDesigning in ComponentState then
exit;
if (ssLeft in Shift) and PointInCircle(Point(x, y), Min(Width, Height)) then
begin
mdx := x;
mdy := y;
@ -500,21 +444,24 @@ end;
function THSVColorPicker.GetColorAtPoint(x, y: integer): TColor;
var
Angle, Distance, xDelta, yDelta, Radius: integer;
angle, distance, xDelta, yDelta, radius: integer;
h, s: integer;
begin
Radius := Min(Width, Height) div 2;
radius := Min(Width, Height) div 2;
xDelta := x - Radius;
yDelta := y - Radius;
Angle := ROUND(360 + 180*ArcTan2(-yDelta,xDelta)/PI);
if Angle < 0 then Inc(Angle, 360)
else if Angle > 360 then
Dec(Angle, 360);
h := Angle;
Distance := ROUND(SQRT(SQR(xDelta) + SQR(yDelta)));
if Distance >= Radius then s := 255
else s := MulDiv(Distance, 255, Radius);
if PointInCirc(Point(mx, my), Min(Width, Height)) then
angle := round(360 + 180*arctan2(-yDelta, xDelta) / pi);
if angle < 0 then
inc(angle, 360)
else if angle > 360 then
dec(angle, 360);
h := angle;
distance := round(sqrt(sqr(xDelta) + sqr(yDelta)));
if distance >= radius then
s := 255
else
s := MulDiv(distance, 255, radius);
if PointInCircle(Point(mx, my), Min(Width, Height)) then
begin
if not WebSafe then
Result := HSVtoColor(h, s, FValue)
@ -537,9 +484,8 @@ begin
SetHue(GetHValue(c));
SetSat(GetSValue(c));
FSelectedColor := c;
Fchange := changeSave;
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
FChange := changeSave;
if FChange and Assigned(FOnChange) then FOnChange(Self);
FChange := true;
end;
@ -647,11 +593,4 @@ begin
OnKeyDown(Self, Message.CharCode, Shift);
end;
procedure THSVColorPicker.WebSafeChanged;
begin
inherited;
CreateHSVCircle;
Invalidate;
end;
end.

106
components/mbColorLib/RAxisColorPicker.pas
View File

@ -13,24 +13,18 @@ uses
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines;
HTMLColors, mbColorPickerControl;
type
TRAxisColorPicker = class(TmbColorPickerControl)
private
FSelected: TColor;
FBmp: TBitmap;
FOnChange: TNotifyEvent;
FR, FG, FB: integer;
FManual: boolean;
dx, dy, mxx, myy: integer;
procedure SetRValue(r: integer);
procedure SetGValue(g: integer);
procedure SetBValue(b: integer);
protected
function GetSelectedColor: TColor; override;
procedure WebSafeChanged; override;
function GetGradientColor2D(x, y: Integer): TColor; override;
procedure SetSelectedColor(c: TColor); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
@ -39,24 +33,18 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure DrawMarker(x, y: integer);
procedure Paint; override;
procedure CreateRGBGradient;
procedure Resize; override;
procedure CreateWnd; override;
procedure CorrectCoords(var x, y: integer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property SelectedColor default clRed;
property RValue: integer read FR write SetRValue default 255;
property GValue: integer read FG write SetGValue default 0;
property BValue: integer read FB write SetBValue default 0;
property MarkerStyle default msCircle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChange;
end;
procedure Register;
@ -67,6 +55,9 @@ implementation
{$R RAxisColorPicker.dcr}
{$ENDIF}
uses
mbUtils;
procedure Register;
begin
RegisterComponents('mbColor Lib', [TRAxisColorPicker]);
@ -77,11 +68,14 @@ end;
constructor TRAxisColorPicker.Create(AOwner: TComponent);
begin
inherited;
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.SetSize(256, 256);
FGradientWidth := 256;
FGradientHeight := 256;
{$IFDEF DELPHI}
Width := 256;
Height := 256;
{$ELSE}
SetInitialBounds(0, 0, 256, 256);
{$ENDIF}
HintFormat := 'G: %g B: %b'#13'Hex: %hex';
FG := 0;
FB := 0;
@ -95,49 +89,22 @@ begin
MarkerStyle := msCircle;
end;
destructor TRAxisColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
end;
procedure TRAxisColorPicker.CreateWnd;
begin
inherited;
CreateRGBGradient;
CreateGradient;
end;
procedure TRAxisColorPicker.CreateRGBGradient;
var
g, b : integer;
row: pRGBQuadArray;
{ x is BLUE, y is GREEN }
function TRAxisColorPicker.GetGradientColor2D(x, y: Integer): TColor;
begin
if FBmp = nil then
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;
Result := RGB(FR, FGradientBmp.Height - 1 - y, x);
end;
procedure TRAxisColorPicker.CorrectCoords(var x, y: integer);
begin
if x < 0 then x := 0;
if y < 0 then y := 0;
if x > Width - 1 then x := Width - 1;
if y > Height - 1 then y := Height - 1;
Clamp(x, 0, Width - 1);
Clamp(y, 0, Height - 1);
end;
procedure TRAxisColorPicker.DrawMarker(x, y: integer);
@ -156,17 +123,7 @@ begin
c := clBlack
else
c := clWhite;
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;
function TRAxisColorPicker.GetSelectedColor: TColor;
begin
Result := FSelected;
InternalDrawMarker(x, y, c);
end;
procedure TRAxisColorPicker.SetSelectedColor(c: TColor);
@ -179,13 +136,13 @@ begin
FManual := false;
myy := Round((255-FG)*(Height/255));
mxx := Round(FB*(Width/255));
CreateRGBGradient;
CreateGradient;
Invalidate;
end;
procedure TRAxisColorPicker.Paint;
begin
Canvas.StretchDraw(ClientRect, FBmp);
Canvas.StretchDraw(ClientRect, FGradientBmp);
CorrectCoords(mxx, myy);
DrawMarker(mxx, myy);
end;
@ -345,38 +302,23 @@ end;
procedure TRAxisColorPicker.SetRValue(r: integer);
begin
if r > 255 then r := 255;
if r < 0 then r := 0;
Clamp(r, 0, 255);
FR := r;
SetSelectedColor(RGB(FR, FG, FB));
end;
procedure TRAxisColorPicker.SetGValue(g: integer);
begin
if g > 255 then g := 255;
if g < 0 then g := 0;
Clamp(g, 0, 255);
FG := g;
SetSelectedColor(RGB(FR, FG, FB));
end;
procedure TRAxisColorPicker.SetBValue(b: integer);
begin
if b > 255 then b := 255;
if b < 0 then b := 0;
Clamp(b, 0, 255);
FB := b;
SetSelectedColor(RGB(FR, FG, FB));
end;
function TRAxisColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y];
end;
procedure TRAxisColorPicker.WebSafeChanged;
begin
inherited;
CreateRGBGradient;
Invalidate;
end;
end.

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 GetSValue(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 HSLToRGBQuad(H, S, L: integer): TRGBQuad;
procedure RGBTripleToHSL(RGBTriple : TRGBTriple; var h, s, l: integer);
implementation
uses
mbUtils;
function HSLtoRGB(H, S, L: double): TColor;
var
M1, M2: double;
@ -156,12 +159,12 @@ begin
RGBToHSLRange(AColor, d, d, l);
Result := l;
end;
{
procedure Clamp(var Input: integer; Min, Max: integer);
begin
if (Input < Min) then Input := Min;
if (Input > Max) then Input := Max;
end;
end; }
function HSLToRGBTriple(H, S, L: integer): TRGBTriple;
const

185
components/mbColorLib/SLColorPicker.pas
View File

@ -12,19 +12,14 @@ uses
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, RGBHSLUtils,
Forms, HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines;
SysUtils, Classes, Controls, Graphics, Math, Forms,
mbColorPickerControl;
type
TSLColorPicker = class(TmbColorPickerControl)
private
FManual: boolean;
FHue, FSat, FLum: integer;
FOnChange: TNotifyEvent;
FChange: boolean;
FBMP: TBitmap;
procedure CreateSLGradient;
procedure DrawMarker(x, y: integer);
procedure SelectionChanged(x, y: integer);
procedure UpdateCoords;
@ -32,7 +27,7 @@ type
procedure SetSat(s: integer);
procedure SetLum(l: integer);
protected
procedure WebSafeChanged; override;
function GetGradientColor2D(X, Y: Integer): TColor; override;
function GetSelectedColor: TColor; override;
procedure SetSelectedColor(c: TColor); override;
procedure Paint; override;
@ -45,18 +40,14 @@ type
message CN_KEYDOWN;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorAtPoint(x, y: integer): TColor; override;
property Manual: boolean read FManual;
published
property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 0;
property Luminance: integer read FLum write SetLum default 255;
property SelectedColor default clWhite;
property MarkerStyle default msCircle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChange;
end;
procedure Register;
@ -65,10 +56,10 @@ implementation
{$IFDEF FPC}
{$R SLColorPicker.dcr}
{$ENDIF}
uses
IntfGraphics, fpimage;
{$ENDIF}
ScanLines, RGBHSLUtils, HTMLColors, mbUtils;
procedure Register;
begin
@ -78,11 +69,14 @@ end;
constructor TSLColorPicker.Create(AOwner: TComponent);
begin
inherited;
FBMP := TBitmap.Create;
FBMP.PixelFormat := pf32bit;
FBMP.SetSize(256, 256);
FGradientWidth := 256;
FGradientHeight := 256;
{$IFDEF DELPHI}
Width := 255;
Height := 255;
{$ELSE}
SetInitialBounds(0, 0, 256, 256);
{$ENDIF}
MaxHue := 360;
MaxSat := 255;
MaxLum := 255;
@ -93,104 +87,15 @@ begin
MarkerStyle := msCircle;
end;
destructor TSLColorPicker.Destroy;
begin
FBMP.Free;
inherited;
end;
//{$IFDEF DELPHI}
procedure TSLColorPicker.CreateSLGradient;
{ This picker has Saturation along the X and Luminance along the Y axis. }
function TSLColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
var
x, y, skip: integer;
row: pRGBQuadArray;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
q: TRGBQuad;
begin
if FBmp = nil then
begin
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.Width := 256;
FBmp.Height := 256;
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}
q := HSLtoRGBQuad(FHue, x, 255-y);
Result := RGB(q.rgbRed, q.rgbGreen, q.rgbBlue);
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;
begin
inherited;
@ -200,7 +105,7 @@ end;
procedure TSLColorPicker.CreateWnd;
begin
inherited;
CreateSLGradient;
CreateGradient;
UpdateCoords;
end;
@ -215,63 +120,53 @@ var
c: TColor;
begin
c := not GetColorAtPoint(x, y);
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;
InternalDrawMarker(x, y, c);
end;
procedure TSLColorPicker.Paint;
begin
Canvas.StretchDraw(ClientRect, FBMP);
Canvas.StretchDraw(ClientRect, FGradientBMP);
UpdateCoords;
DrawMarker(mdx, mdy);
end;
procedure TSLColorPicker.SetHue(h: integer);
begin
if h > 360 then h := 360;
if h < 0 then h := 0;
Clamp(h, 0, 360);
if FHue <> h then
begin
FHue := h;
FManual := false;
CreateSLGradient;
CreateGradient;
UpdateCoords;
Invalidate;
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TSLColorPicker.SetSat(s: integer);
begin
if s > 255 then s := 255;
if s < 0 then s := 0;
Clamp(s, 0, 255);
if FSat <> s then
begin
FSat := s;
FManual := false;
UpdateCoords;
Invalidate;
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TSLColorPicker.SetLum(l: integer);
procedure TSLColorPicker.SetLum(L: integer);
begin
if l > 255 then l := 255;
if l < 0 then l := 0;
if FLum <> l then
Clamp(L, 0, 255);
if FLum <> L then
begin
FLum := l;
FLum := L;
FManual := false;
UpdateCoords;
Invalidate;
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
@ -309,7 +204,8 @@ var
R: TRect;
begin
inherited;
if csDesigning in ComponentState then Exit;
if csDesigning in ComponentState then
Exit;
if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then
begin
mdx := x;
@ -330,7 +226,8 @@ end;
procedure TSLColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
if csDesigning in ComponentState then Exit;
if csDesigning in ComponentState then
Exit;
if (ssLeft in Shift) and PtInRect(ClientRect, Point(x, y)) then
begin
mdx := x;
@ -347,13 +244,12 @@ var
begin
if WebSafe then c := GetWebSafe(c);
FManual := false;
Fchange := false;
FChange := false;
RGBTripleToHSL(RGBtoRGBTriple(GetRValue(c), GetGValue(c), GetBValue(c)), h, s, l);
SetHue(h);
SetSat(s);
SetLum(l);
if Fchange then
if Assigned(FOnChange) then FOnChange(Self);
if FChange and Assigned(FOnChange) then FOnChange(Self);
FChange := true;
end;
@ -472,11 +368,4 @@ begin
OnKeyDown(Self, Message.CharCode, Shift);
end;
procedure TSLColorPicker.WebSafeChanged;
begin
inherited;
CreateSLGradient;
Invalidate;
end;
end.

77
components/mbColorLib/SLHColorPicker.pas
View File

@ -31,7 +31,6 @@ type
FSLMenu, FHMenu: TPopupMenu;
FSLCursor, FHCursor: TCursor;
PBack: TBitmap;
function GetManual: boolean;
procedure SelectColor(c: TColor);
procedure SetH(v: integer);
@ -46,21 +45,20 @@ type
procedure SetHMenu(m: TPopupMenu);
procedure SetHCursor(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 SLPickerChange(Sender: TObject);
protected
procedure CreateWnd; override;
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
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorUnderCursor: TColor;
function GetHexColorUnderCursor: string;
function GetSelectedHexColor: string;
@ -93,7 +91,6 @@ type
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
property ParentBackground default true;
{$ENDIF}{$ENDIF}
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnMouseMove;
end;
@ -106,6 +103,13 @@ implementation
{$R SLHColorPicker.dcr}
{$ENDIF}
const
WSL = 255;
HSL = 255;
WH = 40;
DIST = 2;
VDELTA = 8;
procedure Register;
begin
RegisterComponents('mbColor Lib', [TSLHColorPicker]);
@ -124,9 +128,12 @@ begin
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF}{$ENDIF}
SetInitialBounds(0, 0, 297, 271);
// Width := 297;
// Height := 271;
{$IFDEF DELPHI}
Width := 297;
Height := 271;
{$ELSE}
SetInitialBounds(0, 0, WSL + DIST + WH, HSL + 2*VDELTA);
{$ENDIF}
TabStop := true;
FSelectedColor := clRed;
FHPicker := THColorPicker.Create(Self);
@ -137,14 +144,15 @@ begin
// Hue picker
with FHPicker do
begin
SetInitialBounds(257, 0, 40, 271);
{
Height := 271;
Width := 40;
Top := 0;
{$IFDEF DELPHI}
Left := 257;
}
Anchors := [akTop, akRight, akBottom];
Top := 0;
Width := 40;
Height := 271;
{$ELSE}
SetInitialBounds(WSL + DIST, 0, WH, HSL + 2*VDELTA);
{$ENDIF}
// Anchors := [akTop, akRight, akBottom];
Visible := true;
Layout := lyVertical;
ArrowPlacement := spBoth;
@ -158,14 +166,15 @@ begin
InsertControl(FSLPicker);
with FSLPicker do
begin
SetInitialBounds(0, 0, 255, 271);
{
Width := 255;
Height := 271; //255;
Top := 0; //8;
{$IFDEF DELPHI}
Left := 0;
}
Anchors := [akLeft, akRight, akTop, akBottom];
Top := DELTA;
Width := 255;
Height := self.Height - 2 * VDELTA;
{$ELSE}
SetInitialBounds(0, VDELTA, WSL, HSL);
{$ENDIF}
//Anchors := [akLeft, akRight, akTop, akBottom];
Visible := true;
SelectedColor := clRed;
OnChange := SLPickerChange;
@ -332,16 +341,14 @@ begin
inherited;
PaintParentBack;
if FSLPicker = nil then
exit;
if FHPicker = nil then
if (FSLPicker = nil) or (FHPicker = nil) then
exit;
FSLPicker.Width := Width - FHPicker.Width - 10;
FSLPicker.Height := Height - 2;
FSLPicker.Width := Width - FHPicker.Width - DIST;
FSLPicker.Height := Height - 2*VDELTA;
FHPicker.Left := Width - FHPicker.Width - 2;
FHPicker.Height := Height - 2;
FHPicker.Left := Width - FHPicker.Width;
FHPicker.Height := Height;
end;
procedure TSLHColorPicker.PaintParentBack;

24
components/mbColorLib/mbBasicPicker.pas
View File

@ -13,8 +13,17 @@ uses
Classes, SysUtils, Graphics, Controls;
type
{ TmbBasicPicker }
TmbBasicPicker = class(TCustomControl)
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(ACanvas: TCanvas); overload;
procedure PaintParentBack(ABitmap: TBitmap); overload;
@ -50,11 +59,26 @@ begin
inherited;
end;
procedure TmbBasicPicker.CreateGradient;
begin
// to be implemented by descendants
end;
function TmbBasicPicker.GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor;
begin
result := inherited GetDefaultColor(DefaultColorType);
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;
begin
PaintParentBack(Canvas);

94
components/mbColorLib/mbColorPickerControl.pas
View File

@ -29,14 +29,19 @@ type
procedure SetMarkerStyle(s: TMarkerStyle);
procedure SetWebSafe(s: boolean);
protected
FManual: Boolean;
FSelected: TColor;
mx, my, mdx, mdy: integer;
FOnChange: TNotifyEvent;
procedure CreateGradient; override;
function GetSelectedColor: 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 MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CreateWnd; override;
procedure WebSafeChanged; dynamic;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
{$IFDEF DELPHI}
procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER;
@ -48,15 +53,15 @@ type
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
{$ENDIF}
property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
public
constructor Create(AOwner: TComponent); override;
function GetColorAtPoint(x, y: integer): TColor; dynamic;
function GetHexColorAtPoint(X, Y: integer): string;
function GetColorUnderCursor: TColor;
function GetHexColorUnderCursor: string;
property ColorUnderCursor: TColor read GetColorUnderCursor;
property Manual: boolean read FManual;
published
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor;
property HintFormat: string read FHintFormat write FHintFormat;
@ -83,7 +88,6 @@ type
property DragMode;
property DragKind;
property Constraints;
property OnContextPopup;
property OnMouseDown;
property OnMouseMove;
@ -102,7 +106,11 @@ type
implementation
uses PalUtils;
uses
{$IFDEF FPC}
IntfGraphics, fpimage,
{$ENDIF}
ScanLines, PalUtils, SelPropUtils;
constructor TmbCustomPicker.Create(AOwner: TComponent);
begin
@ -148,21 +156,72 @@ begin
inherited;
end;
procedure TmbCustomPicker.CreateGradient;
var
// x, y, skip: integer;
x, y: Integer;
row: pRGBQuadArray;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin
if FGradientBmp = nil then
begin
FGradientBmp := TBitmap.Create;
FGradientBmp.PixelFormat := pf32bit;
end;
FGradientBmp.Width := FGradientWidth;
FGradientBmp.Height := FGradientHeight;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(FGradientBmp.Width, FGradientBmp.Height);
try
intfImg.LoadFromBitmap(FGradientBmp.Handle, FGradientBmp.MaskHandle);
{$ENDIF}
for y := 0 to FGradientBmp.Height - 1 do
begin
{$IFDEF FPC}
row := intfImg.GetDataLineStart(y); //FGradientBmp.Height - 1 - y);
{$ELSE}
row := FHSVBmp.Scanline(y); //FGradientBmp.Height - 1 - y);
{$ENDIF}
for x := 0 to FGradientBmp.Width - 1 do
begin
c := GetGradientColor2D(x, y);
if WebSafe then
c := GetWebSafe(c);
row[x] := RGBToRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
end;
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FGradientBmp.Handle := imgHandle;
FGradientBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
{$ENDIF}
end;
function TmbCustomPicker.GetSelectedColor: TColor;
begin
Result := clNone;
//handled in descendents
Result := FSelected; // valid for most descendents
end;
procedure TmbCustomPicker.SetSelectedColor(C: TColor);
begin
FSelected := C;
//handled in descendents
end;
function TmbCustomPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := clNone;
//handled in descendents
Result := Canvas.Pixels[x, y]; // valid for most descendents
end;
function TmbCustomPicker.GetHexColorAtPoint(X, Y: integer): string;
@ -180,9 +239,19 @@ begin
Result := ColorToHex(GetColorAtPoint(mx, my));
end;
procedure TmbCustomPicker.InternalDrawMarker(X, Y: Integer; C: TColor);
begin
case MarkerStyle of
msCircle: DrawSelCirc(x, y, Canvas);
msSquare: DrawSelSquare(x, y, Canvas);
msCross: DrawSelCross(x, y, Canvas, c);
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
end;
end;
procedure TmbCustomPicker.CMHintShow(var Message: TCMHintShow);
begin
if GetColorUnderCursor <> clNone then
if GetColorUnderCursor <> clNone then
with TCMHintShow(Message) do
if not ShowHint then
Message.Result := 1
@ -225,7 +294,7 @@ begin
if FMarkerStyle <> s then
begin
FMarkerStyle := s;
invalidate;
Invalidate;
end;
end;
@ -240,7 +309,8 @@ end;
procedure TmbCustomPicker.WebSafeChanged;
begin
//handled in descendents
CreateGradient;
Invalidate;
end;
end.

26
components/mbColorLib/mbTrackBarPicker.pas
View File

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

9
components/mbColorLib/mbutils.pas
View File

@ -8,6 +8,7 @@ uses
Classes, SysUtils;
procedure Clamp(var AValue:Integer; AMin, AMax: Integer);
function PointInCircle(p: TPoint; Size: integer): boolean;
implementation
@ -17,6 +18,14 @@ begin
if AValue > AMax then AValue := AMax;
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.