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

mbColorLib: Delphi support removed. Change version number to 2.1 (standard even/odd numbering scheme).

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5549 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2016-12-20 15:41:10 +00:00
parent 8e3f2972ae
commit f00577f5f4
30 changed files with 4038 additions and 5806 deletions
Download Patch File Download Diff File Expand all files Collapse all files

229
components/mbColorLib/GAxisColorPicker.pas
View File

@ -7,12 +7,7 @@ unit GAxisColorPicker;
interface interface
uses uses
{$IFDEF FPC} LCLType, LCLIntf, LMessages, SysUtils, Classes, Controls, Graphics, Math, Forms,
LCLType, LCLIntf, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, mbColorPickerControl; HTMLColors, mbColorPickerControl;
type type
@ -29,12 +24,8 @@ type
procedure DrawMarker(x, y: integer); procedure DrawMarker(x, y: integer);
function GetGradientColor2D(x, y: Integer): TColor; override; function GetGradientColor2D(x, y: Integer): TColor; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override;
(*
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
*)
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure Paint; override; procedure Paint; override;
procedure Resize; override; procedure Resize; override;
@ -50,6 +41,7 @@ type
property OnChange; property OnChange;
end; end;
implementation implementation
uses uses
@ -62,12 +54,7 @@ begin
inherited; inherited;
FGradientWidth := 256; FGradientWidth := 256;
FGradientHeight := 256; FGradientHeight := 256;
{$IFDEF DELPHI}
Width := 256;
Height := 256;
{$ELSE}
SetInitialBounds(0, 0, 256, 256); 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;
@ -93,11 +80,6 @@ begin
CreateGradient; CreateGradient;
end; end;
function TGAxisColorPicker.GetGradientColor2D(x, y: Integer): TColor;
begin
Result := RGB(FBufferBmp.Height - 1 - y, FG, x);
end;
procedure TGAxisColorPicker.DrawMarker(x, y: integer); procedure TGAxisColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
@ -115,34 +97,9 @@ begin
InternalDrawMarker(x, y, c); InternalDrawMarker(x, y, c);
end; end;
procedure TGAxisColorPicker.SetSelectedColor(c: TColor); function TGAxisColorPicker.GetGradientColor2D(x, y: Integer): TColor;
begin begin
if WebSafe then c := GetWebSafe(c); Result := RGB(FBufferBmp.Height - 1 - y, FG, x);
FR := GetRValue(c);
FG := GetGValue(c);
FB := GetBValue(c);
FSelected := c;
FManual := false;
myy := Round((255 - FR) * Height / 255);
mxx := Round(FB * Width / 255);
Invalidate;
if Assigned(FOnChange) then
FOnChange(Self);
end;
procedure TGAxisColorPicker.Paint;
begin
Canvas.StretchDraw(ClientRect, FBufferBmp);
CorrectCoords(mxx, myy);
DrawMarker(mxx, myy);
end;
procedure TGAxisColorPicker.Resize;
begin
FManual := false;
myy := Round((255 - FR) * Height / 255);
mxx := Round(FB * Width / 255);
inherited;
end; end;
procedure TGAxisColorPicker.KeyDown(var Key: Word; Shift: TShiftState); procedure TGAxisColorPicker.KeyDown(var Key: Word; Shift: TShiftState);
@ -207,20 +164,12 @@ begin
end; end;
procedure TGAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TGAxisColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
R: TRect;
begin begin
inherited; inherited;
mxx := x; mxx := x;
myy := y; myy := y;
if Button = mbLeft then if Button = mbLeft then
begin begin
{$IFDEF DELPHI}
R := ClientRect;
R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight);
ClipCursor(@R);
{$ENDIF}
FSelected := GetColorAtPoint(x, y); FSelected := GetColorAtPoint(x, y);
FManual := true; FManual := true;
Invalidate; Invalidate;
@ -228,24 +177,6 @@ begin
SetFocus; SetFocus;
end; end;
procedure TGAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
if ssLeft in Shift then
begin
{$IFDEF DELPHI}
ClipCursor(nil);
{$ENDIF}
mxx := X;
myy := Y;
FSelected := GetColorAtPoint(X, Y);
FManual := true;
Invalidate;
if Assigned(FOnChange) then
FOnChange(Self);
end;
end;
procedure TGAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TGAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
@ -260,108 +191,41 @@ begin
FOnChange(Self); FOnChange(Self);
end; end;
end; end;
(*
procedure TGAxisColorPicker.CNKeyDown( procedure TGAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
var
Shift: TShiftState;
FInherited: boolean;
begin begin
FInherited := false; inherited;
Shift := KeyDataToShiftState(Message.KeyData); if ssLeft in Shift then
if not (ssCtrl in Shift) then begin
case Message.CharCode of mxx := X;
VK_LEFT: myy := Y;
begin FSelected := GetColorAtPoint(X, Y);
mxx := dx - 1; FManual := true;
myy := dy; Invalidate;
FSelected := GetColorAtPoint(mxx, myy); if Assigned(FOnChange) then
FManual := true; FOnChange(Self);
Invalidate;
end;
VK_RIGHT:
begin
mxx := dx + 1;
myy := dy;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_UP:
begin
mxx := dx;
myy := dy - 1;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_DOWN:
begin
mxx := dx;
myy := dy + 1;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
else
begin
FInherited := true;
inherited;
end;
end
else
case Message.CharCode of
VK_LEFT:
begin
mxx := dx - 10;
myy := dy;
Refresh;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_RIGHT:
begin
mxx := dx + 10;
myy := dy;
Refresh;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_UP:
begin
mxx := dx;
myy := dy - 10;
Refresh;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_DOWN:
begin
mxx := dx;
myy := dy + 10;
Refresh;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
else
begin
FInherited := true;
inherited;
end;
end; end;
if not FInherited then
if Assigned(OnKeyDown) then
OnKeyDown(Self, Message.CharCode, Shift);
end; end;
*)
procedure TGAxisColorPicker.SetRValue(r: integer); procedure TGAxisColorPicker.Paint;
begin begin
Clamp(r, 0, 255); Canvas.StretchDraw(ClientRect, FBufferBmp);
FR := r; CorrectCoords(mxx, myy);
DrawMarker(mxx, myy);
end;
procedure TGAxisColorPicker.Resize;
begin
FManual := false;
myy := Round((255 - FR) * Height / 255);
mxx := Round(FB * Width / 255);
inherited;
end;
procedure TGAxisColorPicker.SetBValue(b: integer);
begin
Clamp(b, 0, 255);
FB := b;
SetSelectedColor(RGB(FR, FG, FB)); SetSelectedColor(RGB(FR, FG, FB));
end; end;
@ -372,11 +236,26 @@ begin
SetSelectedColor(RGB(FR, FG, FB)); SetSelectedColor(RGB(FR, FG, FB));
end; end;
procedure TGAxisColorPicker.SetBValue(b: integer); procedure TGAxisColorPicker.SetRValue(r: integer);
begin begin
Clamp(b, 0, 255); Clamp(r, 0, 255);
FB := b; FR := r;
SetSelectedColor(RGB(FR, FG, FB)); SetSelectedColor(RGB(FR, FG, FB));
end; end;
procedure TGAxisColorPicker.SetSelectedColor(c: TColor);
begin
if WebSafe then c := GetWebSafe(c);
FR := GetRValue(c);
FG := GetGValue(c);
FB := GetBValue(c);
FSelected := c;
FManual := false;
myy := Round((255 - FR) * Height / 255);
mxx := Round(FB * Width / 255);
Invalidate;
if Assigned(FOnChange) then
FOnChange(Self);
end;
end. end.

194
components/mbColorLib/GColorPicker.pas
View File

@ -1,29 +1,26 @@
unit GColorPicker; unit GColorPicker;
{$IFDEF FPC}{$MODE DELPHI}{$ENDIF} {$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
interface interface
uses uses
{$IFDEF FPC} LCLIntf, LCLType, LMessages, SysUtils, Classes, Controls, Graphics, Forms,
LCLIntf, LCLType, LMessages, HTMLColors, mbTrackBarPicker;
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
mbTrackBarPicker, HTMLColors;
type type
TGColorPicker = class(TmbTrackBarPicker) TGColorPicker = class(TmbTrackBarPicker)
private private
FRed, FGreen, FBlue: integer; FRed, FGreen, FBlue: integer;
function ArrowPosFromGreen(g: integer): integer; function ArrowPosFromGreen(g: integer): integer;
function GreenFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor; function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor); function GreenFromArrowPos(p: integer): integer;
procedure SetRed(r: integer);
procedure SetGreen(g: integer);
procedure SetBlue(b: integer); procedure SetBlue(b: integer);
procedure SetGreen(g: integer);
procedure SetRed(r: integer);
procedure SetSelectedColor(c: TColor);
protected protected
procedure Execute(tbaAction: integer); override; procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override; function GetArrowPos: integer; override;
@ -39,6 +36,7 @@ type
property Layout default lyVertical; property Layout default lyVertical;
end; end;
implementation implementation
uses uses
@ -63,50 +61,6 @@ begin
FChange := true; FChange := true;
end; end;
function TGColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := RGB(FRed, AValue, FBlue);
end;
procedure TGColorPicker.SetRed(r: integer);
begin
Clamp(r, 0, 255);
if FRed <> r then
begin
FRed := r;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TGColorPicker.SetGreen(g: integer);
begin
Clamp(g, 0, 255);
if FGreen <> g then
begin
FGreen := g;
FArrowPos := ArrowPosFromGreen(g);
FManual := false;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TGColorPicker.SetBlue(b: integer);
begin
Clamp(b, 0, 255);
if FBlue <> b then
begin
FBlue := b;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
function TGColorPicker.ArrowPosFromGreen(g: integer): integer; function TGColorPicker.ArrowPosFromGreen(g: integer): integer;
var var
a: integer; a: integer;
@ -126,48 +80,6 @@ begin
Result := a; Result := a;
end; end;
function TGColorPicker.GreenFromArrowPos(p: integer): integer;
var
g: integer;
begin
if Layout = lyHorizontal then
g := Round(p/((Width - 12)/255))
else
g := Round(255 - p/((Height - 12)/255));
Clamp(g, 0, 255);
Result := g;
end;
function TGColorPicker.GetSelectedColor: TColor;
begin
if not WebSafe then
Result := RGB(FRed, FGreen, FBlue)
else
Result := GetWebSafe(RGB(FRed, FGreen, FBlue));
end;
function TGColorPicker.GetSelectedValue: integer;
begin
Result := FGreen;
end;
procedure TGColorPicker.SetSelectedColor(c: TColor);
begin
if WebSafe then c := GetWebSafe(c);
FChange := false;
SetRed(GetRValue(c));
SetBlue(GetBValue(c));
SetGreen(GetGValue(c));
FManual := false;
FChange := true;
if Assigned(OnChange) then OnChange(Self);
end;
function TGColorPicker.GetArrowPos: integer;
begin
Result := ArrowPosFromGreen(FGreen);
end;
procedure TGColorPicker.Execute(tbaAction: integer); procedure TGColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
@ -204,4 +116,90 @@ begin
end; end;
end; end;
function TGColorPicker.GetArrowPos: integer;
begin
Result := ArrowPosFromGreen(FGreen);
end;
function TGColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := RGB(FRed, AValue, FBlue);
end;
function TGColorPicker.GetSelectedColor: TColor;
begin
if not WebSafe then
Result := RGB(FRed, FGreen, FBlue)
else
Result := GetWebSafe(RGB(FRed, FGreen, FBlue));
end;
function TGColorPicker.GetSelectedValue: integer;
begin
Result := FGreen;
end;
function TGColorPicker.GreenFromArrowPos(p: integer): integer;
var
g: integer;
begin
if Layout = lyHorizontal then
g := Round(p/((Width - 12)/255))
else
g := Round(255 - p/((Height - 12)/255));
Clamp(g, 0, 255);
Result := g;
end;
procedure TGColorPicker.SetBlue(b: integer);
begin
Clamp(b, 0, 255);
if FBlue <> b then
begin
FBlue := b;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TGColorPicker.SetGreen(g: integer);
begin
Clamp(g, 0, 255);
if FGreen <> g then
begin
FGreen := g;
FArrowPos := ArrowPosFromGreen(g);
FManual := false;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TGColorPicker.SetRed(r: integer);
begin
Clamp(r, 0, 255);
if FRed <> r then
begin
FRed := r;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TGColorPicker.SetSelectedColor(c: TColor);
begin
if WebSafe then c := GetWebSafe(c);
FChange := false;
SetRed(GetRValue(c));
SetBlue(GetBValue(c));
SetGreen(GetGValue(c));
FManual := false;
FChange := true;
if Assigned(OnChange) then OnChange(Self);
end;
end. end.

205
components/mbColorLib/HColorPicker.pas
View File

@ -7,13 +7,8 @@ unit HColorPicker;
interface interface
uses uses
{$IFDEF FPC} LCLIntf, LCLType, LMessages, SysUtils, Classes, Controls, Graphics, Forms,
LCLIntf, LCLType, LMessages, RGBHSVUtils, HTMLColors, mbTrackBarPicker;
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
RGBHSVUtils, mbTrackBarPicker, HTMLColors;
type type
THColorPicker = class(TmbTrackBarPicker) THColorPicker = class(TmbTrackBarPicker)
@ -24,14 +19,14 @@ type
function HueFromArrowPos(p: integer): integer; function HueFromArrowPos(p: integer): integer;
function GetHue: Integer; function GetHue: Integer;
function GetSat: Integer; function GetSat: Integer;
function GetVal: Integer;
function GetSelectedColor: TColor; function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor); function GetVal: Integer;
procedure SetHue(h: integer); procedure SetHue(h: integer);
procedure SetMaxHue(h: Integer); procedure SetMaxHue(h: Integer);
procedure SetMaxSat(s: Integer); procedure SetMaxSat(s: Integer);
procedure SetMaxVal(v: Integer); procedure SetMaxVal(v: Integer);
procedure SetSat(s: integer); procedure SetSat(s: integer);
procedure SetSelectedColor(c: TColor);
procedure SetVal(v: integer); procedure SetVal(v: integer);
protected protected
procedure Execute(tbaAction: integer); override; procedure Execute(tbaAction: integer); override;
@ -75,6 +70,68 @@ begin
FChange := true; FChange := true;
end; end;
function THColorPicker.ArrowPosFromHue(h: integer): integer;
var
a: integer;
begin
if Layout = lyHorizontal then
begin
a := Round((Width - 12) * h / FMaxHue);
if a > Width - FLimit then a := Width - FLimit;
end
else
begin
a := Round((Height - 12) * h / FMaxHue);
if a > Height - FLimit then a := Height - FLimit;
end;
if a < 0 then a := 0;
Result := a;
end;
procedure THColorPicker.Execute(tbaAction: integer);
begin
case tbaAction of
TBA_Resize:
SetHue(GetHue);
TBA_MouseMove:
Hue := HueFromArrowPos(FArrowPos);
TBA_MouseDown:
Hue := HueFromArrowPos(FArrowPos);
TBA_MouseUp:
Hue := HueFromArrowPos(FArrowPos);
TBA_WheelUp:
SetHue(GetHue() + Increment);
TBA_WheelDown:
SetHue(GetHue() - Increment);
TBA_VKLeft:
SetHue(GetHue() - Increment);
TBA_VKCtrlLeft:
SetHue(0);
TBA_VKRight:
SetHue(GetHue() + Increment);
TBA_VKCtrlRight:
SetHue(FMaxHue);
TBA_VKUp:
SetHue(GetHue() - Increment);
TBA_VKCtrlUp:
SetHue(0);
TBA_VKDown:
SetHue(GetHue() + Increment);
TBA_VKCtrlDown:
SetHue(FMaxHue);
else
inherited;
end;
end;
function THColorPicker.GetArrowPos: integer;
begin
if FMaxHue = 0 then
Result := inherited GetArrowPos
else
Result := ArrowPosFromHue(GetHue());
end;
function THColorPicker.GetGradientColor(AValue: Integer): TColor; function THColorPicker.GetGradientColor(AValue: Integer): TColor;
var var
h: Double; h: Double;
@ -94,11 +151,35 @@ begin
Result := round(FSat * FMaxSat); Result := round(FSat * FMaxSat);
end; end;
function THColorPicker.GetSelectedColor: TColor;
begin
Result := HSVtoColor(FHue, FSat, FVal);
if WebSafe then
Result := GetWebSafe(Result);
end;
function THColorPicker.GetSelectedValue: integer;
begin
Result := GetHue();
end;
function THColorPicker.GetVal: Integer; function THColorPicker.GetVal: Integer;
begin begin
Result := round(FVal * FMaxVal); Result := round(FVal * FMaxVal);
end; end;
function THColorPicker.HueFromArrowPos(p: integer): integer;
var
r: integer;
begin
if Layout = lyHorizontal then
r := Round(p / (Width - 12) * FMaxHue)
else
r := Round(p / (Height - 12) * MaxHue);
Clamp(r, 0, FMaxHue);
Result := r;
end;
procedure THColorPicker.SetHue(h: integer); procedure THColorPicker.SetHue(h: integer);
begin begin
Clamp(h, 0, FMaxHue); Clamp(h, 0, FMaxHue);
@ -156,61 +237,6 @@ begin
end; end;
end; end;
procedure THColorPicker.SetVal(v: integer);
begin
Clamp(v, 0, FMaxVal);
if GetVal() <> v then
begin
FVal := v / FMaxVal;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
function THColorPicker.ArrowPosFromHue(h: integer): integer;
var
a: integer;
begin
if Layout = lyHorizontal then
begin
a := Round((Width - 12) * h / FMaxHue);
if a > Width - FLimit then a := Width - FLimit;
end
else
begin
a := Round((Height - 12) * h / FMaxHue);
if a > Height - FLimit then a := Height - FLimit;
end;
if a < 0 then a := 0;
Result := a;
end;
function THColorPicker.HueFromArrowPos(p: integer): integer;
var
r: integer;
begin
if Layout = lyHorizontal then
r := Round(p / (Width - 12) * FMaxHue)
else
r := Round(p / (Height - 12) * MaxHue);
Clamp(r, 0, FMaxHue);
Result := r;
end;
function THColorPicker.GetSelectedColor: TColor;
begin
Result := HSVtoColor(FHue, FSat, FVal);
if WebSafe then
Result := GetWebSafe(Result);
end;
function THColorPicker.GetSelectedValue: integer;
begin
Result := GetHue();
end;
procedure THColorPicker.SetSelectedColor(c: TColor); procedure THColorPicker.SetSelectedColor(c: TColor);
var var
h, s, v: integer; h, s, v: integer;
@ -226,48 +252,17 @@ begin
if Assigned(OnChange) then OnChange(Self); if Assigned(OnChange) then OnChange(Self);
end; end;
function THColorPicker.GetArrowPos: integer; procedure THColorPicker.SetVal(v: integer);
begin begin
if FMaxHue = 0 then Clamp(v, 0, FMaxVal);
Result := inherited GetArrowPos if GetVal() <> v then
else begin
Result := ArrowPosFromHue(GetHue()); FVal := v / FMaxVal;
end; FManual := false;
CreateGradient;
procedure THColorPicker.Execute(tbaAction: integer); Invalidate;
begin if FChange and Assigned(OnChange) then OnChange(Self);
case tbaAction of end;
TBA_Resize:
SetHue(GetHue);
TBA_MouseMove:
Hue := HueFromArrowPos(FArrowPos);
TBA_MouseDown:
Hue := HueFromArrowPos(FArrowPos);
TBA_MouseUp:
Hue := HueFromArrowPos(FArrowPos);
TBA_WheelUp:
SetHue(GetHue() + Increment);
TBA_WheelDown:
SetHue(GetHue() - Increment);
TBA_VKLeft:
SetHue(GetHue() - Increment);
TBA_VKCtrlLeft:
SetHue(0);
TBA_VKRight:
SetHue(GetHue() + Increment);
TBA_VKCtrlRight:
SetHue(FMaxHue);
TBA_VKUp:
SetHue(GetHue() - Increment);
TBA_VKCtrlUp:
SetHue(0);
TBA_VKDown:
SetHue(GetHue() + Increment);
TBA_VKCtrlDown:
SetHue(FMaxHue);
else
inherited;
end;
end; end;
end. end.

546
components/mbColorLib/HRingPicker.pas
View File

@ -7,13 +7,8 @@ unit HRingPicker;
interface interface
uses uses
{$IFDEF FPC} LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics, Math, Forms,
LCLIntf, LCLType, LMessages, RGBHSVUtils, HTMLColors, mbColorPickerControl;
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, RGBHSVUtils,
Forms, {IFDEF DELPHI_7_UP Themes, $ENDIF} HTMLColors, mbColorPickerControl;
type type
THRingPicker = class(TmbColorPickerControl) THRingPicker = class(TmbColorPickerControl)
@ -47,19 +42,14 @@ type
procedure CreateGradient; override; procedure CreateGradient; override;
function GetGradientColor2D(X, Y: Integer): TColor; override; function GetGradientColor2D(X, Y: Integer): TColor; override;
function GetSelectedColor: TColor; override; function GetSelectedColor: TColor; override;
procedure SetSelectedColor(c: TColor); override;
procedure Paint; override;
procedure Resize; override;
// procedure CreateWnd; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
function MouseOnPicker(X, Y: Integer): Boolean; function MouseOnPicker(X, Y: Integer): Boolean;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
(* procedure Paint; override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); procedure Resize; override;
message CN_KEYDOWN; procedure SetSelectedColor(c: TColor); override;
*)
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
function GetColorAtPoint(x, y: integer): TColor; override; function GetColorAtPoint(x, y: integer): TColor; override;
@ -72,8 +62,8 @@ type
property MaxSaturation: Integer read FMaxSat write SetMaxSat default 255; property MaxSaturation: Integer read FMaxSat write SetMaxSat default 255;
property MaxValue: Integer read FMaxValue write SetMaxValue default 255; property MaxValue: Integer read FMaxValue write SetMaxValue 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 Radius: integer read FRadius write SetRadius default 40; property Radius: integer read FRadius write SetRadius default 40;
property SelectedColor default clNone;
property OnChange; property OnChange;
end; end;
@ -88,12 +78,7 @@ uses
constructor THRingPicker.Create(AOwner: TComponent); constructor THRingPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
{$IFDEF DELPHI}
Width := 204;
Height := 204;
{$ELSE}
SetInitialBounds(0, 0, 204, 204); SetInitialBounds(0, 0, 204, 204);
{$ENDIF}
FMaxHue := 359; FMaxHue := 359;
FMaxSat := 255; FMaxSat := 255;
FMaxValue := 255; FMaxValue := 255;
@ -107,6 +92,7 @@ begin
FRadius := 40; FRadius := 40;
FDoChange := false; FDoChange := false;
HintFormat := 'Hue: %h (selected)'; HintFormat := 'Hue: %h (selected)';
TabStop := true;
end; end;
procedure THRingPicker.CreateGradient; procedure THRingPicker.CreateGradient;
@ -116,6 +102,49 @@ begin
inherited; inherited;
end; end;
procedure THRingPicker.DrawHueLine;
var
angle: double;
sinAngle, cosAngle: Double;
radius: integer;
begin
radius := Min(Width, Height) div 2;
if (FHue >= 0) and (FHue <= 1.0) then
begin
angle := -FHue * 2 * pi;
SinCos(angle, sinAngle, cosAngle);
Canvas.Pen.Color := FHueLineColor;
Canvas.MoveTo(radius, radius);
Canvas.LineTo(radius + round(radius*cosAngle), radius + round(radius*sinAngle));
end;
end;
function THRingPicker.GetColorAtPoint(x, y: integer): TColor;
var
angle: Double;
dx, dy, radius: integer;
h: Double;
begin
radius := Min(Width, Height) div 2;
if PointInCircle(Point(x, y), Min(Width, Height)) then
begin
dx := x - Radius;
dy := y - Radius;
angle := 360 + 180 * arctan2(-dy, dx) / pi;
if angle < 0 then
angle := angle + 360
else if angle > 360 then
angle := angle - 360;
h := angle / 360;
Result := HSVtoColor(h, FSat, FValue);
if WebSafe then
Result := GetWebSafe(Result);
end
else
Result := clNone;
end;
{ Outer loop: Y, Inner loop: X } { Outer loop: Y, Inner loop: X }
function THRingPicker.GetGradientColor2D(X, Y: Integer): TColor; function THRingPicker.GetGradientColor2D(X, Y: Integer): TColor;
var var
@ -143,34 +172,6 @@ begin
Result := GetDefaultColor(dctBrush); Result := GetDefaultColor(dctBrush);
end; end;
procedure THRingPicker.Resize;
begin
inherited;
CreateGradient;
UpdateCoords;
end;
{
procedure THRingPicker.CreateWnd;
begin
inherited;
CreateGradient;
UpdateCoords;
end;
}
procedure THRingPicker.UpdateCoords;
var
r, angle: double;
radius: integer;
sinAngle, cosAngle: Double;
begin
radius := Min(Width, Height) div 2;
r := -radius * FSat;
angle := -(FHue * 2 + 1) * pi;
SinCos(angle, sinAngle, cosAngle);
mdx := round(cosAngle * r) + radius;
mdy := round(sinAngle * r) + radius;
end;
function THRingPicker.GetHue: Integer; function THRingPicker.GetHue: Integer;
begin begin
Result := round(FHue * FMaxHue); Result := round(FHue * FMaxHue);
@ -181,168 +182,23 @@ begin
Result := round(FSat * FMaxSat); Result := round(FSat * FMaxSat);
end; end;
function THRingPicker.GetSelectedColor: TColor;
begin
if FSelectedColor <> clNone then
begin
Result := HSVtoColor(FHue, FSat, FValue);
if WebSafe then
Result := GetWebSafe(Result);
end
else
Result := clNone;
end;
function THRingPicker.GetValue: Integer; function THRingPicker.GetValue: Integer;
begin begin
Result := round(FValue * FMaxValue); Result := round(FValue * FMaxValue);
end; end;
procedure THRingPicker.SetHue(h: integer);
begin
if h > FMaxHue then h := h - (FMaxHue + 1);
if h < 0 then h := h + (FMaxHue + 1);
if GetHue() <> h then
begin
FHue := h / FMaxHue;
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure THRingPicker.SetMaxHue(h: Integer);
begin
if h = FMaxHue then
exit;
FMaxHue := h;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
procedure THRingPicker.SetMaxSat(s: Integer);
begin
if s = FMaxSat then
exit;
FMaxSat := s;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
procedure THRingPicker.SetMaxValue(v: Integer);
begin
if v = FMaxValue then
exit;
FMaxValue := v;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
procedure THRingPicker.SetSat(s: integer);
begin
Clamp(s, 0, FMaxSat);
if GetSat() <> s then
begin
FSat := s / FMaxSat;
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure THRingPicker.SetValue(v: integer);
begin
Clamp(v, 0, FMaxValue);
if GetValue() <> V then
begin
FValue := V / FMaxValue;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure THRingPicker.SetHueLineColor(c: TColor);
begin
if FHueLineColor <> c then
begin
FHueLineColor := c;
Invalidate;
end;
end;
procedure THRingPicker.SetRadius(r: integer);
begin
if FRadius <> r then
begin
FRadius := r;
Invalidate;
end;
end;
procedure THRingPicker.DrawHueLine;
var
angle: double;
sinAngle, cosAngle: Double;
radius: integer;
begin
radius := Min(Width, Height) div 2;
if (FHue >= 0) and (FHue <= 1.0) then
begin
angle := -FHue * 2 * pi;
SinCos(angle, sinAngle, cosAngle);
Canvas.Pen.Color := FHueLineColor;
Canvas.MoveTo(radius, radius);
Canvas.LineTo(radius + round(radius*cosAngle), radius + round(radius*sinAngle));
end;
end;
procedure THRingPicker.Paint;
var
rgn, r1, r2: HRGN;
r: TRect;
size: Integer;
ringwidth: Integer;
begin
PaintParentBack(Canvas);
size := Min(Width, Height); // diameter of circle
ringwidth := size div 2 - FRadius; // FRadius is inner radius
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
rgn := r1;
InflateRect(R, -ringwidth, - ringwidth);
r2 := CreateEllipticRgnIndirect(R);
CombineRgn(rgn, r1, r2, RGN_DIFF);
end;
SelectClipRgn(Canvas.Handle, rgn);
Canvas.Draw(0, 0, FBufferBmp);
DeleteObject(rgn);
DrawHueLine;
if FDoChange then
begin
if Assigned(FOnChange) then FOnChange(Self);
FDoChange := false;
end;
end;
procedure THRingPicker.SelectionChanged(x, y: integer);
var
angle, dx, dy, Radius: integer;
begin
FSelectedColor := clWhite;
radius := Min(Width, Height) div 2;
dx := x - radius;
dy := y - radius;
angle := round(360 + 180*arctan2(-dy, dx) / pi);
if angle < 0 then
inc(angle, 360)
else if angle > 360 then
dec(angle, 360);
FChange := false;
SetHue(MulDiv(angle, FMaxHue + 1, 360));
FChange := true;
Invalidate;
end;
procedure THRingPicker.KeyDown(var Key: Word; Shift: TShiftState); procedure THRingPicker.KeyDown(var Key: Word; Shift: TShiftState);
var var
eraseKey: Boolean; eraseKey: Boolean;
@ -379,31 +235,8 @@ begin
inherited; inherited;
end; end;
procedure THRingPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
{$IFDEF DELPHI}
ClipCursor(nil);
{$ENDIF}
if csDesigning in ComponentState then Exit;
if (Button = mbLeft) and FDragging then
begin
mdx := x;
mdy := y;
FDoChange := true;
SelectionChanged(X, Y);
FManual := true;
FDragging := false;
end;
end;
procedure THRingPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; procedure THRingPicker.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); X, Y: Integer);
{$IFDEF DELPHI}
var
R: TRect;
{$ENDIF}
begin begin
inherited; inherited;
if csDesigning in ComponentState then if csDesigning in ComponentState then
@ -412,13 +245,6 @@ begin
then begin then begin
mdx := x; mdx := x;
mdy := y; mdy := y;
{$IFDEF DELPHI}
R := ClientRect;
InflateRect(R, 1, 1);
R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight);
ClipCursor(@R);
{$ENDIF}
FDoChange := true; FDoChange := true;
SelectionChanged(X, Y); SelectionChanged(X, Y);
FManual := true; FManual := true;
@ -453,42 +279,161 @@ begin
end; end;
end; end;
function THRingPicker.GetSelectedColor: TColor; procedure THRingPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin begin
if FSelectedColor <> clNone then inherited;
if csDesigning in ComponentState then Exit;
if (Button = mbLeft) and FDragging then
begin begin
Result := HSVtoColor(FHue, FSat, FValue); mdx := x;
if WebSafe then mdy := y;
Result := GetWebSafe(Result); FDoChange := true;
end SelectionChanged(X, Y);
else FManual := true;
Result := clNone; FDragging := false;
end;
end; end;
function THRingPicker.GetColorAtPoint(x, y: integer): TColor; procedure THRingPicker.Paint;
var var
angle: Double; rgn, r1, r2: HRGN;
dx, dy, radius: integer; r: TRect;
h: Double; size: Integer;
ringwidth: Integer;
begin begin
radius := Min(Width, Height) div 2; PaintParentBack(Canvas);
size := Min(Width, Height); // diameter of circle
if PointInCircle(Point(x, y), Min(Width, Height)) then ringwidth := size div 2 - FRadius; // FRadius is inner radius
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 begin
dx := x - Radius; rgn := r1;
dy := y - Radius; InflateRect(R, -ringwidth, - ringwidth);
angle := 360 + 180 * arctan2(-dy, dx) / pi; r2 := CreateEllipticRgnIndirect(R);
if angle < 0 then CombineRgn(rgn, r1, r2, RGN_DIFF);
angle := angle + 360 end;
else if angle > 360 then SelectClipRgn(Canvas.Handle, rgn);
angle := angle - 360; Canvas.Draw(0, 0, FBufferBmp);
h := angle / 360; DeleteObject(rgn);
Result := HSVtoColor(h, FSat, FValue); DrawHueLine;
if WebSafe then if FDoChange then
Result := GetWebSafe(Result); begin
end if Assigned(FOnChange) then FOnChange(Self);
else FDoChange := false;
Result := clNone; end;
end;
function THRingPicker.RadHue(New: integer): integer;
begin
if New < 0 then New := New + (FMaxHue + 1);
if New > (FMaxHue + 1) then New := New - (FMaxHue + 1);
Result := New;
end;
procedure THRingPicker.Resize;
begin
inherited;
CreateGradient;
UpdateCoords;
end;
procedure THRingPicker.SelectionChanged(x, y: integer);
var
angle, dx, dy, Radius: integer;
begin
FSelectedColor := clWhite;
radius := Min(Width, Height) div 2;
dx := x - radius;
dy := y - radius;
angle := round(360 + 180*arctan2(-dy, dx) / pi);
if angle < 0 then
inc(angle, 360)
else if angle > 360 then
dec(angle, 360);
FChange := false;
SetHue(MulDiv(angle, FMaxHue + 1, 360));
FChange := true;
Invalidate;
end;
procedure THRingPicker.SetHue(h: integer);
begin
if h > FMaxHue then h := h - (FMaxHue + 1);
if h < 0 then h := h + (FMaxHue + 1);
if GetHue() <> h then
begin
FHue := h / FMaxHue;
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure THRingPicker.SetHueLineColor(c: TColor);
begin
if FHueLineColor <> c then
begin
FHueLineColor := c;
Invalidate;
end;
end;
procedure THRingPicker.SetMaxHue(h: Integer);
begin
if h = FMaxHue then
exit;
FMaxHue := h;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
procedure THRingPicker.SetMaxSat(s: Integer);
begin
if s = FMaxSat then
exit;
FMaxSat := s;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
procedure THRingPicker.SetMaxValue(v: Integer);
begin
if v = FMaxValue then
exit;
FMaxValue := v;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
procedure THRingPicker.SetRadius(r: integer);
begin
if FRadius <> r then
begin
FRadius := r;
Invalidate;
end;
end;
procedure THRingPicker.SetSat(s: integer);
begin
Clamp(s, 0, FMaxSat);
if GetSat() <> s then
begin
FSat := s / FMaxSat;
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end; end;
procedure THRingPicker.SetSelectedColor(c: TColor); procedure THRingPicker.SetSelectedColor(c: TColor);
@ -509,52 +454,31 @@ begin
FChange := true; FChange := true;
end; end;
function THRingPicker.RadHue(New: integer): integer; procedure THRingPicker.SetValue(v: integer);
begin begin
if New < 0 then New := New + (FMaxHue + 1); Clamp(v, 0, FMaxValue);
if New > (FMaxHue + 1) then New := New - (FMaxHue + 1); if GetValue() <> V then
Result := New; begin
end; FValue := V / FMaxValue;
(* FManual := false;
procedure THRingPicker.CNKeyDown( CreateGradient;
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} ); Invalidate;
var if FChange and Assigned(FOnChange) then FOnChange(Self);
shift: TShiftState;
FInherited: boolean;
delta: Integer;
begin
FInherited := false;
shift := KeyDataToShiftState(Message.KeyData);
if ssCtrl in Shift then
delta := 10
else
delta := 1;
case Message.CharCode of
VK_LEFT:
begin
FChange := false;
SetHue(RadHue(GetHue() + delta));
FChange := true;
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
VK_RIGHT:
begin
FChange := false;
SetHue(RadHue(GetHue() - delta));
FChange := true;
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end
else
begin
FInherited := true;
inherited;
end;
end; end;
if not FInherited then
if Assigned(OnKeyDown) then
OnKeyDown(Self, Message.CharCode, Shift);
end; end;
*)
procedure THRingPicker.UpdateCoords;
var
r, angle: double;
radius: integer;
sinAngle, cosAngle: Double;
begin
radius := Min(Width, Height) div 2;
r := -radius * FSat;
angle := -(FHue * 2 + 1) * pi;
SinCos(angle, sinAngle, cosAngle);
mdx := round(cosAngle * r) + radius;
mdy := round(sinAngle * r) + radius;
end;
end. end.

221
components/mbColorLib/HSColorPicker.pas
View File

@ -9,12 +9,7 @@ unit HSColorPicker;
interface interface
uses uses
{$IFDEF FPC} LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics, Math, Forms,
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages, Scanlines,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
RGBHSLUtils, HTMLColors, mbColorPickerControl; RGBHSLUtils, HTMLColors, mbColorPickerControl;
type type
@ -40,10 +35,6 @@ type
function GetGradientColor2D(X, Y: Integer): TColor; override; function GetGradientColor2D(X, Y: Integer): TColor; override;
procedure SetSelectedColor(c: TColor); override; procedure SetSelectedColor(c: TColor); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override;
(*
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
*)
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;
@ -56,10 +47,9 @@ type
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
property Hue: integer read GetHue write SetHue; property Hue: integer read GetHue write SetHue;
property Saturation: integer read GetSat write SetSat; property Saturation: integer read GetSat write SetSat;
// property Lum: integer read GetLum write SetLum;
published published
property SelectedColor default clRed; property SelectedColor default clRed;
property Luminance: Integer read GetLum write SetLum; property Luminance: Integer read GetLum write SetLum default 120;
property MaxHue: Integer read FMaxHue write SetMaxHue default 359; property MaxHue: Integer read FMaxHue write SetMaxHue default 359;
property MaxSaturation: Integer read FMaxSat write SetMaxSat default 240; property MaxSaturation: Integer read FMaxSat write SetMaxSat default 240;
property MaxLuminance: Integer read FMaxLum write SetMaxLum default 240; property MaxLuminance: Integer read FMaxLum write SetMaxLum default 240;
@ -82,12 +72,7 @@ begin
FMaxLum := 240; FMaxLum := 240;
FGradientWidth := FMaxHue + 1; FGradientWidth := FMaxHue + 1;
FGradientHeight := FMaxSat + 1; FGradientHeight := FMaxSat + 1;
{$IFDEF DELPHI}
Width := 239;
Height := 240;
{$ELSE}
SetInitialBounds(0, 0, FGradientWidth, FGradientHeight); SetInitialBounds(0, 0, FGradientWidth, FGradientHeight);
{$ENDIF}
HintFormat := 'H: %h S: %hslS'#13'Hex: %hex'; HintFormat := 'H: %h S: %hslS'#13'Hex: %hex';
FHue := 0; FHue := 0;
FSat := 1.0; FSat := 1.0;
@ -101,27 +86,18 @@ begin
MarkerStyle := msCross; MarkerStyle := msCross;
end; end;
procedure THSColorPicker.CreateWnd;
begin
inherited;
CreateGradient;
end;
function THSColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
begin
{$IFDEF USE_COLOR_TO_RGB}
Result := HSLToColor(x / FMaxHue, (FBufferBmp.Height - 1 - y) / FMaxSat, FLum);
{$ELSE}
Result := HSLtoRGB(x / FMaxHue, (FMaxSat - y) / FMaxSat, FLum);
{$ENDIF}
end;
procedure THSColorPicker.CorrectCoords(var x, y: integer); procedure THSColorPicker.CorrectCoords(var x, y: integer);
begin begin
Clamp(x, 0, Width - 1); Clamp(x, 0, Width - 1);
Clamp(y, 0, Height - 1); Clamp(y, 0, Height - 1);
end; end;
procedure THSColorPicker.CreateWnd;
begin
inherited;
CreateGradient;
end;
procedure THSColorPicker.DrawMarker(x, y: integer); procedure THSColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
@ -144,6 +120,15 @@ begin
InternalDrawMarker(x, y, c); InternalDrawMarker(x, y, c);
end; end;
function THSColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
begin
{$IFDEF USE_COLOR_TO_RGB}
Result := HSLToColor(x / FMaxHue, (FBufferBmp.Height - 1 - y) / FMaxSat, FLum);
{$ELSE}
Result := HSLtoRGB(x / FMaxHue, (FMaxSat - y) / FMaxSat, FLum);
{$ENDIF}
end;
function THSColorPicker.GetHue: Integer; function THSColorPicker.GetHue: Integer;
begin begin
Result := Round(FHue * FMaxHue); Result := Round(FHue * FMaxHue);
@ -159,37 +144,6 @@ begin
Result := Round(FSat * FMaxSat); Result := Round(FSat * FMaxSat);
end; end;
procedure THSColorPicker.SetSelectedColor(c: TColor);
var
L: Double;
begin
if WebSafe then c := GetWebSafe(c);
{$IFDEF USE_COLOR_TO_RGB}
ColorToHSL(c, FHue, FSat, L);
{$ELSE}
RGBtoHSL(c, FHue, FSat, L);
{$ENDIF}
FSelected := c;
FManual := false;
mxx := Round(FHue * Width);
myy := Round((1.0 - FSat) * Height);
Invalidate;
if Assigned(OnChange) then OnChange(Self);
end;
procedure THSColorPicker.Paint;
begin
Canvas.StretchDraw(ClientRect, FBufferBmp);
CorrectCoords(mxx, myy);
DrawMarker(mxx, myy);
end;
procedure THSColorPicker.Resize;
begin
SetSelectedColor(FSelected);
inherited;
end;
procedure THSColorPicker.KeyDown(var Key: Word; Shift: TShiftState); procedure THSColorPicker.KeyDown(var Key: Word; Shift: TShiftState);
var var
eraseKey: Boolean; eraseKey: Boolean;
@ -248,22 +202,12 @@ begin
end; end;
procedure THSColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure THSColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
{$IFDEF DELPHI}
var
R: TRect;
{$ENDIF}
begin begin
inherited; inherited;
mxx := x; mxx := x;
myy := y; myy := y;
if Button = mbLeft then if Button = mbLeft then
begin begin
{$IFDEF DELPHI}
R := ClientRect;
R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight);
ClipCursor(@R);
{$ENDIF}
SetSelectedColor(GetColorAtPoint(x, y)); SetSelectedColor(GetColorAtPoint(x, y));
FManual := true; FManual := true;
Invalidate; Invalidate;
@ -271,19 +215,6 @@ begin
SetFocus; SetFocus;
end; end;
procedure THSColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
{$IFDEF DELPHI}
ClipCursor(nil);
{$ENDIF}
mxx := x;
myy := y;
SetSelectedColor(GetColorAtPoint(x, y));
FManual := true;
Invalidate;
end;
procedure THSColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure THSColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
@ -297,6 +228,26 @@ begin
end; end;
end; end;
procedure THSColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
if ssLeft in Shift then
begin
mxx := x;
myy := y;
SetSelectedColor(GetColorAtPoint(x, y));
FManual := true;
Invalidate;
end;
end;
procedure THSColorPicker.Paint;
begin
Canvas.StretchDraw(ClientRect, FBufferBmp);
CorrectCoords(mxx, myy);
DrawMarker(mxx, myy);
end;
function THSColorPicker.PredictColor: TColor; function THSColorPicker.PredictColor: TColor;
var var
H, S, L: Double; H, S, L: Double;
@ -309,65 +260,11 @@ begin
Result := HSLToRGB(H, S, L); Result := HSLToRGB(H, S, L);
end; end;
(* procedure THSColorPicker.Resize;
procedure THSColorPicker.CNKeyDown(
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} );
var
Shift: TShiftState;
FInherited: boolean;
delta: Integer;
begin begin
FInherited := false; SetSelectedColor(FSelected);
Shift := KeyDataToShiftState(Message.KeyData); inherited;
if (ssCtrl in Shift) then
delta := 10
else
delta := 1;
case Message.CharCode of
VK_LEFT:
begin
mxx := dx - delta;
myy := dy;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_RIGHT:
begin
mxx := dx + delta;
myy := dy;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_UP:
begin
mxx := dx;
myy := dy - delta;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_DOWN:
begin
mxx := dx;
myy := dy + delta;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
else
begin
FInherited := true;
inherited;
end;
end;
if not FInherited then
if Assigned(OnKeyDown) then
OnKeyDown(Self, Message.CharCode, Shift);
end; end;
*)
procedure THSColorPicker.SetHue(H: integer); procedure THSColorPicker.SetHue(H: integer);
begin begin
@ -415,16 +312,6 @@ begin
Invalidate; Invalidate;
end; end;
procedure THSColorPicker.SetMaxSat(S: Integer);
begin
if S = FMaxSat then
exit;
FMaxSat := S;
FGradientHeight := FMaxSat + 1;
CreateGradient;
Invalidate;
end;
procedure THSColorPicker.SetMaxLum(L: Integer); procedure THSColorPicker.SetMaxLum(L: Integer);
begin begin
if L = FMaxLum then if L = FMaxLum then
@ -435,4 +322,32 @@ begin
if Assigned(OnChange) then OnChange(Self); if Assigned(OnChange) then OnChange(Self);
end; end;
procedure THSColorPicker.SetMaxSat(S: Integer);
begin
if S = FMaxSat then
exit;
FMaxSat := S;
FGradientHeight := FMaxSat + 1;
CreateGradient;
Invalidate;
end;
procedure THSColorPicker.SetSelectedColor(c: TColor);
var
L: Double;
begin
if WebSafe then c := GetWebSafe(c);
{$IFDEF USE_COLOR_TO_RGB}
ColorToHSL(c, FHue, FSat, L);
{$ELSE}
RGBtoHSL(c, FHue, FSat, L);
{$ENDIF}
FSelected := c;
FManual := false;
mxx := Round(FHue * Width);
myy := Round((1.0 - FSat) * Height);
Invalidate;
if Assigned(OnChange) then OnChange(Self);
end;
end. end.

365
components/mbColorLib/HSLColorPicker.pas
View File

@ -6,17 +6,10 @@ unit HSLColorPicker;
interface interface
{$I mxs.inc}
uses uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} SysUtils, Classes, Controls, Graphics, Forms, Menus, Themes,
Windows, Messages, HTMLColors, RGBHSLUtils, HSColorPicker, LColorPicker, mbBasicPicker;
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, Menus,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF}
RGBHSLUtils, HSColorPicker, LColorPicker, HTMLColors, mbBasicPicker;
type type
THSLColorPicker = class(TmbBasicPicker) THSLColorPicker = class(TmbBasicPicker)
@ -57,17 +50,14 @@ type
procedure SetLCursor(c: TCursor); procedure SetLCursor(c: TCursor);
procedure SetSelectedColor(Value: TColor); procedure SetSelectedColor(Value: TColor);
protected protected
procedure CreateWnd; override;
procedure DoChange; procedure DoChange;
procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
function GetColorUnderCursor: TColor; override; function GetColorUnderCursor: TColor; 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 HSPickerChange(Sender: TObject); procedure HSPickerChange(Sender: TObject);
procedure LPickerChange(Sender: TObject); procedure LPickerChange(Sender: TObject);
procedure Paint; override;
procedure Resize; override;
procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; destructor Destroy; override;
@ -103,13 +93,11 @@ type
property TabOrder; property TabOrder;
property Color; property Color;
property ParentColor default true; property ParentColor default true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
property ParentBackground default true;
{$ENDIF}{$ENDIF}
property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnMouseMove; property OnMouseMove;
end; end;
implementation implementation
{THSLColorPicker} {THSLColorPicker}
@ -121,15 +109,10 @@ constructor THSLColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
// ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; // ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];
//DoubleBuffered := true;
PBack := TBitmap.Create; PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit; PBack.PixelFormat := pf32bit;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF} {$ENDIF}
SetInitialBounds(0, 0, 206, 146); SetInitialBounds(0, 0, 206, 146);
//Width := 206;
//Height := 146;
TabStop := true; TabStop := true;
FSelectedColor := clRed; FSelectedColor := clRed;
FHSPicker := THSColorPicker.Create(Self); FHSPicker := THSColorPicker.Create(Self);
@ -140,14 +123,7 @@ begin
with FHSPicker do with FHSPicker do
begin begin
{$IFDEF DELPHI}
Left := 0;
Top := 6;
Width := 174;
Height := 134;
{$ELSE}
SetInitialBounds(0, 6, 174, 134); SetInitialBounds(0, 6, 174, 134);
{$ENDIF}
Anchors := [akLeft, akTop, akRight, akBottom]; Anchors := [akLeft, akTop, akRight, akBottom];
Visible := true; Visible := true;
MaxHue := 359; MaxHue := 359;
@ -162,27 +138,20 @@ begin
with FLPicker do with FLPicker do
begin begin
Layout := lyVertical; Layout := lyVertical;
{$IFDEF DELPHI}
Left := 184;
Top := 0;
Width := 25;
Height := 146;
{$ELSE}
SetInitialBounds(184, 0, 25, 146); SetInitialBounds(184, 0, 25, 146);
{$ENDIF}
Anchors := [akRight, akTop, akBottom]; Anchors := [akRight, akTop, akBottom];
Visible := true; Visible := true;
MaxHue := 359; MaxHue := FHSPicker.MaxHue;
MaxSaturation := 240; MaxSaturation := FHSPicker.MaxSaturation;
MaxLuminance := 240; MaxLuminance := FHSPicker.MaxLuminance;
Luminance := 120; Luminance := MaxLuminance div 2;
OnChange := LPickerChange; OnChange := LPickerChange;
OnMouseMove := DoMouseMove; OnMouseMove := DoMouseMove;
end; end;
Hue := 0; Hue := 0;
Saturation := 240; Saturation := FHSPicker.MaxLuminance;
Luminance := 120; Luminance := FHSPicker.MaxLuminance div 2;
FRValue := 255; FRValue := 255;
FGValue := 0; FGValue := 0;
FBValue := 0; FBValue := 0;
@ -193,26 +162,9 @@ end;
destructor THSLColorPicker.Destroy; destructor THSLColorPicker.Destroy;
begin begin
PBack.Free; PBack.Free;
//FHSPicker.Free;
//FLPicker.Free;
inherited Destroy; inherited Destroy;
end; end;
procedure THSLColorPicker.HSPickerChange(Sender: TObject);
begin
FLPicker.Hue := FHSPicker.Hue;
FLPicker.Saturation := FHSPicker.Saturation;
FLPicker.Invalidate;
DoChange;
end;
procedure THSLColorPicker.LPickerChange(Sender: TObject);
begin
// FHSPicker.Lum := FLPicker.Luminance;
FSelectedColor := FLPicker.SelectedColor;
DoChange;
end;
procedure THSLColorPicker.DoChange; procedure THSLColorPicker.DoChange;
begin begin
FRValue := GetRValue(FLPicker.SelectedColor); FRValue := GetRValue(FLPicker.SelectedColor);
@ -222,11 +174,28 @@ begin
FOnChange(Self); FOnChange(Self);
end; end;
procedure THSLColorPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if Assigned(OnMouseMove) then
OnMouseMove(Self, Shift, x, y);
inherited;
end;
function THSLColorPicker.GetColorUnderCursor: TColor;
begin
Result := FHSPicker.ColorUnderCursor;
end;
function THSLColorPicker.GetH: Integer; function THSLColorPicker.GetH: Integer;
begin begin
Result := FHSPicker.Hue; Result := FHSPicker.Hue;
end; end;
function THSLColorPicker.GetHexColorUnderCursor: string;
begin
Result := FHSPicker.GetHexColorUnderCursor;
end;
function THSLColorPicker.GetS: Integer; function THSLColorPicker.GetS: Integer;
begin begin
Result := FHSPicker.Saturation; Result := FHSPicker.Saturation;
@ -237,6 +206,11 @@ begin
Result := FLPicker.Luminance; Result := FLPicker.Luminance;
end; end;
function THSLColorPicker.GetManual:boolean;
begin
Result := FHSPicker.Manual or FLPicker.Manual;
end;
function THSLColorPicker.GetMaxH: Integer; function THSLColorPicker.GetMaxH: Integer;
begin begin
Result := FHSPicker.MaxHue; Result := FHSPicker.MaxHue;
@ -252,162 +226,25 @@ begin
Result := FLPicker.MaxLuminance; Result := FLPicker.MaxLuminance;
end; end;
procedure THSLColorPicker.SelectColor(c: TColor);
begin
FSelectedColor := c;
FHSPicker.SelectedColor := c;
FLPicker.SelectedColor := c;
end;
procedure THSLColorPicker.SetH(H: integer);
begin
FHSPicker.Hue := H;
FLPicker.Hue := H;
end;
procedure THSLColorPicker.SetS(S: integer);
begin
FHSPicker.Saturation := S;
FLPicker.Saturation := S;
end;
procedure THSLColorPicker.SetL(L: integer);
begin
FLPicker.Luminance := L;
end;
procedure THSLColorPicker.SetMaxH(H: Integer);
begin
FHSPicker.MaxHue := H;
FLPicker.MaxHue := H;
end;
procedure THSLColorPicker.SetMaxS(S: Integer);
begin
FHSPicker.MaxSaturation := S;
FLPicker.MaxSaturation := S;
end;
procedure THSLColorPicker.SetMaxL(L: Integer);
begin
FHSPicker.MaxLuminance := L;
FLPicker.MaxLuminance := L;
end;
procedure THSLColorPicker.SetR(R: integer);
begin
FRValue := R;
SetSelectedColor(RGB(FRValue, FGValue, FBValue));
end;
procedure THSLColorPicker.SetG(G: integer);
begin
FGValue := G;
SetSelectedColor(RGB(FRValue, FGValue, FBValue));
end;
procedure THSLColorPicker.SetB(B: integer);
begin
FBValue := B;
SetSelectedColor(RGB(FRValue, FGValue, FBValue));
end;
function THSLColorPicker.GetSelectedHexColor: string; function THSLColorPicker.GetSelectedHexColor: string;
begin begin
Result := ColorToHex(FSelectedColor); Result := ColorToHex(FSelectedColor);
end; end;
procedure THSLColorPicker.SetHSHint(h: string); procedure THSLColorPicker.HSPickerChange(Sender: TObject);
begin begin
FHSHint := h; FLPicker.Hue := FHSPicker.Hue;
FHSPicker.HintFormat := h; FLPicker.Saturation := FHSPicker.Saturation;
FLPicker.Invalidate;
DoChange;
end; end;
procedure THSLColorPicker.SetLHint(h: string); procedure THSLColorPicker.LPickerChange(Sender: TObject);
begin begin
FLHint := h; FSelectedColor := FLPicker.SelectedColor;
FLPicker.HintFormat := h; DoChange;
end; end;
procedure THSLColorPicker.SetLMenu(m: TPopupMenu);
begin
FLMenu := m;
FLPicker.PopupMenu := m;
end;
procedure THSLColorPicker.SetHSMenu(m: TPopupMenu);
begin
FHSMenu := m;
FHSPicker.PopupMenu := m;
end;
procedure THSLColorPicker.SetLumIncrement(i: integer);
begin
FLumIncrement := i;
FLPicker.Increment := i;
end;
procedure THSLColorPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if Assigned(OnMouseMove) then
OnMouseMove(Self, Shift, x, y);
inherited;
end;
function THSLColorPicker.GetColorUnderCursor: TColor;
begin
Result := FHSPicker.ColorUnderCursor;
end;
function THSLColorPicker.GetHexColorUnderCursor: string;
begin
Result := FHSPicker.GetHexColorUnderCursor;
end;
procedure THSLColorPicker.SetHSCursor(c: TCursor);
begin
FHSCursor := c;
FHSPicker.Cursor := c;
end;
procedure THSLColorPicker.SetLCursor(c: TCursor);
begin
FLCursor := c;
FLPicker.Cursor := c;
end;
procedure THSLColorPicker.WMSetFocus(
var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF} );
begin
FHSPicker.SetFocus;
Message.Result := 1;
end;
function THSLColorPicker.GetManual:boolean;
begin
Result := FHSPicker.Manual or FLPicker.Manual;
end;
(*
procedure THSLColorPicker.PaintParentBack;
begin
if PBack = nil then
begin
PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit;
end;
PBack.Width := Width;
PBack.Height := Height;
if Color = clDefault then begin
PBack.Transparent := true;
PBack.TransparentColor := clForm;
PBack.Canvas.Brush.Color := clForm;
end else
PBack.Canvas.Brush.Color := Color;
PBack.Canvas.FillRect(0, 0, Width, Height);
// PaintParentBack(PBack);
end;
*)
procedure THSLColorPicker.Resize; procedure THSLColorPicker.Resize;
begin begin
inherited; inherited;
@ -422,18 +259,114 @@ begin
FLPicker.Height := Height; // - 12; FLPicker.Height := Height; // - 12;
end; end;
procedure THSLColorPicker.CreateWnd;
begin
inherited;
// PaintParentBack;
end;
procedure THSLColorPicker.Paint; procedure THSLColorPicker.Paint;
begin begin
PaintParentBack(Canvas); PaintParentBack(Canvas);
Canvas.Draw(0, 0, PBack); Canvas.Draw(0, 0, PBack);
end; end;
procedure THSLColorPicker.SelectColor(c: TColor);
begin
FSelectedColor := c;
FHSPicker.SelectedColor := c;
FLPicker.SelectedColor := c;
end;
procedure THSLColorPicker.SetB(B: integer);
begin
FBValue := B;
SetSelectedColor(RGB(FRValue, FGValue, FBValue));
end;
procedure THSLColorPicker.SetG(G: integer);
begin
FGValue := G;
SetSelectedColor(RGB(FRValue, FGValue, FBValue));
end;
procedure THSLColorPicker.SetH(H: integer);
begin
FHSPicker.Hue := H;
FLPicker.Hue := H;
end;
procedure THSLColorPicker.SetHSCursor(c: TCursor);
begin
FHSCursor := c;
FHSPicker.Cursor := c;
end;
procedure THSLColorPicker.SetHSHint(h: string);
begin
FHSHint := h;
FHSPicker.HintFormat := h;
end;
procedure THSLColorPicker.SetHSMenu(m: TPopupMenu);
begin
FHSMenu := m;
FHSPicker.PopupMenu := m;
end;
procedure THSLColorPicker.SetL(L: integer);
begin
FLPicker.Luminance := L;
end;
procedure THSLColorPicker.SetLHint(h: string);
begin
FLHint := h;
FLPicker.HintFormat := h;
end;
procedure THSLColorPicker.SetLMenu(m: TPopupMenu);
begin
FLMenu := m;
FLPicker.PopupMenu := m;
end;
procedure THSLColorPicker.SetLumIncrement(i: integer);
begin
FLumIncrement := i;
FLPicker.Increment := i;
end;
procedure THSLColorPicker.SetLCursor(c: TCursor);
begin
FLCursor := c;
FLPicker.Cursor := c;
end;
procedure THSLColorPicker.SetMaxH(H: Integer);
begin
FHSPicker.MaxHue := H;
FLPicker.MaxHue := H;
end;
procedure THSLColorPicker.SetMaxL(L: Integer);
begin
FHSPicker.MaxLuminance := L;
FLPicker.MaxLuminance := L;
end;
procedure THSLColorPicker.SetMaxS(S: Integer);
begin
FHSPicker.MaxSaturation := S;
FLPicker.MaxSaturation := S;
end;
procedure THSLColorPicker.SetR(R: integer);
begin
FRValue := R;
SetSelectedColor(RGB(FRValue, FGValue, FBValue));
end;
procedure THSLColorPicker.SetS(S: integer);
begin
FHSPicker.Saturation := S;
FLPicker.Saturation := S;
end;
procedure THSLColorPicker.SetSelectedColor(Value: TColor); procedure THSLColorPicker.SetSelectedColor(Value: TColor);
begin begin
if FSelectedColor <> Value then if FSelectedColor <> Value then
@ -444,4 +377,12 @@ begin
end; end;
end; end;
procedure THSLColorPicker.WMSetFocus(
var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF} );
begin
FHSPicker.SetFocus;
Message.Result := 1;
end;
end. end.

367
components/mbColorLib/HSLRingPicker.pas
View File

@ -6,16 +6,9 @@ unit HSLRingPicker;
interface interface
{$I mxs.inc}
uses uses
{$IFDEF FPC} LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics,
LCLIntf, LCLType, LMessages, Forms, Menus, Math, Themes,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, Menus, Math,
{$IFDEF DELPHI_7_UP}Themes,{$ENDIF}
RGBHSLUtils, HRingPicker, SLColorPicker, HTMLColors, mbBasicPicker; RGBHSLUtils, HRingPicker, SLColorPicker, HTMLColors, mbBasicPicker;
type type
@ -61,20 +54,13 @@ type
procedure Paint; override; procedure Paint; override;
procedure Resize; override; procedure Resize; override;
procedure RingPickerChange(Sender: TObject); procedure RingPickerChange(Sender: TObject);
procedure SetFocus; override;
procedure SLPickerChange(Sender: TObject); procedure SLPickerChange(Sender: TObject);
(*
{$IFDEF DELPHI}
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
{$ELSE}
procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS;
{$ENDIF}
*)
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; destructor Destroy; override;
function GetHexColorUnderCursor: string; override; function GetHexColorUnderCursor: string; override;
function GetSelectedHexColor: string; function GetSelectedHexColor: string;
procedure SetFocus; override;
property ColorUnderCursor; property ColorUnderCursor;
property Hue: integer read GetHue write SetHue; property Hue: integer read GetHue write SetHue;
property Saturation: integer read GetSat write SetSat; property Saturation: integer read GetSat write SetSat;
@ -119,22 +105,13 @@ constructor THSLRingPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
// ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}]; // ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}];
//DoubleBuffered := true;
FRValue := 255; FRValue := 255;
FGValue := 0; FGValue := 0;
FBValue := 0; FBValue := 0;
PBack := TBitmap.Create; PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit; PBack.PixelFormat := pf32bit;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF} {$ENDIF}
{$IFDEF DELPHI}
Width := 245;
Height := 245;
{$ELSE}
SetInitialBounds(0, 0, 245, 245); SetInitialBounds(0, 0, 245, 245);
{$ENDIF}
TabStop := true; TabStop := true;
FSelectedColor := clRed; FSelectedColor := clRed;
FRingCursor := crDefault; FRingCursor := crDefault;
@ -146,14 +123,7 @@ begin
InsertControl(FRingPicker); InsertControl(FRingPicker);
with FRingPicker do with FRingPicker do
begin begin
{$IFDEF DELPHI}
Left := 0;
Top := 0;
Width := 246;
Height := 246;
{$ELSE}
SetInitialBounds(0, 0, 246, 246); SetInitialBounds(0, 0, 246, 246);
{$ENDIF}
//Radius := 40; //Radius := 40;
Align := alClient; Align := alClient;
Visible := true; Visible := true;
@ -168,14 +138,7 @@ begin
InsertControl(FSLPicker); InsertControl(FSLPicker);
with FSLPicker do with FSLPicker do
begin begin
{$IFDEF DELPHI}
Left := 63;
Top := 63;
Width := 120;
Height := 120;
{$ELSE}
SetInitialBounds(63, 63, 120, 120); SetInitialBounds(63, 63, 120, 120);
{$ENDIF}
MaxSaturation := 240; MaxSaturation := 240;
MaxLuminance := 240; MaxLuminance := 240;
Saturation := 240; Saturation := 240;
@ -189,11 +152,90 @@ end;
destructor THSLRingPicker.Destroy; destructor THSLRingPicker.Destroy;
begin begin
PBack.Free; PBack.Free;
//FRingPicker.Free;
//FSLPicker.Free;
inherited Destroy; inherited Destroy;
end; end;
procedure THSLRingPicker.CreateWnd;
begin
inherited;
PaintParentBack(PBack);
end;
procedure THSLRingPicker.DoChange;
begin
if (FRingPicker = nil) or (FSLPicker = nil) then
exit;
FRValue := GetRValue(FSLPicker.SelectedColor);
FGValue := GetGValue(FSLPicker.SelectedColor);
FBValue := GetBValue(FSLPicker.SelectedColor);
if Assigned(FOnChange) then
FOnChange(Self);
end;
procedure THSLRingPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if Assigned(OnMouseMove) then
OnMouseMove(Self, Shift, x, y);
inherited;
end;
function THSLRingPicker.GetColorUnderCursor: TColor;
begin
Result := FSLPicker.ColorUnderCursor;
end;
function THSLRingPicker.GetHexColorUnderCursor: string;
begin
Result := FSLPicker.GetHexColorUnderCursor;
end;
function THSLRingPicker.GetHue: Integer;
begin
Result := FRingPicker.Hue;
end;
function THSLRingPicker.GetLum: Integer;
begin
Result := FSLPicker.Luminance;
end;
function THSLRingPicker.GetMaxHue: Integer;
begin
Result := FRingPicker.MaxHue;
end;
function THSLRingPicker.GetManual:boolean;
begin
Result := FRingPicker.Manual or FSLPicker.Manual;
end;
function THSLRingPicker.GetMaxSat: Integer;
begin
Result := FSLPicker.MaxSaturation;
end;
function THSLRingPicker.GetMaxLum: Integer;
begin
Result := FSLPicker.MaxLuminance;
end;
function THSLRingPicker.GetSat: Integer;
begin
Result := FSLPicker.Saturation;
end;
function THSLRingPicker.GetSelectedHexColor: string;
begin
Result := ColorToHex(FSelectedColor);
end;
procedure THSLRingPicker.Paint;
begin
PaintParentBack(PBack);
Canvas.Draw(0, 0, PBack);
end;
procedure THSLRingPicker.Resize; procedure THSLRingPicker.Resize;
var var
circ: TPoint; circ: TPoint;
@ -225,26 +267,6 @@ begin
DoChange; DoChange;
end; end;
procedure THSLRingPicker.SLPickerChange(Sender: TObject);
begin
if FSLPicker = nil then
exit;
FSelectedColor := FSLPicker.SelectedColor;
DoChange;
end;
procedure THSLRingPicker.DoChange;
begin
if (FRingPicker = nil) or (FSLPicker = nil) then
exit;
FRValue := GetRValue(FSLPicker.SelectedColor);
FGValue := GetGValue(FSLPicker.SelectedColor);
FBValue := GetBValue(FSLPicker.SelectedColor);
if Assigned(FOnChange) then
FOnChange(Self);
end;
procedure THSLRingPicker.SelectColor(c: TColor); procedure THSLRingPicker.SelectColor(c: TColor);
begin begin
if (FRingPicker = nil) or (FSLPicker = nil) then if (FRingPicker = nil) or (FSLPicker = nil) then
@ -258,6 +280,24 @@ begin
FSelectedColor := c; FSelectedColor := c;
end; end;
procedure THSLRingPicker.SetB(v: integer);
begin
FBValue := v;
SelectColor(RGB(FRValue, FGValue, FBValue));
end;
procedure THSLRingPicker.SetFocus;
begin
inherited;
FRingPicker.SetFocus;
end;
procedure THSLRingPicker.SetG(v: integer);
begin
FGValue := v;
SelectColor(RGB(FRValue, FGValue, FBValue));
end;
procedure THSLRingPicker.SetHue(H: integer); procedure THSLRingPicker.SetHue(H: integer);
begin begin
if (FRingPicker = nil) or (FSLPicker = nil) then if (FRingPicker = nil) or (FSLPicker = nil) then
@ -267,13 +307,6 @@ begin
FSLPicker.Hue := H; FSLPicker.Hue := H;
end; end;
procedure THSLRingPicker.SetSat(S: integer);
begin
if (FSLPicker = nil) then
exit;
FSLPicker.Saturation := S;
end;
procedure THSLRingPicker.SetLum(L: integer); procedure THSLRingPicker.SetLum(L: integer);
begin begin
if (FSLPicker = nil) then if (FSLPicker = nil) then
@ -281,143 +314,6 @@ begin
FSLPicker.Luminance := L; FSLPicker.Luminance := L;
end; end;
procedure THSLRingPicker.SetR(v: integer);
begin
FRValue := v;
SelectColor(RGB(FRValue, FGValue, FBValue));
end;
procedure THSLRingPicker.SetG(v: integer);
begin
FGValue := v;
SelectColor(RGB(FRValue, FGValue, FBValue));
end;
procedure THSLRingPicker.SetB(v: integer);
begin
FBValue := v;
SelectColor(RGB(FRValue, FGValue, FBValue));
end;
function THSLRingPicker.GetSelectedHexColor: string;
begin
Result := ColorToHex(FSelectedColor);
end;
procedure THSLRingPicker.SetRingHint(h: string);
begin
FRingHint := h;
FRingPicker.HintFormat := h;
end;
procedure THSLRingPicker.SetSLHint(h: string);
begin
FSLHint := h;
FSLPicker.HintFormat := h;
end;
procedure THSLRingPicker.SetRingMenu(m: TPopupMenu);
begin
FRingMenu := m;
FRingPicker.PopupMenu := m;
end;
procedure THSLRingPicker.SetSLMenu(m: TPopupMenu);
begin
FSLMenu := m;
FSLPicker.PopupMenu := m;
end;
procedure THSLRingPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if Assigned(OnMouseMove) then
OnMouseMove(Self, Shift, x, y);
inherited;
end;
function THSLRingPicker.GetColorUnderCursor: TColor;
begin
Result := FSLPicker.ColorUnderCursor;
end;
function THSLRingPicker.GetHexColorUnderCursor: string;
begin
Result := FSLPicker.GetHexColorUnderCursor;
end;
procedure THSLRingPicker.SetRingCursor(c: TCursor);
begin
FRingCursor := c;
FRingPicker.Cursor := c;
end;
procedure THSLRingPicker.SetSLCursor(c: TCursor);
begin
FSLCursor := c;
FSLPicker.Cursor := c;
end;
(*
procedure THSLRingPicker.WMSetFocus(
var Message: {$IFDEF DELPHI}TWMSetFocus{$ELSE}TLMSetFocus{$ENDIF} );
begin
FRingPicker.SetFocus;
Message.Result := 1;
end;
*)
procedure THSLRingPicker.SetFocus;
begin
inherited;
FRingPicker.SetFocus;
end;
function THSLRingPicker.GetManual:boolean;
begin
Result := FRingPicker.Manual or FSLPicker.Manual;
end;
procedure THSLRingPicker.Paint;
begin
PaintParentBack(PBack);
Canvas.Draw(0, 0, PBack);
end;
procedure THSLRingPicker.CreateWnd;
begin
inherited;
PaintParentBack(PBack);
end;
function THSLRingPicker.GetHue: Integer;
begin
Result := FRingPicker.Hue;
end;
function THSLRingPicker.GetSat: Integer;
begin
Result := FSLPicker.Saturation;
end;
function THSLRingPicker.GetLum: Integer;
begin
Result := FSLPicker.Luminance;
end;
function THSLRingPicker.GetMaxHue: Integer;
begin
Result := FRingPicker.MaxHue;
end;
function THSLRingPicker.GetMaxSat: Integer;
begin
Result := FSLPicker.MaxSaturation;
end;
function THSLRingPicker.GetMaxLum: Integer;
begin
Result := FSLPicker.MaxLuminance;
end;
procedure THSLRingPicker.SetMaxHue(H: Integer); procedure THSLRingPicker.SetMaxHue(H: Integer);
begin begin
FRingPicker.MaxHue := H; FRingPicker.MaxHue := H;
@ -433,4 +329,61 @@ begin
FSLPicker.MaxSaturation := S; FSLPicker.MaxSaturation := S;
end; end;
procedure THSLRingPicker.SetR(v: integer);
begin
FRValue := v;
SelectColor(RGB(FRValue, FGValue, FBValue));
end;
procedure THSLRingPicker.SetRingCursor(c: TCursor);
begin
FRingCursor := c;
FRingPicker.Cursor := c;
end;
procedure THSLRingPicker.SetRingHint(h: string);
begin
FRingHint := h;
FRingPicker.HintFormat := h;
end;
procedure THSLRingPicker.SetRingMenu(m: TPopupMenu);
begin
FRingMenu := m;
FRingPicker.PopupMenu := m;
end;
procedure THSLRingPicker.SetSat(S: integer);
begin
if (FSLPicker = nil) then
exit;
FSLPicker.Saturation := S;
end;
procedure THSLRingPicker.SetSLCursor(c: TCursor);
begin
FSLCursor := c;
FSLPicker.Cursor := c;
end;
procedure THSLRingPicker.SetSLHint(h: string);
begin
FSLHint := h;
FSLPicker.HintFormat := h;
end;
procedure THSLRingPicker.SetSLMenu(m: TPopupMenu);
begin
FSLMenu := m;
FSLPicker.PopupMenu := m;
end;
procedure THSLRingPicker.SLPickerChange(Sender: TObject);
begin
if FSLPicker = nil then
exit;
FSelectedColor := FSLPicker.SelectedColor;
DoChange;
end;
end. end.

663
components/mbColorLib/HSVColorPicker.pas
View File

@ -7,14 +7,8 @@ unit HSVColorPicker;
interface interface
uses uses
{$IFDEF FPC} LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics, Math, Forms, Themes,
LCLIntf, LCLType, LMessages, RGBHSVUtils, Scanlines, HTMLColors, mbColorPickerControl;
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, RGBHSVUtils, Scanlines,
Forms, {$IFDEF DELPHI_7_UP}Themes,{$ENDIF}
HTMLColors, mbColorPickerControl;
type type
THSVColorPicker = class(TmbColorPickerControl) THSVColorPicker = class(TmbColorPickerControl)
@ -50,21 +44,16 @@ type
procedure UpdateCoords; procedure UpdateCoords;
protected protected
procedure CreateGradient; override; procedure CreateGradient; override;
procedure CreateWnd; override;
function GetGradientColor2D(X, Y: Integer): TColor; override; function GetGradientColor2D(X, Y: Integer): TColor; override;
function GetSelectedColor: TColor; override; function GetSelectedColor: TColor; override;
procedure SetSelectedColor(c: TColor); override;
procedure Paint; override; procedure Paint; override;
procedure Resize; override; procedure Resize; override;
procedure CreateWnd; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
// function MouseOnPicker(X, Y: Integer): Boolean; override; procedure MouseMove(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 SetSelectedColor(c: TColor); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
*)
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
function GetColorAtPoint(x, y: integer): TColor; override; function GetColorAtPoint(x, y: integer): TColor; override;
@ -95,12 +84,7 @@ uses
constructor THSVColorPicker.Create(AOwner: TComponent); constructor THSVColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
{$IFDEF DELPHI}
Width := 204;
Height := 204;
{$ELSE}
SetInitialBounds(0, 0, 204, 204); SetInitialBounds(0, 0, 204, 204);
{$ENDIF}
FMaxHue := 359; FMaxHue := 359;
FMaxSat := 255; FMaxSat := 255;
FMaxValue := 255; FMaxValue := 255;
@ -119,30 +103,6 @@ begin
MarkerStyle := msCrossCirc; MarkerStyle := msCrossCirc;
end; end;
procedure THSVColorPicker.Paint;
var
rgn: HRGN;
R: TRect;
begin
PaintParentBack(Canvas);
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, FBufferBmp);
DeleteObject(rgn);
DrawSatCirc;
DrawHueLine;
DrawMarker(mdx, mdy);
if FDoChange then
begin
if Assigned(FOnChange) then FOnChange(Self);
FDoChange := false;
end;
end;
procedure THSVColorPicker.CreateGradient; procedure THSVColorPicker.CreateGradient;
begin begin
FGradientWidth := Min(Width, Height); FGradientWidth := Min(Width, Height);
@ -150,59 +110,6 @@ begin
inherited; inherited;
end; end;
{ Outer loop: Y, Inner loop: X }
function THSVColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
var
dx, dy: Integer;
dSq, radiusSq: Integer;
radius, size: Integer;
S, H, V: Double;
q: TRGBQuad;
begin
size := FGradientWidth; // or Height, they are the same...
radius := size div 2;
radiusSq := sqr(radius);
dx := X - radius;
dy := Y - radius;
dSq := sqr(dx) + sqr(dy);
if dSq <= radiusSq then
begin
if radius <> 0 then
S := sqrt(dSq) / radius
else
S := 0;
H := 180 * (1 + arctan2(dx, dy) / pi); // wp: order (x,y) is correct!
H := H + 90;
if H > 360 then H := H - 360;
Result := HSVtoColor(H/360, S, FValue);
if WebSafe then
Result := GetWebSafe(Result);
end else
Result := GetDefaultColor(dctBrush);
end;
function THSVColorPicker.GetHue: Integer;
begin
Result := round(FHue * FMaxHue);
end;
function THSVColorPicker.GetSat: Integer;
begin
Result := round(FSat * FMaxSat);
end;
function THSVColorPicker.GetValue: Integer;
begin
Result := round(FValue * FMaxValue);
end;
procedure THSVColorPicker.Resize;
begin
inherited;
CreateGradient;
UpdateCoords;
end;
procedure THSVColorPicker.CreateWnd; procedure THSVColorPicker.CreateWnd;
begin begin
inherited; inherited;
@ -210,136 +117,6 @@ begin
UpdateCoords; UpdateCoords;
end; end;
procedure THSVColorPicker.UpdateCoords;
var
r, angle: double;
sinAngle, cosAngle: Double;
radius: integer;
begin
radius := Min(Width, Height) div 2;
r := -FSat * radius;
angle := -(FHue * 2 + 1) * pi;
SinCos(angle, sinAngle, cosAngle);
mdx := round(cosAngle * r) + radius;
mdy := round(sinAngle * r) + radius;
end;
procedure THSVColorPicker.SetHue(h: integer);
begin
if h > FMaxHue then h := h - (FMaxHue + 1);
if h < 0 then h := h + (FMaxHue + 1);
// Clamp(h, 0, FMaxHue);
if GetHue() <> h then
begin
FHue := h / FMaxHue;
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure THSVColorPicker.SetSat(s: integer);
begin
Clamp(s, 0, FMaxSat);
if GetSat() <> s then
begin
FSat := s / FMaxSat;
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure THSVColorPicker.SetValue(V: integer);
begin
Clamp(V, 0, FMaxValue);
if GetValue() <> V then
begin
FValue := V / FMaxValue;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure THSVColorPicker.SetMaxHue(h: Integer);
begin
if h = FMaxHue then
exit;
FMaxHue := h;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
procedure THSVColorPicker.SetMaxSat(s: Integer);
begin
if s = FMaxSat then
exit;
FMaxSat := s;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
procedure THSVColorPicker.SetMaxValue(v: Integer);
begin
if v = FMaxValue then
exit;
FMaxValue := v;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
procedure THSVColorPicker.SetSatCircColor(c: TColor);
begin
if FSatCircColor <> c then
begin
FSatCircColor := c;
Invalidate;
end;
end;
procedure THSVColorPicker.SetHueLineColor(c: TColor);
begin
if FHueLineColor <> c then
begin
FHueLineColor := c;
Invalidate;
end;
end;
procedure THSVColorPicker.SetShowSatCirc(s: boolean);
begin
if FShowSatCirc <> s then
begin
FShowSatCirc := s;
Invalidate;
end;
end;
procedure THSVColorPicker.SetShowSelCirc(s: boolean);
begin
if FShowSelCirc <> s then
begin
FShowSelCirc := s;
Invalidate;
end;
end;
procedure THSVColorPicker.SetShowHueLine(s: boolean);
begin
if FShowHueLine <> s then
begin
FShowHueLine := s;
Invalidate;
end;
end;
procedure THSVColorPicker.DrawSatCirc; procedure THSVColorPicker.DrawSatCirc;
var var
delta: integer; delta: integer;
@ -389,39 +166,89 @@ begin
InternalDrawMarker(x, y, c); InternalDrawMarker(x, y, c);
end; end;
procedure THSVColorPicker.SelectionChanged(x, y: integer); function THSVColorPicker.GetColorAtPoint(x, y: integer): TColor;
var var
angle: Double; angle: Double;
dx, dy, r, radius: integer; dx, dy, r, radius: integer;
h, s: double;
begin begin
radius := Min(Width, Height) div 2; radius := Min(Width, Height) div 2;
dx := x - radius; dx := x - Radius;
dy := y - radius; dy := y - Radius;
r := round(sqrt(sqr(dx) + sqr(dy))); r := round(sqrt(sqr(dx) + sqr(dy)));
if r <= radius then
if r > radius then // point outside circle
begin begin
FChange := false; angle := 360 + 180 * arctan2(-dy, dx) / pi;
SetSelectedColor(clNone); if angle < 0 then
FChange := true; angle := angle + 360
exit; else if angle > 360 then
end; angle := angle - 360;
h := angle / 360;
s := r / radius;
Result := HSVtoColor(h, s, FValue);
if WebSafe then
Result := GetWebSafe(Result);
end else
Result := clNone;
end;
FSelectedColor := clWhite; { Outer loop: Y, Inner loop: X }
angle := 360 + 180*arctan2(-dy, dx) / pi; // wp: "-y, x" correct? The others have "x, y" function THSVColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
if angle < 0 then var
angle := angle + 360 dx, dy: Integer;
else if angle > 360 then dSq, radiusSq: Integer;
angle := angle - 360; radius, size: Integer;
FChange := false; S, H, V: Double;
FHue := angle / 360; q: TRGBQuad;
if r > radius then begin
FSat := 1.0 size := FGradientWidth; // or Height, they are the same...
radius := size div 2;
radiusSq := sqr(radius);
dx := X - radius;
dy := Y - radius;
dSq := sqr(dx) + sqr(dy);
if dSq <= radiusSq then
begin
if radius <> 0 then
S := sqrt(dSq) / radius
else
S := 0;
H := 180 * (1 + arctan2(dx, dy) / pi); // wp: order (x,y) is correct!
H := H + 90;
if H > 360 then H := H - 360;
Result := HSVtoColor(H/360, S, FValue);
if WebSafe then
Result := GetWebSafe(Result);
end else
Result := GetDefaultColor(dctBrush);
end;
function THSVColorPicker.GetHue: Integer;
begin
Result := round(FHue * FMaxHue);
end;
function THSVColorPicker.GetSat: Integer;
begin
Result := round(FSat * FMaxSat);
end;
function THSVColorPicker.GetSelectedColor: TColor;
begin
if FSelectedColor <> clNone then
begin
Result := HSVtoColor(FHue, FSat, FValue);
if WebSafe then
Result := GetWebSafe(Result);
end
else else
FSat := r / radius; Result := clNone;
FChange := true; end;
Invalidate; function THSVColorPicker.GetValue: Integer;
begin
Result := round(FValue * FMaxValue);
end; end;
procedure THSVColorPicker.KeyDown(var Key: Word; Shift: TShiftState); procedure THSVColorPicker.KeyDown(var Key: Word; Shift: TShiftState);
@ -476,31 +303,8 @@ begin
inherited; inherited;
end; end;
procedure THSVColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
{$IFDEF DELPHI}
ClipCursor(nil);
{$ENDIF}
if csDesigning in ComponentState then
exit;
if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then
begin
mdx := x;
mdy := y;
FDoChange := true;
SelectionChanged(X, Y);
FManual := true;
end;
end;
procedure THSVColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; procedure THSVColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); X, Y: Integer);
{$IFDEF DELPHI}
var
R: TRect;
{$ENDIF}
begin begin
inherited; inherited;
if csDesigning in ComponentState then if csDesigning in ComponentState then
@ -509,13 +313,6 @@ begin
begin begin
mdx := x; mdx := x;
mdy := y; mdy := y;
{$IFDEF DELPHI}
R := ClientRect;
InflateRect(R, 1, 1);
R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight);
ClipCursor(@R);
{$ENDIF}
FDoChange := true; FDoChange := true;
SelectionChanged(X, Y); SelectionChanged(X, Y);
FManual := true; FManual := true;
@ -537,56 +334,169 @@ begin
FManual := true; FManual := true;
end; end;
end; end;
(*
function THSVColorPicker.MouseOnPicker(X, Y: Integer): Boolean; procedure THSVColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
var X, Y: Integer);
diameter, r: Integer;
P, ctr: TPoint;
begin begin
diameter := Min(Width, Height); inherited;
r := diameter div 2; if csDesigning in ComponentState then
P := Point(x, y); exit;
ctr := Point(r, r); if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then
Result := PtInCircle(P, ctr, r);
end;
*)
function THSVColorPicker.GetSelectedColor: TColor;
begin
if FSelectedColor <> clNone then
begin begin
Result := HSVtoColor(FHue, FSat, FValue); mdx := x;
if WebSafe then mdy := y;
Result := GetWebSafe(Result); FDoChange := true;
end SelectionChanged(X, Y);
else FManual := true;
Result := clNone; end;
end; end;
function THSVColorPicker.GetColorAtPoint(x, y: integer): TColor; procedure THSVColorPicker.Paint;
var
rgn: HRGN;
R: TRect;
begin
PaintParentBack(Canvas);
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, FBufferBmp);
DeleteObject(rgn);
DrawSatCirc;
DrawHueLine;
DrawMarker(mdx, mdy);
if FDoChange then
begin
if Assigned(FOnChange) then FOnChange(Self);
FDoChange := false;
end;
end;
function THSVColorPicker.RadHue(New: integer): integer;
begin
if New < 0 then New := New + (FMaxHue + 1);
if New > (FMaxHue + 1) then New := New - (FMaxHue + 1);
Result := New;
end;
procedure THSVColorPicker.Resize;
begin
inherited;
CreateGradient;
UpdateCoords;
end;
procedure THSVColorPicker.SelectionChanged(x, y: integer);
var var
angle: Double; angle: Double;
dx, dy, r, radius: integer; dx, dy, r, radius: integer;
h, s: double;
begin begin
radius := Min(Width, Height) div 2; radius := Min(Width, Height) div 2;
dx := x - Radius; dx := x - radius;
dy := y - Radius; dy := y - radius;
r := round(sqrt(sqr(dx) + sqr(dy))); r := round(sqrt(sqr(dx) + sqr(dy)));
if r <= radius then
if r > radius then // point outside circle
begin begin
angle := 360 + 180 * arctan2(-dy, dx) / pi; FChange := false;
if angle < 0 then SetSelectedColor(clNone);
angle := angle + 360 FChange := true;
else if angle > 360 then exit;
angle := angle - 360; end;
h := angle / 360;
s := r / radius; FSelectedColor := clWhite;
Result := HSVtoColor(h, s, FValue); angle := 360 + 180*arctan2(-dy, dx) / pi; // wp: "-y, x" correct? The others have "x, y"
if WebSafe then if angle < 0 then
Result := GetWebSafe(Result); angle := angle + 360
end else else if angle > 360 then
Result := clNone; angle := angle - 360;
FChange := false;
FHue := angle / 360;
if r > radius then
FSat := 1.0
else
FSat := r / radius;
FChange := true;
Invalidate;
end;
procedure THSVColorPicker.SetHue(h: integer);
begin
if h > FMaxHue then h := h - (FMaxHue + 1);
if h < 0 then h := h + (FMaxHue + 1);
if GetHue() <> h then
begin
FHue := h / FMaxHue;
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure THSVColorPicker.SetHueLineColor(c: TColor);
begin
if FHueLineColor <> c then
begin
FHueLineColor := c;
Invalidate;
end;
end;
procedure THSVColorPicker.SetMaxHue(h: Integer);
begin
if h = FMaxHue then
exit;
FMaxHue := h;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
procedure THSVColorPicker.SetMaxSat(s: Integer);
begin
if s = FMaxSat then
exit;
FMaxSat := s;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
procedure THSVColorPicker.SetMaxValue(v: Integer);
begin
if v = FMaxValue then
exit;
FMaxValue := v;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
procedure THSVColorPicker.SetSat(s: integer);
begin
Clamp(s, 0, FMaxSat);
if GetSat() <> s then
begin
FSat := s / FMaxSat;
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure THSVColorPicker.SetSatCircColor(c: TColor);
begin
if FSatCircColor <> c then
begin
FSatCircColor := c;
Invalidate;
end;
end; end;
procedure THSVColorPicker.SetSelectedColor(c: TColor); procedure THSVColorPicker.SetSelectedColor(c: TColor);
@ -607,69 +517,58 @@ begin
FChange := true; FChange := true;
end; end;
function THSVColorPicker.RadHue(New: integer): integer; procedure THSVColorPicker.SetShowHueLine(s: boolean);
begin begin
if New < 0 then New := New + (FMaxHue + 1); if FShowHueLine <> s then
if New > (FMaxHue + 1) then New := New - (FMaxHue + 1); begin
Result := New; FShowHueLine := s;
end; Invalidate;
(*
procedure THSVColorPicker.CNKeyDown(
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} );
var
shift: TShiftState;
FInherited: boolean;
delta: Integer;
begin
FInherited := false;
shift := KeyDataToShiftState(Message.KeyData);
if ssCtrl in shift then
delta := 10
else
delta := 1;
case Message.CharCode of
VK_LEFT:
begin
FChange := false;
SetHue(RadHue(GetHue() + delta));
FChange := true;
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
VK_RIGHT:
begin
FChange := false;
SetHue(RadHue(GetHue() - delta));
FChange := true;
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
VK_UP:
begin
FChange := false;
SetSat(GetSat() + delta);
FChange := true;
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
VK_DOWN:
begin
FChange := false;
SetSat(GetSat() - delta);
FChange := true;
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
else
begin
FInherited := true;
inherited;
end;
end; end;
if not FInherited then
if Assigned(OnKeyDown) then
OnKeyDown(Self, Message.CharCode, Shift);
end; end;
*)
procedure THSVColorPicker.SetShowSatCirc(s: boolean);
begin
if FShowSatCirc <> s then
begin
FShowSatCirc := s;
Invalidate;
end;
end;
procedure THSVColorPicker.SetShowSelCirc(s: boolean);
begin
if FShowSelCirc <> s then
begin
FShowSelCirc := s;
Invalidate;
end;
end;
procedure THSVColorPicker.SetValue(V: integer);
begin
Clamp(V, 0, FMaxValue);
if GetValue() <> V then
begin
FValue := V / FMaxValue;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure THSVColorPicker.UpdateCoords;
var
r, angle: double;
sinAngle, cosAngle: Double;
radius: integer;
begin
radius := Min(Width, Height) div 2;
r := -FSat * radius;
angle := -(FHue * 2 + 1) * pi;
SinCos(angle, sinAngle, cosAngle);
mdx := round(cosAngle * r) + radius;
mdy := round(sinAngle * r) + radius;
end;
end. end.

268
components/mbColorLib/HTMLColors.pas
View File

@ -2,125 +2,131 @@ unit HTMLColors;
interface interface
{$I mxs.inc}
uses uses
SysUtils, SysUtils, LCLIntf, Graphics, Variants;
{$IFDEF FPC}
LCLIntf,
{$ELSE}
Windows,
{$ENDIF}
Graphics{$IFDEF DELPHI_6_UP}, Variants{$ENDIF};
const const
SPECIAL_COUNT = 140; SPECIAL_COUNT = 140;
WEBSAFE_COUNT = 216; WEBSAFE_COUNT = 216;
SYSTEM_COUNT = 28; SYSTEM_COUNT = 28;
BASIC_COUNT = 16; BASIC_COUNT = 16;
SPECIAL_HEX: array [0..139] of string = ('000000', 'FAEBD7', '00FFFF', '7FFFD4', 'F0FFFF', 'F5F5DC', 'FFE4C4', SPECIAL_HEX: array [0..139] of string = (
'F0F8FF', 'FFEBCD', '0000FF', '8A2BE2', 'A52A2A', 'DEB887', '5F9EA0', '000000', 'FAEBD7', '00FFFF', '7FFFD4', 'F0FFFF', 'F5F5DC', 'FFE4C4',
'7FFF00', 'D2691E', 'FF7F50', '6495ED', 'FFF8DC', 'DC143C', '00FFFF', 'F0F8FF', 'FFEBCD', '0000FF', '8A2BE2', 'A52A2A', 'DEB887', '5F9EA0',
'00008B', '008B8B', 'B8860B', 'A9A9A9', '006400', 'BDB76B', '8B008B', '7FFF00', 'D2691E', 'FF7F50', '6495ED', 'FFF8DC', 'DC143C', '00FFFF',
'556B2F', 'FF8C00', '9932CC', '8B0000', 'E9967A', '8FBC8B', '483D8B', '00008B', '008B8B', 'B8860B', 'A9A9A9', '006400', 'BDB76B', '8B008B',
'2F4F4F', '00CED1', '9400D3', 'FF1493', '00BFFF', '696969', '1E90FF', '556B2F', 'FF8C00', '9932CC', '8B0000', 'E9967A', '8FBC8B', '483D8B',
'B22222', 'FFFAF0', '228B22', 'FF00FF', 'DCDCDC', 'F8F8FF', 'FFD700', '2F4F4F', '00CED1', '9400D3', 'FF1493', '00BFFF', '696969', '1E90FF',
'DAA520', '808080', '008000', 'ADFF2F', 'F0FFF0', 'FF69B4', 'CD5C5C', 'B22222', 'FFFAF0', '228B22', 'FF00FF', 'DCDCDC', 'F8F8FF', 'FFD700',
'4B0082', 'FFFFF0', 'F0E68C', 'E6E6FA', 'FFF0F5', '7CFC00', 'FFFACD', 'DAA520', '808080', '008000', 'ADFF2F', 'F0FFF0', 'FF69B4', 'CD5C5C',
'ADD8E6', 'F08080', 'E0FFFF', 'FAFAD2', '90EE90', 'D3D3D3', 'FFB6C1', '4B0082', 'FFFFF0', 'F0E68C', 'E6E6FA', 'FFF0F5', '7CFC00', 'FFFACD',
'FFA07A', '20B2AA', '87CEFA', '778899', 'B0C4DE', 'FFFFE0', '00FF00', 'ADD8E6', 'F08080', 'E0FFFF', 'FAFAD2', '90EE90', 'D3D3D3', 'FFB6C1',
'32CD32', 'FAF0E6', 'FF00FF', '800000', '66CDAA', '0000CD', 'BA55D3', 'FFA07A', '20B2AA', '87CEFA', '778899', 'B0C4DE', 'FFFFE0', '00FF00',
'9370DB', '3CB371', '7B68EE', '00FA9A', '48D1CC', 'C71585', '191970', '32CD32', 'FAF0E6', 'FF00FF', '800000', '66CDAA', '0000CD', 'BA55D3',
'F5FFFA', 'FFE4E1', 'FFE4B5', 'FFDEAD', '000080', 'FDF5E6', '808000', '9370DB', '3CB371', '7B68EE', '00FA9A', '48D1CC', 'C71585', '191970',
'6B8E23', 'FFA500', 'FF4500', 'DA70D6', 'EEE8AA', '98FB98', 'AFEEEE', 'F5FFFA', 'FFE4E1', 'FFE4B5', 'FFDEAD', '000080', 'FDF5E6', '808000',
'DB7093', 'FFEFD5', 'FFDAB9', 'CD853F', 'FFC0CB', 'DDA0DD', 'B0E0E6', '6B8E23', 'FFA500', 'FF4500', 'DA70D6', 'EEE8AA', '98FB98', 'AFEEEE',
'800080', 'FF0000', 'BC8F8F', '4169E1', '8B4513', 'FA8072', 'F4A460', 'DB7093', 'FFEFD5', 'FFDAB9', 'CD853F', 'FFC0CB', 'DDA0DD', 'B0E0E6',
'2E8B57', 'FFF5EE', 'A0522D', 'C0C0C0', '87CEEB', '6A5ACD', '708090', '800080', 'FF0000', 'BC8F8F', '4169E1', '8B4513', 'FA8072', 'F4A460',
'FFFAFA', '00FF7F', '4682B4', 'D2B48C', '008080', 'D8BFD8', 'FF6347', '2E8B57', 'FFF5EE', 'A0522D', 'C0C0C0', '87CEEB', '6A5ACD', '708090',
'40E0D0', 'EE82EE', 'F5DEB3', 'FFFFFF', 'F5F5F5', 'FFFF00', '9ACD32'); 'FFFAFA', '00FF7F', '4682B4', 'D2B48C', '008080', 'D8BFD8', 'FF6347',
SPECIAL_NAMES: array [0..139] of string = ('black', 'antiquewhite', 'aqua', 'aquamarine', 'azure', 'beige', '40E0D0', 'EE82EE', 'F5DEB3', 'FFFFFF', 'F5F5F5', 'FFFF00', '9ACD32'
'bisque', 'aliceblue', 'blanchedalmond', 'blue', 'blueviolet', 'brown', );
'burlywood', 'cadetblue', 'chartreuse', 'chocolate', 'coral', SPECIAL_NAMES: array [0..139] of string = (
'cornflower', 'cornsilk', 'crimson', 'cyan', 'darkblue', 'darkcyan', 'black', 'antiquewhite', 'aqua', 'aquamarine', 'azure', 'beige',
'darkgoldenrod', 'darkgray', 'darkgreen', 'darkkhaki', 'darkmagenta', 'bisque', 'aliceblue', 'blanchedalmond', 'blue', 'blueviolet', 'brown',
'darkolivegreen', 'darkorange', 'darkorchid', 'darkred', 'darksalmon', 'burlywood', 'cadetblue', 'chartreuse', 'chocolate', 'coral',
'darkseagreen', 'darkslateblue', 'darkslategray', 'darkturquoise', 'cornflower', 'cornsilk', 'crimson', 'cyan', 'darkblue', 'darkcyan',
'darkviolet', 'deeppink', 'deepskyblue', 'dimgray', 'dodgerblue', 'darkgoldenrod', 'darkgray', 'darkgreen', 'darkkhaki', 'darkmagenta',
'firebrick', 'floralwhite', 'forestgreen', 'fuchsia', 'gainsboro', 'darkolivegreen', 'darkorange', 'darkorchid', 'darkred', 'darksalmon',
'ghostwhite', 'gold', 'goldenrod', 'gray', 'green', 'greenyellow', 'darkseagreen', 'darkslateblue', 'darkslategray', 'darkturquoise',
'honeydew', 'hotpink', 'indianred', 'indigo', 'ivory', 'khaki', 'lavender', 'darkviolet', 'deeppink', 'deepskyblue', 'dimgray', 'dodgerblue',
'lavenderblush', 'lawngreen', 'lemonchiffon', 'lightblue', 'lightcoral', 'firebrick', 'floralwhite', 'forestgreen', 'fuchsia', 'gainsboro',
'lightcyan', 'lightgoldenrodyellow', 'lightgreen', 'lightgray', 'lightpink', 'ghostwhite', 'gold', 'goldenrod', 'gray', 'green', 'greenyellow',
'lightsalmon', 'lightseagreen', 'lightskyblue', 'lightslategray', 'honeydew', 'hotpink', 'indianred', 'indigo', 'ivory', 'khaki', 'lavender',
'lightsteelblue', 'lightyellow', 'lime', 'limegreen', 'linen', 'magenta', 'lavenderblush', 'lawngreen', 'lemonchiffon', 'lightblue', 'lightcoral',
'maroon', 'mediumaquamarine', 'mediumblue', 'mediumorchid', 'mediumpurple', 'lightcyan', 'lightgoldenrodyellow', 'lightgreen', 'lightgray', 'lightpink',
'mediumseagreen', 'mediumslateblue', 'mediumspringgreen', 'mediumturquoise', 'lightsalmon', 'lightseagreen', 'lightskyblue', 'lightslategray',
'mediumvioletred', 'midnightblue', 'mintcream', 'mistyrose', 'moccasin', 'lightsteelblue', 'lightyellow', 'lime', 'limegreen', 'linen', 'magenta',
'navajowhite', 'navy', 'oldlace', 'olive', 'olivedrab', 'orange', 'orangered', 'maroon', 'mediumaquamarine', 'mediumblue', 'mediumorchid', 'mediumpurple',
'orchid', 'palegoldenrod', 'palegreen', 'paleturquoise', 'palevioletred', 'mediumseagreen', 'mediumslateblue', 'mediumspringgreen', 'mediumturquoise',
'papayawhip', 'peachpuff', 'peru', 'pink', 'plum', 'powderblue', 'purple', 'mediumvioletred', 'midnightblue', 'mintcream', 'mistyrose', 'moccasin',
'red', 'rosybrown', 'royalblue', 'saddlebrown', 'salmon', 'sandybrown', 'navajowhite', 'navy', 'oldlace', 'olive', 'olivedrab', 'orange', 'orangered',
'seagreen', 'seashell', 'sienna', 'silver', 'skyblue', 'slateblue', 'orchid', 'palegoldenrod', 'palegreen', 'paleturquoise', 'palevioletred',
'slategray', 'snow', 'springgreen', 'steelblue', 'tan', 'teal', 'thistle', 'papayawhip', 'peachpuff', 'peru', 'pink', 'plum', 'powderblue', 'purple',
'tomato', 'turquoise', 'violet', 'wheat', 'white', 'whitesmoke', 'yellow', 'red', 'rosybrown', 'royalblue', 'saddlebrown', 'salmon', 'sandybrown',
'yellowgreen'); 'seagreen', 'seashell', 'sienna', 'silver', 'skyblue', 'slateblue',
WEBSAFE_HEX: array [0..215] of string = ('000000' ,'000033' ,'000066' ,'000099' ,'0000cc' ,'0000ff', 'slategray', 'snow', 'springgreen', 'steelblue', 'tan', 'teal', 'thistle',
'003300' ,'003333' ,'003366' ,'003399' ,'0033cc' ,'0033ff', 'tomato', 'turquoise', 'violet', 'wheat', 'white', 'whitesmoke', 'yellow',
'006600' ,'006633' ,'006666' ,'006699' ,'0066cc' ,'0066ff', 'yellowgreen'
'009900' ,'009933' ,'009966' ,'009999' ,'0099cc' ,'0099ff', );
'00cc00' ,'00cc33' ,'00cc66' ,'00cc99' ,'00cccc' ,'00ccff', WEBSAFE_HEX: array [0..215] of string = (
'00ff00' ,'00ff33' ,'00ff66' ,'00ff99' ,'00ffcc' ,'00ffff', '000000' ,'000033' ,'000066' ,'000099' ,'0000cc' ,'0000ff',
'330000' ,'330033' ,'330066' ,'330099' ,'3300cc' ,'3300ff', '003300' ,'003333' ,'003366' ,'003399' ,'0033cc' ,'0033ff',
'333300' ,'333333' ,'333366' ,'333399' ,'3333cc' ,'3333ff', '006600' ,'006633' ,'006666' ,'006699' ,'0066cc' ,'0066ff',
'336600' ,'336633' ,'336666' ,'336699' ,'3366cc' ,'3366ff', '009900' ,'009933' ,'009966' ,'009999' ,'0099cc' ,'0099ff',
'339900' ,'339933' ,'339966' ,'339999' ,'3399cc' ,'3399ff', '00cc00' ,'00cc33' ,'00cc66' ,'00cc99' ,'00cccc' ,'00ccff',
'33cc00' ,'33cc33' ,'33cc66' ,'33cc99' ,'33cccc' ,'33ccff', '00ff00' ,'00ff33' ,'00ff66' ,'00ff99' ,'00ffcc' ,'00ffff',
'33ff00' ,'33ff33' ,'33ff66' ,'33ff99' ,'33ffcc' ,'33ffff', '330000' ,'330033' ,'330066' ,'330099' ,'3300cc' ,'3300ff',
'660000' ,'660033' ,'660066' ,'660099' ,'6600cc' ,'6600ff', '333300' ,'333333' ,'333366' ,'333399' ,'3333cc' ,'3333ff',
'663300' ,'663333' ,'663366' ,'663399' ,'6633cc' ,'6633ff', '336600' ,'336633' ,'336666' ,'336699' ,'3366cc' ,'3366ff',
'666600' ,'666633' ,'666666' ,'666699' ,'6666cc' ,'6666ff', '339900' ,'339933' ,'339966' ,'339999' ,'3399cc' ,'3399ff',
'669900' ,'669933' ,'669966' ,'669999' ,'6699cc' ,'6699ff', '33cc00' ,'33cc33' ,'33cc66' ,'33cc99' ,'33cccc' ,'33ccff',
'66cc00' ,'66cc33' ,'66cc66' ,'66cc99' ,'66cccc' ,'66ccff', '33ff00' ,'33ff33' ,'33ff66' ,'33ff99' ,'33ffcc' ,'33ffff',
'66ff00' ,'66ff33' ,'66ff66' ,'66ff99' ,'66ffcc' ,'66ffff', '660000' ,'660033' ,'660066' ,'660099' ,'6600cc' ,'6600ff',
'990000' ,'990033' ,'990066' ,'990099' ,'9900cc' ,'9900ff', '663300' ,'663333' ,'663366' ,'663399' ,'6633cc' ,'6633ff',
'993300' ,'993333' ,'993366' ,'993399' ,'9933cc' ,'9933ff', '666600' ,'666633' ,'666666' ,'666699' ,'6666cc' ,'6666ff',
'996600' ,'996633' ,'996666' ,'996699' ,'9966cc' ,'9966ff', '669900' ,'669933' ,'669966' ,'669999' ,'6699cc' ,'6699ff',
'999900' ,'999933' ,'999966' ,'999999' ,'9999cc' ,'9999ff', '66cc00' ,'66cc33' ,'66cc66' ,'66cc99' ,'66cccc' ,'66ccff',
'99cc00' ,'99cc33' ,'99cc66' ,'99cc99' ,'99cccc' ,'99ccff', '66ff00' ,'66ff33' ,'66ff66' ,'66ff99' ,'66ffcc' ,'66ffff',
'99ff00' ,'99ff33' ,'99ff66' ,'99ff99' ,'99ffcc' ,'99ffff', '990000' ,'990033' ,'990066' ,'990099' ,'9900cc' ,'9900ff',
'cc0000' ,'cc0033' ,'cc0066' ,'cc0099' ,'cc00cc' ,'cc00ff', '993300' ,'993333' ,'993366' ,'993399' ,'9933cc' ,'9933ff',
'cc3300' ,'cc3333' ,'cc3366' ,'cc3399' ,'cc33cc' ,'cc33ff', '996600' ,'996633' ,'996666' ,'996699' ,'9966cc' ,'9966ff',
'cc6600' ,'cc6633' ,'cc6666' ,'cc6699' ,'cc66cc' ,'cc66ff', '999900' ,'999933' ,'999966' ,'999999' ,'9999cc' ,'9999ff',
'cc9900' ,'cc9933' ,'cc9966' ,'cc9999' ,'cc99cc' ,'cc99ff', '99cc00' ,'99cc33' ,'99cc66' ,'99cc99' ,'99cccc' ,'99ccff',
'cccc00' ,'cccc33' ,'cccc66' ,'cccc99' ,'cccccc' ,'ccccff', '99ff00' ,'99ff33' ,'99ff66' ,'99ff99' ,'99ffcc' ,'99ffff',
'ccff00' ,'ccff33' ,'CCFF66' ,'ccff99' ,'ccffcc' ,'ccffff', 'cc0000' ,'cc0033' ,'cc0066' ,'cc0099' ,'cc00cc' ,'cc00ff',
'ff0000' ,'ff0033' ,'ff0066' ,'ff0099' ,'ff00cc' ,'ff00ff', 'cc3300' ,'cc3333' ,'cc3366' ,'cc3399' ,'cc33cc' ,'cc33ff',
'ff3300' ,'ff3333' ,'ff3366' ,'ff3399' ,'ff33cc' ,'ff33ff', 'cc6600' ,'cc6633' ,'cc6666' ,'cc6699' ,'cc66cc' ,'cc66ff',
'ff6600' ,'ff6633' ,'ff6666' ,'ff6699' ,'ff66cc' ,'ff66ff', 'cc9900' ,'cc9933' ,'cc9966' ,'cc9999' ,'cc99cc' ,'cc99ff',
'ff9900' ,'ff9933' ,'ff9966' ,'ff9999' ,'ff99cc' ,'ff99ff', 'cccc00' ,'cccc33' ,'cccc66' ,'cccc99' ,'cccccc' ,'ccccff',
'ffcc00' ,'ffcc33' ,'ffcc66' ,'ffcc99' ,'ffcccc' ,'ffccff', 'ccff00' ,'ccff33' ,'CCFF66' ,'ccff99' ,'ccffcc' ,'ccffff',
'ffff00' ,'ffff33' ,'ffff66' ,'ffff99' ,'ffffcc' ,'ffffff'); 'ff0000' ,'ff0033' ,'ff0066' ,'ff0099' ,'ff00cc' ,'ff00ff',
SYSTEM_VALUES: array [0..27] of TColor = (clActiveBorder, clActiveCaption, clAppWorkspace, clBackground, 'ff3300' ,'ff3333' ,'ff3366' ,'ff3399' ,'ff33cc' ,'ff33ff',
clBtnFace, clBtnHighlight, clBtnShadow, clBtnText, clCaptionText, 'ff6600' ,'ff6633' ,'ff6666' ,'ff6699' ,'ff66cc' ,'ff66ff',
clGrayText, clHighlight, clHighlightText, clInactiveBorder, 'ff9900' ,'ff9933' ,'ff9966' ,'ff9999' ,'ff99cc' ,'ff99ff',
clInactiveCaption, clInactiveCaptionText, clInfoBk, clInfoText, 'ffcc00' ,'ffcc33' ,'ffcc66' ,'ffcc99' ,'ffcccc' ,'ffccff',
clMenu, clMenuText, clScrollbar, cl3dDkShadow, cl3dLight, 'ffff00' ,'ffff33' ,'ffff66' ,'ffff99' ,'ffffcc' ,'ffffff'
clBtnHighlight, clActiveBorder, clBtnShadow, clWindow, );
clWindowFrame, clWindowText); SYSTEM_VALUES: array [0..27] of TColor = (
SYSTEM_NAMES: array [0..27] of string = ('activeborder', 'activecaption', 'appworkspace', 'background', clActiveBorder, clActiveCaption, clAppWorkspace, clBackground,
'buttonface', 'buttonhighlight', 'buttonshadow', 'buttontext', clBtnFace, clBtnHighlight, clBtnShadow, clBtnText, clCaptionText,
'captiontext', 'graytext', 'highlight', 'highlighttext', clGrayText, clHighlight, clHighlightText, clInactiveBorder,
'inactiveborder', 'inactivecaption', 'inactivecaptiontext', clInactiveCaption, clInactiveCaptionText, clInfoBk, clInfoText,
'infobackground', 'infotext', 'menu', 'menutext', 'scrollbar', clMenu, clMenuText, clScrollbar, cl3dDkShadow, cl3dLight,
'threeddarkshadow', 'threedface', 'threedhighlight', clBtnHighlight, clActiveBorder, clBtnShadow, clWindow,
'threedlightshadow', 'threedshadow', 'window', 'windowframe', clWindowFrame, clWindowText
'windowtext'); );
BASIC_VALUES: array [0..15] of TColor = (clBlack, clAqua, clBlue, clFuchsia, clGray, clGreen, clLime, SYSTEM_NAMES: array [0..27] of string = (
clMaroon, clNavy, clOlive, clPurple, clRed, clSilver, clTeal, 'activeborder', 'activecaption', 'appworkspace', 'background',
clWhite, clYellow); 'buttonface', 'buttonhighlight', 'buttonshadow', 'buttontext',
BASIC_NAMES: array [0..15] of string = ('black', 'aqua', 'blue', 'fuchsia', 'gray', 'green', 'lime', 'captiontext', 'graytext', 'highlight', 'highlighttext',
'maroon', 'navy', 'olive', 'purple', 'red', 'silver', 'teal', 'inactiveborder', 'inactivecaption', 'inactivecaptiontext',
'white', 'yellow'); 'infobackground', 'infotext', 'menu', 'menutext', 'scrollbar',
'threeddarkshadow', 'threedface', 'threedhighlight',
'threedlightshadow', 'threedshadow', 'window', 'windowframe',
'windowtext'
);
BASIC_VALUES: array [0..15] of TColor = (
clBlack, clAqua, clBlue, clFuchsia, clGray, clGreen, clLime,
clMaroon, clNavy, clOlive, clPurple, clRed, clSilver, clTeal,
clWhite, clYellow
);
BASIC_NAMES: array [0..15] of string = (
'black', 'aqua', 'blue', 'fuchsia', 'gray', 'green', 'lime',
'maroon', 'navy', 'olive', 'purple', 'red', 'silver', 'teal',
'white', 'yellow'
);
procedure MakeIntoHex(var s: string); procedure MakeIntoHex(var s: string);
function IsMember(a: array of string; n: integer; s: string): boolean; function IsMember(a: array of string; n: integer; s: string): boolean;
@ -139,8 +145,6 @@ implementation
var var
WS: array [0..255] of byte; WS: array [0..255] of byte;
//------------------------------------------------------------------------------
//checks membership of a string array //checks membership of a string array
function IsMember(a: array of string; n: integer; s: string): boolean; function IsMember(a: array of string; n: integer; s: string): boolean;
var var
@ -152,16 +156,12 @@ begin
Result := true; Result := true;
end; end;
//------------------------------------------------------------------------------ //checks if the color's name was used instead of hex
//checks if the color's nam was used instead of hex
function IsSpecialColor(s: string): boolean; function IsSpecialColor(s: string): boolean;
begin begin
Result := IsMember(BASIC_NAMES, BASIC_COUNT, s) or IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) or IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s); Result := IsMember(BASIC_NAMES, BASIC_COUNT, s) or IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) or IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s);
end; end;
//------------------------------------------------------------------------------
//is hex was used then remove the wrong characters //is hex was used then remove the wrong characters
procedure MakeIntoHex(var s: string); procedure MakeIntoHex(var s: string);
var var
@ -173,8 +173,6 @@ begin
s[i] := '0'; s[i] := '0';
end; end;
//------------------------------------------------------------------------------
//formats entered text into a true hex value //formats entered text into a true hex value
function FormatHexColor(S: string): string; function FormatHexColor(S: string): string;
var var
@ -209,8 +207,6 @@ begin
Result := s; Result := s;
end; end;
//------------------------------------------------------------------------------
//gets a hex value from a color name from special colors //gets a hex value from a color name from special colors
function GetHexFromName(s: string): string; function GetHexFromName(s: string): string;
var var
@ -226,8 +222,6 @@ begin
Result := SPECIAL_HEX[k]; Result := SPECIAL_HEX[k];
end; end;
//------------------------------------------------------------------------------
// gets a TColor value from a color name from basic or system colors // gets a TColor value from a color name from basic or system colors
function GetValueFromName(s: string): TColor; function GetValueFromName(s: string): TColor;
var var
@ -259,19 +253,12 @@ begin
Result := clNone; Result := clNone;
end; end;
//------------------------------------------------------------------------------
//converts a TColor value to a hex value //converts a TColor value to a hex value
function ColorToHex(Color: TColor): string; function ColorToHex(Color: TColor): string;
begin begin
// if Color <> $ then
Result := IntToHex(GetRValue(Color), 2) + IntToHex(GetGValue(Color), 2) + IntToHex(GetBValue(Color), 2) Result := IntToHex(GetRValue(Color), 2) + IntToHex(GetGValue(Color), 2) + IntToHex(GetBValue(Color), 2)
// else
// Result := '000000';
end; end;
//------------------------------------------------------------------------------
//converts a hex value to a TColor //converts a hex value to a TColor
function HexToTColor(s: OleVariant): TColor; function HexToTColor(s: OleVariant): TColor;
begin begin
@ -297,8 +284,6 @@ begin
Result := clNone; Result := clNone;
end; end;
//------------------------------------------------------------------------------
//checks if a hex value belongs to the websafe palette //checks if a hex value belongs to the websafe palette
function IsWebSafe(s: string): boolean; function IsWebSafe(s: string): boolean;
begin begin
@ -306,8 +291,6 @@ begin
Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s); Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s);
end; end;
//------------------------------------------------------------------------------
//checks if a color belongs to the websafe palette //checks if a color belongs to the websafe palette
function IsWebSafe(c: TColor): boolean; function IsWebSafe(c: TColor): boolean;
var var
@ -317,8 +300,6 @@ begin
Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s); Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s);
end; end;
//------------------------------------------------------------------------------
//initializes the websafe comparison array //initializes the websafe comparison array
procedure InitializeWS; procedure InitializeWS;
var var
@ -328,15 +309,12 @@ begin
WS[I] := ((i + $19) div $33) * $33; WS[I] := ((i + $19) div $33) * $33;
end; end;
//------------------------------------------------------------------------------
//returns the closest web safe color to the one given //returns the closest web safe color to the one given
function GetWebSafe(C: TColor): TColor; function GetWebSafe(C: TColor): TColor;
begin begin
Result := RGB(WS[GetRValue(C)], WS[GetGValue(C)], WS[GetBValue(C)]); Result := RGB(WS[GetRValue(C)], WS[GetGValue(C)], WS[GetBValue(C)]);
end; end;
//------------------------------------------------------------------------------
initialization initialization
InitializeWS; InitializeWS;

886
components/mbColorLib/HexaColorPicker.pas
View File

File diff suppressed because it is too large Load Diff

188
components/mbColorLib/KColorPicker.pas
View File

@ -7,11 +7,7 @@ unit KColorPicker;
interface interface
uses uses
{$IFDEF FPC} LCLIntf, LCLType,
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
RGBCMYKUtils, mbTrackBarPicker, HTMLColors; RGBCMYKUtils, mbTrackBarPicker, HTMLColors;
@ -22,9 +18,9 @@ type
function ArrowPosFromBlack(k: integer): integer; function ArrowPosFromBlack(k: integer): integer;
function BlackFromArrowPos(p: integer): integer; function BlackFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor; function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
procedure SetCyan(c: integer); procedure SetCyan(c: integer);
procedure SetMagenta(m: integer); procedure SetMagenta(m: integer);
procedure SetSelectedColor(c: TColor);
procedure SetYellow(y: integer); procedure SetYellow(y: integer);
procedure SetBlack(k: integer); procedure SetBlack(k: integer);
protected protected
@ -68,63 +64,6 @@ begin
FChange := true; FChange := true;
end; end;
function TKColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := CMYKtoColor(FCyan, FMagenta, FYellow, AValue);
end;
procedure TKColorPicker.SetBlack(k: integer);
begin
Clamp(k, 0, 255);
if FBlack <> k then
begin
FBlack := k;
FArrowPos := ArrowPosFromBlack(k);
FManual := false;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TKColorPicker.SetMagenta(m: integer);
begin
Clamp(m, 0, 255);
if FMagenta <> m then
begin
FMagenta := m;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TKColorPicker.SetYellow(y: integer);
begin
Clamp(y, 0, 255);
if FYellow <> y then
begin
FYellow := y;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TKColorPicker.SetCyan(c: integer);
begin
Clamp(c, 0, 255);
if FCyan <> c then
begin
FCyan := c;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
function TKColorPicker.ArrowPosFromBlack(k: integer): integer; function TKColorPicker.ArrowPosFromBlack(k: integer): integer;
var var
a: integer; a: integer;
@ -156,39 +95,6 @@ begin
Result := k; Result := k;
end; end;
function TKColorPicker.GetSelectedColor: TColor;
begin
Result := CMYKtoColor(FCyan, FMagenta, FYellow, FBlack);
if WebSafe then
Result := GetWebSafe(Result);
end;
function TKColorPicker.GetSelectedValue: integer;
begin
Result := FBlack;
end;
procedure TKColorPicker.SetSelectedColor(c: TColor);
var
cy, m, y, k: integer;
begin
if WebSafe then c := GetWebSafe(c);
ColorToCMYK(c, cy, m, y, k);
FChange := false;
SetMagenta(m);
SetYellow(y);
SetCyan(cy);
SetBlack(k);
FManual := false;
FChange := true;
if Assigned(OnChange) then OnChange(Self);
end;
function TKColorPicker.GetArrowPos: integer;
begin
Result := ArrowPosFromBlack(FBlack);
end;
procedure TKColorPicker.Execute(tbaAction: integer); procedure TKColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
@ -225,4 +131,94 @@ begin
end; end;
end; end;
function TKColorPicker.GetArrowPos: integer;
begin
Result := ArrowPosFromBlack(FBlack);
end;
function TKColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := CMYKtoColor(FCyan, FMagenta, FYellow, AValue);
end;
function TKColorPicker.GetSelectedColor: TColor;
begin
Result := CMYKtoColor(FCyan, FMagenta, FYellow, FBlack);
if WebSafe then
Result := GetWebSafe(Result);
end;
function TKColorPicker.GetSelectedValue: integer;
begin
Result := FBlack;
end;
procedure TKColorPicker.SetBlack(k: integer);
begin
Clamp(k, 0, 255);
if FBlack <> k then
begin
FBlack := k;
FArrowPos := ArrowPosFromBlack(k);
FManual := false;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TKColorPicker.SetCyan(c: integer);
begin
Clamp(c, 0, 255);
if FCyan <> c then
begin
FCyan := c;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TKColorPicker.SetMagenta(m: integer);
begin
Clamp(m, 0, 255);
if FMagenta <> m then
begin
FMagenta := m;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TKColorPicker.SetSelectedColor(c: TColor);
var
cy, m, y, k: integer;
begin
if WebSafe then c := GetWebSafe(c);
ColorToCMYK(c, cy, m, y, k);
FChange := false;
SetMagenta(m);
SetYellow(y);
SetCyan(cy);
SetBlack(k);
FManual := false;
FChange := true;
if Assigned(OnChange) then OnChange(Self);
end;
procedure TKColorPicker.SetYellow(y: integer);
begin
Clamp(y, 0, 255);
if FYellow <> y then
begin
FYellow := y;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
end. end.

191
components/mbColorLib/LColorPicker.pas
View File

@ -7,13 +7,8 @@ interface
{$ENDIF} {$ENDIF}
uses uses
{$IFDEF FPC} LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics, Forms,
LCLIntf, LCLType, LMessages, HTMLColors, RGBHSLUtils, mbTrackBarPicker;
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
RGBHSLUtils, mbTrackBarPicker, HTMLColors;
type type
TLColorPicker = class(TmbTrackBarPicker) TLColorPicker = class(TmbTrackBarPicker)
@ -21,17 +16,17 @@ type
FHue, FSat, FLuminance: Double; FHue, FSat, FLuminance: Double;
FMaxHue, FMaxSat, FMaxLum: Integer; FMaxHue, FMaxSat, FMaxLum: Integer;
function ArrowPosFromLum(L: integer): integer; function ArrowPosFromLum(L: integer): integer;
function LumFromArrowPos(p: integer): integer;
function GetHue: Integer; function GetHue: Integer;
function GetSat: Integer;
function GetLuminance: Integer; function GetLuminance: Integer;
function GetSat: Integer;
function GetSelectedColor: TColor;
function LumFromArrowPos(p: integer): integer;
procedure SetHue(H: integer); procedure SetHue(H: integer);
procedure SetSat(S: integer);
procedure SetLuminance(L: integer); procedure SetLuminance(L: integer);
procedure SetMaxHue(H: Integer); procedure SetMaxHue(H: Integer);
procedure SetMaxSat(S: Integer);
procedure SetMaxLum(L: Integer); procedure SetMaxLum(L: Integer);
function GetSelectedColor: TColor; procedure SetMaxSat(S: Integer);
procedure SetSat(S: integer);
procedure SetSelectedColor(c: TColor); procedure SetSelectedColor(c: TColor);
protected protected
procedure Execute(tbaAction: integer); override; procedure Execute(tbaAction: integer); override;
@ -74,6 +69,68 @@ begin
FChange := true; FChange := true;
end; end;
function TLColorPicker.ArrowPosFromLum(L: integer): integer;
var
a: integer;
begin
if Layout = lyHorizontal then
begin
a := Round((Width - 12) * L / FMaxLum);
if a > Width - FLimit then a := Width - FLimit;
end
else
begin
a := Round((Height - 12) * (FMaxLum - L) / FMaxLum);
if a > Height - FLimit then a := Height - FLimit;
end;
if a < 0 then a := 0;
Result := a;
end;
procedure TLColorPicker.Execute(tbaAction: integer);
begin
case tbaAction of
TBA_Resize:
SetLuminance(GetLuminance());
TBA_MouseMove:
SetLuminance(LumFromArrowPos(FArrowPos));
TBA_MouseDown:
SetLuminance(LumFromArrowPos(FArrowPos));
TBA_MouseUp:
SetLuminance(LumFromArrowPos(FArrowPos));
TBA_WheelUp:
SetLuminance(GetLuminance() + Increment);
TBA_WheelDown:
SetLuminance(GetLuminance() - Increment);
TBA_VKRight:
SetLuminance(GetLuminance() + Increment);
TBA_VKCtrlRight:
SetLuminance(FMaxLum);
TBA_VKLeft:
SetLuminance(GetLuminance() - Increment);
TBA_VKCtrlLeft:
SetLuminance(0);
TBA_VKUp:
SetLuminance(GetLuminance() + Increment);
TBA_VKCtrlUp:
SetLuminance(FMaxLum);
TBA_VKDown:
SetLuminance(GetLuminance() - Increment);
TBA_VKCtrlDown:
SetLuminance(0);
else
inherited;
end;
end;
function TLColorPicker.GetArrowPos: integer;
begin
if FMaxLum = 0 then
Result := inherited GetArrowPos
else
Result := ArrowPosFromLum(GetLuminance());
end;
function TLColorPicker.GetGradientColor(AValue: Integer): TColor; function TLColorPicker.GetGradientColor(AValue: Integer): TColor;
begin begin
Result := HSLToRGB(FHue, FSat, AValue/FMaxLum); Result := HSLToRGB(FHue, FSat, AValue/FMaxLum);
@ -94,6 +151,30 @@ begin
Result := Round(FSat * FMaxSat); Result := Round(FSat * FMaxSat);
end; end;
function TLColorPicker.GetSelectedColor: TColor;
begin
Result := HSLToRGB(FHue, FSat, FLuminance);
if WebSafe then
Result := GetWebSafe(Result);
end;
function TLColorPicker.GetSelectedValue: integer;
begin
Result := GetLuminance();
end;
function TLColorPicker.LumFromArrowPos(p: integer): integer;
var
L: integer;
begin
if Layout = lyHorizontal then
L := Round(p / (Width - 12) * FMaxLum)
else
L := Round(MaxLum - p /(Height - 12) * FMaxLum);
Clamp(L, 0, FMaxLum);
Result := L;
end;
procedure TLColorPicker.SetHue(H: integer); procedure TLColorPicker.SetHue(H: integer);
begin begin
Clamp(H, 0, FMaxHue); Clamp(H, 0, FMaxHue);
@ -164,48 +245,6 @@ begin
end; end;
end; end;
function TLColorPicker.ArrowPosFromLum(L: integer): integer;
var
a: integer;
begin
if Layout = lyHorizontal then
begin
a := Round((Width - 12) * L / FMaxLum);
if a > Width - FLimit then a := Width - FLimit;
end
else
begin
a := Round((Height - 12) * (FMaxLum - L) / FMaxLum);
if a > Height - FLimit then a := Height - FLimit;
end;
if a < 0 then a := 0;
Result := a;
end;
function TLColorPicker.LumFromArrowPos(p: integer): integer;
var
L: integer;
begin
if Layout = lyHorizontal then
L := Round(p / (Width - 12) * FMaxLum)
else
L := Round(MaxLum - p /(Height - 12) * FMaxLum);
Clamp(L, 0, FMaxLum);
Result := L;
end;
function TLColorPicker.GetSelectedColor: TColor;
begin
Result := HSLToRGB(FHue, FSat, FLuminance);
if WebSafe then
Result := GetWebSafe(Result);
end;
function TLColorPicker.GetSelectedValue: integer;
begin
Result := GetLuminance();
end;
procedure TLColorPicker.SetSelectedColor(c: TColor); procedure TLColorPicker.SetSelectedColor(c: TColor);
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
@ -217,48 +256,4 @@ begin
if FChange and Assigned(OnChange) then OnChange(Self); if FChange and Assigned(OnChange) then OnChange(Self);
end; end;
function TLColorPicker.GetArrowPos: integer;
begin
if FMaxLum = 0 then
Result := inherited GetArrowPos
else
Result := ArrowPosFromLum(GetLuminance());
end;
procedure TLColorPicker.Execute(tbaAction: integer);
begin
case tbaAction of
TBA_Resize:
SetLuminance(GetLuminance());
TBA_MouseMove:
SetLuminance(LumFromArrowPos(FArrowPos));
TBA_MouseDown:
SetLuminance(LumFromArrowPos(FArrowPos));
TBA_MouseUp:
SetLuminance(LumFromArrowPos(FArrowPos));
TBA_WheelUp:
SetLuminance(GetLuminance() + Increment);
TBA_WheelDown:
SetLuminance(GetLuminance() - Increment);
TBA_VKRight:
SetLuminance(GetLuminance() + Increment);
TBA_VKCtrlRight:
SetLuminance(FMaxLum);
TBA_VKLeft:
SetLuminance(GetLuminance() - Increment);
TBA_VKCtrlLeft:
SetLuminance(0);
TBA_VKUp:
SetLuminance(GetLuminance() + Increment);
TBA_VKCtrlUp:
SetLuminance(FMaxLum);
TBA_VKDown:
SetLuminance(GetLuminance() - Increment);
TBA_VKCtrlDown:
SetLuminance(0);
else
inherited;
end;
end;
end. end.

228
components/mbColorLib/MColorPicker.pas
View File

@ -2,31 +2,25 @@ unit MColorPicker;
interface interface
{$IFDEF FPC} {$MODE DELPHI}
{$MODE DELPHI}
{$ENDIF}
uses uses
{$IFDEF FPC} LCLIntf, LCLType,
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
RGBCMYKUtils, mbTrackBarPicker, HTMLColors; //, Scanlines; RGBCMYKUtils, mbTrackBarPicker, HTMLColors;
type type
TMColorPicker = class(TmbTrackBarPicker) TMColorPicker = class(TmbTrackBarPicker)
private private
FCyan, FMagenta, FYellow, FBlack: integer; FCyan, FMagenta, FYellow, FBlack: integer;
function ArrowPosFromMagenta(m: integer): integer; function ArrowPosFromMagenta(m: integer): integer;
function MagentaFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor; function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor); function MagentaFromArrowPos(p: integer): integer;
procedure SetBlack(k: integer);
procedure SetCyan(c: integer); procedure SetCyan(c: integer);
procedure SetMagenta(m: integer); procedure SetMagenta(m: integer);
procedure SetSelectedColor(c: TColor);
procedure SetYellow(y: integer); procedure SetYellow(y: integer);
procedure SetBlack(k: integer);
protected protected
procedure Execute(tbaAction: integer); override; procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override; function GetArrowPos: integer; override;
@ -43,6 +37,7 @@ type
property Layout default lyVertical; property Layout default lyVertical;
end; end;
implementation implementation
uses uses
@ -68,128 +63,25 @@ begin
FChange := true; FChange := true;
end; end;
function TMColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := CMYKtoColor(FCyan, AValue, FYellow, FBlack);
end;
procedure TMColorPicker.SetMagenta(m: integer);
begin
Clamp(m, 0, 255);
if FMagenta <> m then
begin
FMagenta := m;
FArrowPos := ArrowPosFromMagenta(m);
FManual := false;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TMColorPicker.SetCyan(c: integer);
begin
Clamp(c, 0, 255);
if FCyan <> c then
begin
FCyan := c;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TMColorPicker.SetYellow(y: integer);
begin
Clamp(y, 0, 255);
if FYellow <> y then
begin
FYellow := y;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TMColorPicker.SetBlack(k: integer);
begin
Clamp(k, 0, 255);
if FBlack <> k then
begin
FBlack := k;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
function TMColorPicker.ArrowPosFromMagenta(m: integer): integer; function TMColorPicker.ArrowPosFromMagenta(m: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/255)*m); a := Round((Width - 12) / 255 * m);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
m := 255 - m; m := 255 - m;
a := Round(((Height - 12)/255)*m); a := Round((Height - 12) / 255 * m);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function TMColorPicker.MagentaFromArrowPos(p: integer): integer;
var
m: integer;
begin
if Layout = lyHorizontal then
m := Round(p/((Width - 12)/255))
else
m := Round(255 - p/((Height - 12)/255));
Clamp(m, 0, 255);
Result := m;
end;
function TMColorPicker.GetSelectedColor: TColor;
begin
Result := CMYKtoColor(FCyan, FMagenta, FYellow, FBlack);
if WebSafe then
Result := GetWebSafe(Result);
end;
function TMColorPicker.GetSelectedValue: integer;
begin
Result := FMagenta;
end;
procedure TMColorPicker.SetSelectedColor(c: TColor);
var
cy, m, y, k: integer;
begin
if WebSafe then c := GetWebSafe(c);
ColorToCMYK(c, cy, m, y, k);
FChange := false;
SetCyan(cy);
SetYellow(y);
SetBlack(k);
SetMagenta(m);
FManual := false;
FChange := true;
if Assigned(OnChange) then OnChange(Self);
end;
function TMColorPicker.GetArrowPos: integer;
begin
Result := ArrowPosFromMagenta(FMagenta);
end;
procedure TMColorPicker.Execute(tbaAction: integer); procedure TMColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
@ -226,4 +118,106 @@ begin
end; end;
end; end;
function TMColorPicker.GetArrowPos: integer;
begin
Result := ArrowPosFromMagenta(FMagenta);
end;
function TMColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := CMYKtoColor(FCyan, AValue, FYellow, FBlack);
end;
function TMColorPicker.GetSelectedColor: TColor;
begin
Result := CMYKtoColor(FCyan, FMagenta, FYellow, FBlack);
if WebSafe then
Result := GetWebSafe(Result);
end;
function TMColorPicker.GetSelectedValue: integer;
begin
Result := FMagenta;
end;
function TMColorPicker.MagentaFromArrowPos(p: integer): integer;
var
m: integer;
begin
if Layout = lyHorizontal then
m := Round(p * 255 / (Width - 12))
else
m := Round(255 - p * 255 / (Height - 12));
Clamp(m, 0, 255);
Result := m;
end;
procedure TMColorPicker.SetBlack(k: integer);
begin
Clamp(k, 0, 255);
if FBlack <> k then
begin
FBlack := k;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TMColorPicker.SetCyan(c: integer);
begin
Clamp(c, 0, 255);
if FCyan <> c then
begin
FCyan := c;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TMColorPicker.SetMagenta(m: integer);
begin
Clamp(m, 0, 255);
if FMagenta <> m then
begin
FMagenta := m;
FArrowPos := ArrowPosFromMagenta(m);
FManual := false;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TMColorPicker.SetSelectedColor(c: TColor);
var
cy, m, y, k: integer;
begin
if WebSafe then c := GetWebSafe(c);
ColorToCMYK(c, cy, m, y, k);
FChange := false;
SetCyan(cy);
SetYellow(y);
SetBlack(k);
SetMagenta(m);
FManual := false;
FChange := true;
if Assigned(OnChange) then OnChange(Self);
end;
procedure TMColorPicker.SetYellow(y: integer);
begin
Clamp(y, 0, 255);
if FYellow <> y then
begin
FYellow := y;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
end. end.

552
components/mbColorLib/OfficeMoreColorsDialog.pas
View File

@ -2,18 +2,11 @@ unit OfficeMoreColorsDialog;
interface interface
{$I mxs.inc}
uses uses
{$IFDEF FPC} LCLIntf, LCLType, SysUtils, Variants, Classes, Graphics, Controls, Forms,
LCLIntf, LCLType, LMessages, StdCtrls, ExtCtrls, ComCtrls,
{$ELSE} HexaColorPicker, HSLColorPicker, RGBHSLUtils, mbColorPreview,
Windows, Messages, {$IFDEF mbXP_Lib}mbXPSpinEdit, mbXPSizeGrip,{$ELSE} Spin,{$ENDIF}
{$ENDIF}
SysUtils, {$IFDEF DELPHI_6_UP}Variants,{$ENDIF} Classes, Graphics, Controls,
Forms, StdCtrls, ExtCtrls, ComCtrls,
HexaColorPicker, HSLColorPicker, RGBHSLUtils,
mbColorPreview, {$IFDEF mbXP_Lib}mbXPSpinEdit, mbXPSizeGrip,{$ELSE} Spin,{$ENDIF}
HTMLColors, SLHColorPicker, HSLRingPicker, RColorPicker, GColorPicker, HTMLColors, SLHColorPicker, HSLRingPicker, RColorPicker, GColorPicker,
BColorPicker; BColorPicker;
@ -102,11 +95,7 @@ var
implementation implementation
{$IFDEF DELPHI} {$R *.lfm}
{$R *.dfm}
{$ELSE}
{$R *.lfm}
{$ENDIF}
procedure TOfficeMoreColorsWin.ColorPickerChange(Sender: TObject); procedure TOfficeMoreColorsWin.ColorPickerChange(Sender: TObject);
begin begin
@ -132,23 +121,15 @@ begin
Params.Style := WS_CAPTION or WS_SIZEBOX or WS_SYSMENU; Params.Style := WS_CAPTION or WS_SIZEBOX or WS_SYSMENU;
Params.ExStyle := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE; Params.ExStyle := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
end; end;
(*
procedure TOfficeMoreColorsWin.CreateWnd;
begin
inherited CreateWnd;
{ wp : LM_SETICON not used in LCL }
// SendMessage(Self.Handle, {$IFDEF FPC}LM_SETICON{$ELSE}WM_SETICON{$ENDIF}, 1, 0);
end;
*)
procedure TOfficeMoreColorsWin.cbColorDisplayChange(Sender: TObject); procedure TOfficeMoreColorsWin.cbColorDisplayChange(Sender: TObject);
begin begin
PickerNotebook.PageIndex := cbColorDisplay.ItemIndex; PickerNotebook.PageIndex := cbColorDisplay.ItemIndex;
SetAllCustom(NewSwatch.Color); SetAllCustom(NewSwatch.Color);
exit; exit;
{ {
HSL.Visible := cbColorDisplay.ItemIndex = 0; HSL.Visible := cbColorDisplay.ItemIndex = 0;
HSLRing.Visible := cbColorDisplay.ItemIndex = 1; HSLRing.Visible := cbColorDisplay.ItemIndex = 1;
@ -162,11 +143,240 @@ begin
SLH.SelectedColor := NewSwatch.Color; SLH.SelectedColor := NewSwatch.Color;
end; end;
procedure TOfficeMoreColorsWin.EBlueChange(Sender: TObject);
begin
if (EBlue.Text <> '') and EBlue.Focused then
begin
inc(FLockChange);
HSL.Blue := EBlue.Value;
SLH.Blue := EBlue.Value;
NewSwatch.Color := RGB(ERed.Value, EGreen.Value, EBlue.Value);
dec(FLockChange);
end;
end;
procedure TOfficeMoreColorsWin.EGreenChange(Sender: TObject);
begin
if (EGreen.Text <> '') and EGreen.Focused then
begin
inc(FLockChange);
HSL.Green := EGreen.Value;
SLH.Green := EGreen.Value;
NewSwatch.Color := RGB(ERed.Value, EGreen.Value, EBlue.Value);
dec(FLockChange);
end;
end;
procedure TOfficeMoreColorsWin.EHueChange(Sender: TObject);
begin
if (EHue.Text <> '') and EHue.Focused then
begin
inc(FLockChange);
HSL.Hue := EHue.Value;
SLH.Hue := EHue.Value;
NewSwatch.Color := HSLRangeToRGB(EHue.Value, ESat.Value, ELum.Value);
dec(FLockChange);
end;
end;
procedure TOfficeMoreColorsWin.ELumChange(Sender: TObject);
begin
if (ELum.Text <> '') and ELum.Focused then
begin
inc(FLockChange);
HSL.Luminance := ELum.Value;
NewSwatch.Color := HSLRangeToRGB(EHue.Value, ESat.Value, ELum.Value);
dec(FLockChange);
end;
end;
procedure TOfficeMoreColorsWin.ERedChange(Sender: TObject);
begin
if (ERed.Text <> '') and ERed.Focused then
begin
inc(FLockChange);
HSL.Red := ERed.Value;
SLH.Red := ERed.Value;
NewSwatch.Color := RGB(ERed.Value, EGreen.Value, EBlue.Value);
dec(FLockChange);
end;
end;
procedure TOfficeMoreColorsWin.ESatChange(Sender: TObject);
begin
if (ESat.Text <> '') and ESat.Focused then
begin
inc(FLockChange);
HSL.Saturation := ESat.Value;
SLH.Saturation := ESat.Value;
NewSwatch.Color := HSLRangeToRGB(EHue.Value, ESat.Value, ELum.Value);
dec(FLockChange);
end;
end;
procedure TOfficeMoreColorsWin.FormCreate(Sender: TObject);
begin
{$IFDEF mbXP_Lib}
ERed := TmbXPSpinEdit.CreateParented(Custom.Handle);
EGreen := TmbXPSpinEdit.CreateParented(Custom.Handle);
EBlue := TmbXPSpinEdit.CreateParented(Custom.Handle);
grip := TmbXPSizeGrip.CreateParented(Self.Handle);
{$ELSE}
ERed := TSpinEdit.CreateParented(Custom.Handle);
EGreen := TSpinEdit.CreateParented(Custom.Handle);
EBlue := TSpinEdit.CreateParented(Custom.Handle);
EHue := TSpinEdit.CreateParented(Custom.Handle);
ESat := TSpinEdit.CreateParented(Custom.Handle);
ELum := TSpinEdit.CreateParented(Custom.Handle);
{$ENDIF}
with ERed do
begin
Name := 'ERed';
Width := 47;
Height := 22;
Left := cbColorDisplay.Left;
Top := LRed.Top - 4;
Alignment := taRightJustify;
Anchors := [akLeft, akBottom];
MaxValue := 255;
MinValue := 0;
Value := 0;
OnChange := @ERedChange;
// TabOrder := cbColorDisplay.TabOrder + 1;
end;
with EGreen do
begin
Name := 'EGreen';
Width := 47;
Height := 22;
Left := cbColorDisplay.Left;
Top := LGreen.Top - 3;
Alignment := taRightJustify;
Anchors := [akLeft, akBottom];
MaxValue := 255;
MinValue := 0;
Value := 0;
OnChange := @EGreenChange;
// TabOrder := ERed.TabOrder + 1;
end;
with EBlue do
begin
Name := 'EBlue';
Width := 47;
Height := 22;
Left := cbColorDisplay.Left;
Top := LBlue.Top - 4;
Alignment := taRightJustify;
Anchors := [akLeft, akBottom];
MaxValue := 255;
MinValue := 0;
Value := 0;
OnChange := @EBlueChange;
// TabOrder := EGreen.TabOrder + 1;
end;
with EHue do
begin
Name := 'EHue';
Width := 47;
Height := 22;
Left := cbColorDisplay.Left + cbColorDisplay.Width - Width;
Top := ERed.Top;
Alignment := taRightJustify;
Anchors := [akLeft, akBottom];
MaxValue := MaxHue;
MinValue := 0;
Value := 0;
OnChange := @EHueChange;
// TabOrder := EBlue.TabOrder + 1;
end;
with ESat do
begin
Name := 'ESat';
Width := 47;
Height := 22;
Left := cbColorDisplay.Left + cbColorDisplay.Width - Width;
Top := EGreen.Top;
Alignment := taRightJustify;
Anchors := [akLeft, akBottom];
MaxValue := MaxSat;
MinValue := 0;
Value := 0;
OnChange := @ESatChange;
// TabOrder := EHue.TabOrder + 1;
end;
with ELum do
begin
Name := 'ELum';
Width := 47;
Height := 22;
Left := cbColorDisplay.Left + cbColorDisplay.Width - Width;
Top := EBlue.Top;
Alignment := taRightJustify;
Anchors := [akLeft, akBottom];
MaxValue := MaxLum;
MinValue := 0;
Value := 0;
OnChange := @ELumChange;
// TabOrder := ESat.TabOrder + 1;
end;
Custom.InsertControl(ERed);
Custom.InsertControl(EGreen);
Custom.InsertControl(EBlue);
Custom.InsertControl(EHue);
Custom.InsertControl(ESat);
Custom.InsertControl(ELum);
{$IFDEF mbXP_Lib}
with grip do
begin
Name := 'grip';
Width := 15;
Height := 15;
Left := 308;
Top := 314;
Anchors := [akRight, akBottom];
end;
InsertControl(grip);
{$ENDIF}
OKBtn.TabOrder := ELum.TabOrder + 1;
CancelBtn.TabOrder := OKBtn.TabOrder + 1;
end;
procedure TOfficeMoreColorsWin.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_RETURN: ModalResult := mrOK;
VK_ESCAPE: ModalResult := mrCancel;
end;
end;
procedure TOfficeMoreColorsWin.FormResize(Sender: TObject);
begin
{$IFDEF mbXP_Lib}
grip.Left := ClientWidth - 15;
grip.Top := ClientHeight - 15;
{$ENDIF}
end;
function TOfficeMoreColorsWin.GetHint(c: TColor): string;
begin
Result := Format('RGB(%u, %u, %u)'#13'Hex: %s', [
GetRValue(c), GetGValue(c), GetBValue(c), ColorToHex(c)
]);
end;
function TOfficeMoreColorsWin.GetShowHint: Boolean; function TOfficeMoreColorsWin.GetShowHint: Boolean;
begin begin
Result := inherited ShowHint; Result := inherited ShowHint;
end; end;
procedure TOfficeMoreColorsWin.HexaChange(Sender: TObject);
begin
NewSwatch.Color := Hexa.SelectedColor;
end;
procedure TOfficeMoreColorsWin.HSLChange(Sender: TObject); procedure TOfficeMoreColorsWin.HSLChange(Sender: TObject);
begin begin
if FLockChange <> 0 then if FLockChange <> 0 then
@ -181,104 +391,6 @@ begin
SetAllCustom(HSLRing.SelectedColor); SetAllCustom(HSLRing.SelectedColor);
end; end;
procedure TOfficeMoreColorsWin.ERedChange(Sender: TObject);
begin
if (ERed.Text <> '') and
(ERed.Focused {$IFDEF DELPHI} or ERed.Button.Focused{$ENDIF}) then
begin
inc(FLockChange);
HSL.Red := ERed.Value;
SLH.Red := ERed.Value;
NewSwatch.Color := RGB(ERed.Value, EGreen.Value, EBlue.Value);
dec(FLockChange);
end;
end;
procedure TOfficeMoreColorsWin.EGreenChange(Sender: TObject);
begin
if (EGreen.Text <> '') and
(EGreen.Focused {$IFDEF DELPHI}or EGreen.Button.Focused{$ENDIF}) then
begin
inc(FLockChange);
HSL.Green := EGreen.Value;
SLH.Green := EGreen.Value;
NewSwatch.Color := RGB(ERed.Value, EGreen.Value, EBlue.Value);
dec(FLockChange);
end;
end;
procedure TOfficeMoreColorsWin.EBlueChange(Sender: TObject);
begin
if (EBlue.Text <> '') and
(EBlue.Focused {$IFDEF DELPHI} or EBlue.Button.Focused{$ENDIF}) then
begin
inc(FLockChange);
HSL.Blue := EBlue.Value;
SLH.Blue := EBlue.Value;
NewSwatch.Color := RGB(ERed.Value, EGreen.Value, EBlue.Value);
dec(FLockChange);
end;
end;
procedure TOfficeMoreColorsWin.EHueChange(Sender: TObject);
begin
if (EHue.Text <> '') and
(EHue.Focused {$IFDEF DELPHI} or EHue.Button.Focused{$ENDIF}) then
begin
inc(FLockChange);
HSL.Hue := EHue.Value;
SLH.Hue := EHue.Value;
NewSwatch.Color := HSLRangeToRGB(EHue.Value, ESat.Value, ELum.Value);
dec(FLockChange);
end;
end;
procedure TOfficeMoreColorsWin.ESatChange(Sender: TObject);
begin
if (ESat.Text <> '') and
(ESat.Focused {$IFDEF DELPHI}or ESat.Button.Focused{$ENDIF}) then
begin
inc(FLockChange);
HSL.Saturation := ESat.Value;
SLH.Saturation := ESat.Value;
NewSwatch.Color := HSLRangeToRGB(EHue.Value, ESat.Value, ELum.Value);
dec(FLockChange);
end;
end;
procedure TOfficeMoreColorsWin.ELumChange(Sender: TObject);
begin
if (ELum.Text <> '') and
(ELum.Focused {$IFDEF DELPHI} or ELum.Button.Focused{$ENDIF}) then
begin
inc(FLockChange);
HSL.Luminance := ELum.Value;
NewSwatch.Color := HSLRangeToRGB(EHue.Value, ESat.Value, ELum.Value);
dec(FLockChange);
end;
end;
procedure TOfficeMoreColorsWin.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_RETURN: ModalResult := mrOK;
VK_ESCAPE: ModalResult := mrCancel;
end;
end;
procedure TOfficeMoreColorsWin.HexaChange(Sender: TObject);
begin
NewSwatch.Color := Hexa.SelectedColor;
end;
function TOfficeMoreColorsWin.GetHint(c: TColor): string;
begin
Result := Format('RGB(%u, %u, %u)'#13'Hex: %s', [
GetRValue(c), GetGValue(c), GetBValue(c), ColorToHex(c)
]);
end;
procedure TOfficeMoreColorsWin.NewSwatchColorChange(Sender: TObject); procedure TOfficeMoreColorsWin.NewSwatchColorChange(Sender: TObject);
var var
r,g,b: Integer; r,g,b: Integer;
@ -291,22 +403,6 @@ begin
exit; exit;
SetAllCustom(NewSwatch.Color); SetAllCustom(NewSwatch.Color);
{
ERed.Value := GetRValue(NewSwatch.Color);
EGreen.Value := GetGValue(NewSwatch.Color);
EBlue.Value := GetBValue(NewSwatch.Color);
EHue.Value := GetHValue(NewSwatch.Color);
ESat.Value := GetSValue(NewSwatch.Color);
ELum.Value := GetLValue(NewSwatch.Color);
if HSL.Visible then
HSL.SelectedColor := NewSwatch.Color;
if HSLRing.Visible then
HSLRing.SelectedColor := NewSwatch.Color;
if SLH.Visible then
SLH.SelectedColor := NewSwatch.Color;
}
end; end;
procedure TOfficeMoreColorsWin.OldSwatchColorChange(Sender: TObject); procedure TOfficeMoreColorsWin.OldSwatchColorChange(Sender: TObject);
@ -315,17 +411,9 @@ begin
SetAllToSel(OldSwatch.Color); SetAllToSel(OldSwatch.Color);
end; end;
procedure TOfficeMoreColorsWin.SetAllToSel(c: TColor); procedure TOfficeMoreColorsWin.PagesChange(Sender: TObject);
var
h, s, l: Integer;
begin begin
case Pages.ActivePageIndex of SetAllToSel(NewSwatch.Color);
// Standard Page
0: Hexa.SelectedColor := c;
// Custom Page
1: SetAllCustom(c);
end;
NewSwatch.Color := c;
end; end;
procedure TOfficeMoreColorsWin.SetAllCustom(c: TColor); procedure TOfficeMoreColorsWin.SetAllCustom(c: TColor);
@ -376,6 +464,19 @@ begin
end; end;
end; end;
procedure TOfficeMoreColorsWin.SetAllToSel(c: TColor);
var
h, s, l: Integer;
begin
case Pages.ActivePageIndex of
// Standard Page
0: Hexa.SelectedColor := c;
// Custom Page
1: SetAllCustom(c);
end;
NewSwatch.Color := c;
end;
procedure TOfficeMoreColorsWin.SetShowHint(AValue: Boolean); procedure TOfficeMoreColorsWin.SetShowHint(AValue: Boolean);
begin begin
inherited ShowHint := AValue; inherited ShowHint := AValue;
@ -392,153 +493,4 @@ begin
SetAllCustom(SLH.SelectedColor); SetAllCustom(SLH.SelectedColor);
end; end;
procedure TOfficeMoreColorsWin.PagesChange(Sender: TObject);
begin
SetAllToSel(NewSwatch.Color);
end;
procedure TOfficeMoreColorsWin.FormResize(Sender: TObject);
begin
{
SLH.Width := SLH.Parent.ClientWidth - SLH.Left;
SLH.Height := cbColorDisplay.Top - SLH.Top;
HSLRing.Width := SLH.Width;
HSLRing.Height := SLH.Height - 4;
}
{$IFDEF mbXP_Lib}
grip.Left := ClientWidth - 15;
grip.Top := ClientHeight - 15;
{$ENDIF}
end;
procedure TOfficeMoreColorsWin.FormCreate(Sender: TObject);
begin
{$IFDEF mbXP_Lib}
ERed := TmbXPSpinEdit.CreateParented(Custom.Handle);
EGreen := TmbXPSpinEdit.CreateParented(Custom.Handle);
EBlue := TmbXPSpinEdit.CreateParented(Custom.Handle);
grip := TmbXPSizeGrip.CreateParented(Self.Handle);
{$ELSE}
ERed := TSpinEdit.CreateParented(Custom.Handle);
EGreen := TSpinEdit.CreateParented(Custom.Handle);
EBlue := TSpinEdit.CreateParented(Custom.Handle);
EHue := TSpinEdit.CreateParented(Custom.Handle);
ESat := TSpinEdit.CreateParented(Custom.Handle);
ELum := TSpinEdit.CreateParented(Custom.Handle);
{$ENDIF}
with ERed do
begin
Name := 'ERed';
Width := 47;
Height := 22;
Left := cbColorDisplay.Left;
Top := LRed.Top - 4;
Alignment := taRightJustify;
Anchors := [akLeft, akBottom];
MaxValue := 255;
MinValue := 0;
Value := 0;
OnChange := @ERedChange;
// TabOrder := cbColorDisplay.TabOrder + 1;
end;
with EGreen do
begin
Name := 'EGreen';
Width := 47;
Height := 22;
Left := cbColorDisplay.Left;
Top := LGreen.Top - 3;
Alignment := taRightJustify;
Anchors := [akLeft, akBottom];
MaxValue := 255;
MinValue := 0;
Value := 0;
OnChange := @EGreenChange;
// TabOrder := ERed.TabOrder + 1;
end;
with EBlue do
begin
Name := 'EBlue';
Width := 47;
Height := 22;
Left := cbColorDisplay.Left;
Top := LBlue.Top - 4;
Alignment := taRightJustify;
Anchors := [akLeft, akBottom];
MaxValue := 255;
MinValue := 0;
Value := 0;
OnChange := @EBlueChange;
// TabOrder := EGreen.TabOrder + 1;
end;
with EHue do
begin
Name := 'EHue';
Width := 47;
Height := 22;
Left := cbColorDisplay.Left + cbColorDisplay.Width - Width;
Top := ERed.Top;
Alignment := taRightJustify;
Anchors := [akLeft, akBottom];
MaxValue := MaxHue;
MinValue := 0;
Value := 0;
OnChange := @EHueChange;
// TabOrder := EBlue.TabOrder + 1;
end;
with ESat do
begin
Name := 'ESat';
Width := 47;
Height := 22;
Left := cbColorDisplay.Left + cbColorDisplay.Width - Width;
Top := EGreen.Top;
Alignment := taRightJustify;
Anchors := [akLeft, akBottom];
MaxValue := MaxSat;
MinValue := 0;
Value := 0;
OnChange := @ESatChange;
// TabOrder := EHue.TabOrder + 1;
end;
with ELum do
begin
Name := 'ELum';
Width := 47;
Height := 22;
Left := cbColorDisplay.Left + cbColorDisplay.Width - Width;
Top := EBlue.Top;
Alignment := taRightJustify;
Anchors := [akLeft, akBottom];
MaxValue := MaxLum;
MinValue := 0;
Value := 0;
OnChange := @ELumChange;
// TabOrder := ESat.TabOrder + 1;
end;
Custom.InsertControl(ERed);
Custom.InsertControl(EGreen);
Custom.InsertControl(EBlue);
Custom.InsertControl(EHue);
Custom.InsertControl(ESat);
Custom.InsertControl(ELum);
{$IFDEF mbXP_Lib}
with grip do
begin
Name := 'grip';
Width := 15;
Height := 15;
Left := 308;
Top := 314;
Anchors := [akRight, akBottom];
end;
InsertControl(grip);
{$ENDIF}
OKBtn.TabOrder := ELum.TabOrder + 1;
CancelBtn.TabOrder := OKBtn.TabOrder + 1;
end;
end. end.

203
components/mbColorLib/RAxisColorPicker.pas
View File

@ -1,18 +1,11 @@
unit RAxisColorPicker; unit RAxisColorPicker;
{$IFDEF FPC} {$MODE DELPHI}
{$MODE DELPHI}
{$ENDIF}
interface interface
uses uses
{$IFDEF FPC} LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics, Math, Forms,
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
HTMLColors, mbColorPickerControl; HTMLColors, mbColorPickerControl;
type type
@ -28,10 +21,6 @@ type
procedure CreateWnd; override; procedure CreateWnd; override;
procedure DrawMarker(x, y: integer); procedure DrawMarker(x, y: integer);
function GetGradientColor2D(x, y: Integer): TColor; override; function GetGradientColor2D(x, y: Integer): TColor; override;
(*
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
*)
procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
@ -50,6 +39,7 @@ type
property OnChange; property OnChange;
end; end;
implementation implementation
uses uses
@ -62,12 +52,7 @@ begin
inherited; inherited;
FGradientWidth := 256; FGradientWidth := 256;
FGradientHeight := 256; FGradientHeight := 256;
{$IFDEF DELPHI}
Width := 256;
Height := 256;
{$ELSE}
SetInitialBounds(0, 0, 256, 256); 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;
@ -81,24 +66,18 @@ begin
MarkerStyle := msCircle; MarkerStyle := msCircle;
end; end;
procedure TRAxisColorPicker.CreateWnd;
begin
inherited;
CreateGradient;
end;
{ x is BLUE, y is GREEN }
function TRAxisColorPicker.GetGradientColor2D(x, y: Integer): TColor;
begin
Result := RGB(FR, FBufferBmp.Height - 1 - y, x);
end;
procedure TRAxisColorPicker.CorrectCoords(var x, y: integer); procedure TRAxisColorPicker.CorrectCoords(var x, y: integer);
begin begin
Clamp(x, 0, Width - 1); Clamp(x, 0, Width - 1);
Clamp(y, 0, Height - 1); Clamp(y, 0, Height - 1);
end; end;
procedure TRAxisColorPicker.CreateWnd;
begin
inherited;
CreateGradient;
end;
procedure TRAxisColorPicker.DrawMarker(x, y: integer); procedure TRAxisColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
@ -116,18 +95,10 @@ begin
InternalDrawMarker(x, y, c); InternalDrawMarker(x, y, c);
end; end;
procedure TRAxisColorPicker.SetSelectedColor(c: TColor); { x is BLUE, y is GREEN }
function TRAxisColorPicker.GetGradientColor2D(x, y: Integer): TColor;
begin begin
if WebSafe then c := GetWebSafe(c); Result := RGB(FR, FBufferBmp.Height - 1 - y, x);
FR := GetRValue(c);
FG := GetGValue(c);
FB := GetBValue(c);
FSelected := c;
FManual := false;
myy := Round((255-FG)*(Height/255));
mxx := Round(FB*(Width/255));
Invalidate;
if Assigned(FOnChange) then FOnChange(self);
end; end;
procedure TRAxisColorPicker.Paint; procedure TRAxisColorPicker.Paint;
@ -229,23 +200,6 @@ begin
SetFocus; SetFocus;
end; end;
procedure TRAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
if ssLeft in Shift then
begin
{$IFDEF DELPHI}
ClipCursor(nil);
{$ENDIF}
mxx := x;
myy := y;
FSelected := GetColorAtPoint(x, y);
FManual := true;
Invalidate;
if Assigned(FOnChange) then FOnChange(self);
end;
end;
procedure TRAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TRAxisColorPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
@ -260,108 +214,25 @@ begin
end; end;
end; end;
(* procedure TRAxisColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
procedure TRAxisColorPicker.CNKeyDown( X, Y: Integer);
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} );
var
Shift: TShiftState;
FInherited: boolean;
begin begin
FInherited := false; inherited;
Shift := KeyDataToShiftState(Message.KeyData); if ssLeft in Shift then
if not (ssCtrl in Shift) then begin
case Message.CharCode of mxx := x;
VK_LEFT: myy := y;
begin FSelected := GetColorAtPoint(x, y);
mxx := dx - 1; FManual := true;
myy := dy; Invalidate;
FSelected := GetColorAtPoint(mxx, myy); if Assigned(FOnChange) then FOnChange(self);
FManual := true;
Invalidate;
end;
VK_RIGHT:
begin
mxx := dx + 1;
myy := dy;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_UP:
begin
mxx := dx;
myy := dy - 1;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_DOWN:
begin
mxx := dx;
myy := dy + 1;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
else
begin
FInherited := true;
inherited;
end;
end
else
case Message.CharCode of
VK_LEFT:
begin
mxx := dx - 10;
myy := dy;
Refresh;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_RIGHT:
begin
mxx := dx + 10;
myy := dy;
Refresh;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_UP:
begin
mxx := dx;
myy := dy - 10;
Refresh;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
VK_DOWN:
begin
mxx := dx;
myy := dy + 10;
Refresh;
FSelected := GetColorAtPoint(mxx, myy);
FManual := true;
Invalidate;
end;
else
begin
FInherited := true;
inherited;
end;
end; end;
if not FInherited then
if Assigned(OnKeyDown) then
OnKeyDown(Self, Message.CharCode, Shift);
end; end;
*)
procedure TRAxisColorPicker.SetRValue(r: integer); procedure TRAxisColorPicker.SetBValue(b: integer);
begin begin
Clamp(r, 0, 255); Clamp(b, 0, 255);
FR := r; FB := b;
SetSelectedColor(RGB(FR, FG, FB)); SetSelectedColor(RGB(FR, FG, FB));
end; end;
@ -372,11 +243,25 @@ begin
SetSelectedColor(RGB(FR, FG, FB)); SetSelectedColor(RGB(FR, FG, FB));
end; end;
procedure TRAxisColorPicker.SetBValue(b: integer); procedure TRAxisColorPicker.SetRValue(r: integer);
begin begin
Clamp(b, 0, 255); Clamp(r, 0, 255);
FB := b; FR := r;
SetSelectedColor(RGB(FR, FG, FB)); SetSelectedColor(RGB(FR, FG, FB));
end; end;
procedure TRAxisColorPicker.SetSelectedColor(c: TColor);
begin
if WebSafe then c := GetWebSafe(c);
FR := GetRValue(c);
FG := GetGValue(c);
FB := GetBValue(c);
FSelected := c;
FManual := false;
myy := Round((255-FG)*(Height/255));
mxx := Round(FB*(Width/255));
Invalidate;
if Assigned(FOnChange) then FOnChange(self);
end;
end. end.

198
components/mbColorLib/RColorPicker.pas
View File

@ -1,19 +1,12 @@
unit RColorPicker; unit RColorPicker;
{$IFDEF FPC} {$MODE DELPHI}
{$MODE DELPHI}
{$ENDIF}
interface interface
uses uses
{$IFDEF FPC} LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics, Forms,
LCLIntf, LCLType, LMessages, HTMLColors, Scanlines, mbTrackBarPicker;
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
mbTrackBarPicker, HTMLColors, Scanlines;
type type
@ -23,12 +16,12 @@ type
private private
FRed, FGreen, FBlue: integer; FRed, FGreen, FBlue: integer;
function ArrowPosFromRed(r: integer): integer; function ArrowPosFromRed(r: integer): integer;
function RedFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor; function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor); function RedFromArrowPos(p: integer): integer;
procedure SetRed(r: integer);
procedure SetGreen(g: integer);
procedure SetBlue(b: integer); procedure SetBlue(b: integer);
procedure SetGreen(g: integer);
procedure SetRed(r: integer);
procedure SetSelectedColor(c: TColor);
protected protected
procedure Execute(tbaAction: integer); override; procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override; function GetArrowPos: integer; override;
@ -50,7 +43,6 @@ implementation
uses uses
mbUtils; mbUtils;
{TRColorPicker} {TRColorPicker}
constructor TRColorPicker.Create(AOwner: TComponent); constructor TRColorPicker.Create(AOwner: TComponent);
@ -70,111 +62,25 @@ begin
FChange := true; FChange := true;
end; end;
function TRColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := RGB(AValue, FGreen, FBlue);
end;
procedure TRColorPicker.SetRed(r: integer);
begin
Clamp(r, 0, 255);
if FRed <> r then
begin
FRed := r;
FArrowPos := ArrowPosFromRed(r);
FManual := false;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TRColorPicker.SetGreen(g: integer);
begin
Clamp(g, 0, 255);
if FGreen <> g then
begin
FGreen := g;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TRColorPicker.SetBlue(b: integer);
begin
Clamp(b, 0, 255);
if FBlue <> b then
begin
FBlue := b;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
function TRColorPicker.ArrowPosFromRed(r: integer): integer; function TRColorPicker.ArrowPosFromRed(r: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/255)*r); a := Round((Width - 12) / 255 * r);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
r := 255 - r; r := 255 - r;
a := Round(((Height - 12)/255)*r); a := Round((Height - 12) / 255 * r);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function TRColorPicker.RedFromArrowPos(p: integer): integer;
var
r: integer;
begin
if Layout = lyHorizontal then
r := Round(p/((Width - 12)/255))
else
r := Round(255 - p/((Height - 12)/255));
Clamp(r, 0, 255);
Result := r;
end;
function TRColorPicker.GetSelectedColor: TColor;
begin
if not WebSafe then
Result := RGB(FRed, FGreen, FBlue)
else
Result := GetWebSafe(RGB(FRed, FGreen, FBlue));
end;
function TRColorPicker.GetSelectedValue: integer;
begin
Result := FRed;
end;
procedure TRColorPicker.SetSelectedColor(c: TColor);
begin
if WebSafe then c := GetWebSafe(c);
FChange := false;
SetGreen(GetGValue(c));
SetBlue(GetBValue(c));
SetRed(GetRValue(c));
FManual := false;
FChange := true;
if Assigned(OnChange) then OnChange(Self);
end;
function TRColorPicker.GetArrowPos: integer;
begin
Result := ArrowPosFromRed(FRed);
end;
procedure TRColorPicker.Execute(tbaAction: integer); procedure TRColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
@ -211,4 +117,90 @@ begin
end; end;
end; end;
function TRColorPicker.GetArrowPos: integer;
begin
Result := ArrowPosFromRed(FRed);
end;
function TRColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := RGB(AValue, FGreen, FBlue);
end;
function TRColorPicker.GetSelectedColor: TColor;
begin
if not WebSafe then
Result := RGB(FRed, FGreen, FBlue)
else
Result := GetWebSafe(RGB(FRed, FGreen, FBlue));
end;
function TRColorPicker.GetSelectedValue: integer;
begin
Result := FRed;
end;
function TRColorPicker.RedFromArrowPos(p: integer): integer;
var
r: integer;
begin
if Layout = lyHorizontal then
r := Round(p * 255 / (Width - 12))
else
r := Round(255 - p * 255 / (Height - 12));
Clamp(r, 0, 255);
Result := r;
end;
procedure TRColorPicker.SetBlue(b: integer);
begin
Clamp(b, 0, 255);
if FBlue <> b then
begin
FBlue := b;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TRColorPicker.SetGreen(g: integer);
begin
Clamp(g, 0, 255);
if FGreen <> g then
begin
FGreen := g;
FManual := false;
CreateGradient;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TRColorPicker.SetRed(r: integer);
begin
Clamp(r, 0, 255);
if FRed <> r then
begin
FRed := r;
FArrowPos := ArrowPosFromRed(r);
FManual := false;
Invalidate;
if FChange and Assigned(OnChange) then OnChange(Self);
end;
end;
procedure TRColorPicker.SetSelectedColor(c: TColor);
begin
if WebSafe then c := GetWebSafe(c);
FChange := false;
SetGreen(GetGValue(c));
SetBlue(GetBValue(c));
SetRed(GetRValue(c));
FManual := false;
FChange := true;
if Assigned(OnChange) then OnChange(Self);
end;
end. end.

359
components/mbColorLib/SLColorPicker.pas
View File

@ -1,17 +1,11 @@
unit SLColorPicker; unit SLColorPicker;
{$IFDEF FPC} {$MODE DELPHI}
{$MODE DELPHI}
{$ENDIF}
interface interface
uses uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms, SysUtils, Classes, Controls, Graphics, Math, Forms,
mbColorPickerControl; mbColorPickerControl;
@ -44,8 +38,6 @@ type
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
// procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
// message CN_KEYDOWN;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
function GetColorAtPoint(x, y: integer): TColor; override; function GetColorAtPoint(x, y: integer): TColor; override;
@ -77,12 +69,7 @@ begin
FMaxLum := 240; FMaxLum := 240;
FGradientWidth := FMaxSat + 1; // x --> Saturation FGradientWidth := FMaxSat + 1; // x --> Saturation
FGradientHeight := FMaxLum + 1; // y --> Luminance FGradientHeight := FMaxLum + 1; // y --> Luminance
{$IFDEF DELPHI}
Width := 255;
Height := 255;
{$ELSE}
SetInitialBounds(0, 0, FGradientWidth, FGradientHeight); SetInitialBounds(0, 0, FGradientWidth, FGradientHeight);
{$ENDIF}
FHue := 0.0; FHue := 0.0;
FSat := 0.0; FSat := 0.0;
FLum := 1.0; FLum := 1.0;
@ -90,19 +77,6 @@ begin
MarkerStyle := msCircle; MarkerStyle := msCircle;
end; end;
{ This picker has Saturation along the X and Luminance along the Y axis. }
function TSLColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
begin
Result := HSLtoColor(FHue, x / FMaxSat, (FMaxLum - y) / FMaxLum);
// Result := HSLtoRGB(FHue, x / FMaxSat, (FMaxLum - y) / FMaxLum);
end;
procedure TSLColorPicker.Resize;
begin
inherited;
UpdateCoords;
end;
procedure TSLColorPicker.CreateWnd; procedure TSLColorPicker.CreateWnd;
begin begin
inherited; inherited;
@ -110,12 +84,6 @@ begin
UpdateCoords; UpdateCoords;
end; end;
procedure TSLColorPicker.UpdateCoords;
begin
mdx := round(FSat * (Width - 1));
mdy := round((1.0 - FLum) * (Height - 1));
end;
procedure TSLColorPicker.DrawMarker(x, y: integer); procedure TSLColorPicker.DrawMarker(x, y: integer);
var var
c: TColor; c: TColor;
@ -124,11 +92,18 @@ begin
InternalDrawMarker(x, y, c); InternalDrawMarker(x, y, c);
end; end;
procedure TSLColorPicker.Paint; function TSLColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin begin
Canvas.StretchDraw(ClientRect, FBufferBMP); Result := HSLToRGB(FHue, x/(Width - 1), (Height - 1 - y) / (Height - 1));
UpdateCoords; if WebSafe then
DrawMarker(mdx, mdy); Result := GetWebSafe(Result);
end;
{ This picker has Saturation along the X and Luminance along the Y axis. }
function TSLColorPicker.GetGradientColor2D(X, Y: Integer): TColor;
begin
Result := HSLtoColor(FHue, x / FMaxSat, (FMaxLum - y) / FMaxLum);
// Result := HSLtoRGB(FHue, x / FMaxSat, (FMaxLum - y) / FMaxLum);
end; end;
function TSLColorPicker.GetHue: Integer; function TSLColorPicker.GetHue: Integer;
@ -146,97 +121,13 @@ begin
Result := round(FSat * FMaxSat); Result := round(FSat * FMaxSat);
end; end;
procedure TSLColorPicker.SetHue(H: integer); function TSLColorPicker.GetSelectedColor: TColor;
begin begin
Clamp(H, 0, FMaxHue); Result := HSLtoRGB(FHue, FSat, FLum);
if GetHue() <> H then if WebSafe then
begin Result := GetWebSafe(Result);
FHue := h / FMaxHue;
FManual := false;
CreateGradient;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end; end;
procedure TSLColorPicker.SetSat(S: integer);
begin
Clamp(S, 0, FMaxSat);
if GetSat() <> S then
begin
FSat := S / FMaxSat;
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TSLColorPicker.SetLum(L: integer);
begin
Clamp(L, 0, FMaxLum);
if GetLum() <> L then
begin
FLum := L / FMaxLum;
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TSLColorPicker.SetMaxHue(H: Integer);
begin
if H = FMaxHue then
exit;
FMaxHue := H;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
procedure TSLColorPicker.SetMaxLum(L: Integer);
begin
if L = FMaxLum then
exit;
FMaxLum := L;
FGradientHeight := FMaxLum + 1;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
procedure TSLColorPicker.SetMaxSat(S: Integer);
begin
if S = FMaxSat then
exit;
FMaxSat := S;
FGradientWidth := FMaxSat + 1;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
procedure TSLColorPicker.SelectionChanged(x, y: integer);
begin
FChange := false;
// SetSat(MulDiv(255, x, Width));
// SetLum(MulDiv(255, Height - y, Height));
FSat := x / (Width - 1);
FLum := (Height - y - 1) / (Height - 1);
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
{
SetSat(MulDiv(255, x, Width - 1));
SetLum(MulDiv(255, Height - y -1, Height - 1));
}
FChange := true;
end;
procedure TSLColorPicker.KeyDown(var Key: Word; Shift: TShiftState); procedure TSLColorPicker.KeyDown(var Key: Word; Shift: TShiftState);
var var
eraseKey: Boolean; eraseKey: Boolean;
@ -291,30 +182,8 @@ begin
inherited; inherited;
end; end;
procedure TSLColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
{$IFDEF DELPHI}
ClipCursor(nil);
{$ENDIF}
if csDesigning in ComponentState then Exit;
if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then
begin
mdx := x;
mdy := y;
SelectionChanged(X, Y);
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TSLColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; procedure TSLColorPicker.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); X, Y: Integer);
{$IFDEF DELPHI}
var
R: TRect;
{$ENDIF}
begin begin
inherited; inherited;
if csDesigning in ComponentState then if csDesigning in ComponentState then
@ -323,15 +192,7 @@ begin
begin begin
mdx := x; mdx := x;
mdy := y; mdy := y;
{$IFDEF DELPHI}
R := ClientRect;
R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight);
ClipCursor(@R);
{$ENDIF}
SelectionChanged(X, Y); SelectionChanged(X, Y);
// FManual := true;
// if Assigned(FOnChange) then FOnChange(Self);
end; end;
SetFocus; SetFocus;
end; end;
@ -346,8 +207,118 @@ begin
mdx := x; mdx := x;
mdy := y; mdy := y;
SelectionChanged(X, Y); SelectionChanged(X, Y);
// FManual := true; end;
// if Assigned(FOnChange) then FOnChange(Self); end;
procedure TSLColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
if csDesigning in ComponentState then Exit;
if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then
begin
mdx := x;
mdy := y;
SelectionChanged(X, Y);
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TSLColorPicker.Paint;
begin
Canvas.StretchDraw(ClientRect, FBufferBMP);
UpdateCoords;
DrawMarker(mdx, mdy);
end;
procedure TSLColorPicker.Resize;
begin
inherited;
UpdateCoords;
end;
procedure TSLColorPicker.SelectionChanged(x, y: integer);
begin
FChange := false;
FSat := x / (Width - 1);
FLum := (Height - y - 1) / (Height - 1);
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
FChange := true;
end;
procedure TSLColorPicker.SetHue(H: integer);
begin
Clamp(H, 0, FMaxHue);
if GetHue() <> H then
begin
FHue := h / FMaxHue;
FManual := false;
CreateGradient;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TSLColorPicker.SetLum(L: integer);
begin
Clamp(L, 0, FMaxLum);
if GetLum() <> L then
begin
FLum := L / FMaxLum;
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end;
end;
procedure TSLColorPicker.SetMaxHue(H: Integer);
begin
if H = FMaxHue then
exit;
FMaxHue := H;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
procedure TSLColorPicker.SetMaxLum(L: Integer);
begin
if L = FMaxLum then
exit;
FMaxLum := L;
FGradientHeight := FMaxLum + 1;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
procedure TSLColorPicker.SetMaxSat(S: Integer);
begin
if S = FMaxSat then
exit;
FMaxSat := S;
FGradientWidth := FMaxSat + 1;
CreateGradient;
if FChange and Assigned(OnChange) then OnChange(Self);
Invalidate;
end;
procedure TSLColorPicker.SetSat(S: integer);
begin
Clamp(S, 0, FMaxSat);
if GetSat() <> S then
begin
FSat := S / FMaxSat;
FManual := false;
UpdateCoords;
Invalidate;
if FChange and Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
@ -366,79 +337,11 @@ begin
FChange := true; FChange := true;
end; end;
function TSLColorPicker.GetSelectedColor: TColor; procedure TSLColorPicker.UpdateCoords;
begin begin
Result := HSLtoRGB(FHue, FSat, FLum); mdx := round(FSat * (Width - 1));
if WebSafe then mdy := round((1.0 - FLum) * (Height - 1));
Result := GetWebSafe(Result);
end; end;
function TSLColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := HSLToRGB(FHue, x/(Width - 1), (Height - 1 - y) / (Height - 1));
if WebSafe then
Result := GetWebSafe(Result);
end;
(*
procedure TSLColorPicker.CNKeyDown(
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} );
var
Shift: TShiftState;
FInherited: boolean;
delta: Integer;
begin
FInherited := false;
Shift := KeyDataToShiftState(Message.KeyData);
if ssCtrl in Shift then
delta := 10
else
delta := 1;
case Message.CharCode of
VK_LEFT:
if not (mdx - delta < 0) then
begin
Dec(mdx, delta);
SelectionChanged(mdx, mdy);
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
VK_RIGHT:
if not (mdx + delta > Width) then
begin
Inc(mdx, delta);
SelectionChanged(mdx, mdy);
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
VK_UP:
if not (mdy - delta < 0) then
begin
Dec(mdy, delta);
SelectionChanged(mdx, mdy);
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
VK_DOWN:
if not (mdy + delta > Height) then
begin
Inc(mdy, delta);
SelectionChanged(mdx, mdy);
FManual := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
else
begin
FInherited := true;
inherited;
end;
end;
if not FInherited then
if Assigned(OnKeyDown) then
OnKeyDown(Self, Message.CharCode, Shift);
end;
*)
end. end.

354
components/mbColorLib/SLHColorPicker.pas
View File

@ -1,22 +1,13 @@
unit SLHColorPicker; unit SLHColorPicker;
{$IFDEF FPC} {$MODE DELPHI}
{$MODE DELPHI}
{$ENDIF}
interface interface
{$I mxs.inc}
uses uses
{$IFDEF FPC} LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics, Forms, Menus, Themes,
LCLIntf, LCLType, LMessages, RGBHSLUtils, mbTrackBarPicker, HTMLColors, SLColorPicker, HColorPicker,
{$ELSE} mbBasicPicker;
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
RGBHSLUtils, mbTrackBarPicker, SLColorPicker, HColorPicker, Menus,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, mbBasicPicker;
type type
TSLHColorPicker = class(TmbBasicPicker) TSLHColorPicker = class(TmbBasicPicker)
@ -55,23 +46,17 @@ type
procedure HPickerChange(Sender: TObject); procedure HPickerChange(Sender: TObject);
procedure SLPickerChange(Sender: TObject); procedure SLPickerChange(Sender: TObject);
protected protected
// procedure CreateWnd; override;
procedure DoChange; procedure DoChange;
procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
function GetColorUnderCursor: TColor; override; function GetColorUnderCursor: TColor; override;
procedure Paint; override; procedure Paint; override;
// procedure PaintParentBack; override;
procedure Resize; override; procedure Resize; override;
procedure SetFocus; 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 GetHexColorUnderCursor: string; override; function GetHexColorUnderCursor: string; override;
function GetSelectedHexColor: string; function GetSelectedHexColor: string;
procedure SetFocus; override;
property ColorUnderCursor; property ColorUnderCursor;
property Hue: integer read GetH write SetH; property Hue: integer read GetH write SetH;
property Saturation: integer read GetS write SetS; property Saturation: integer read GetS write SetS;
@ -98,13 +83,11 @@ type
property TabOrder; property TabOrder;
property Color; property Color;
property ParentColor default true; property ParentColor default true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
property ParentBackground default true;
{$ENDIF}{$ENDIF}
property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnMouseMove; property OnMouseMove;
end; end;
implementation implementation
const const
@ -120,22 +103,14 @@ constructor TSLHColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
//ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; //ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];
DoubleBuffered := true;
FMaxH := 359; FMaxH := 359;
FMaxS := 240; FMaxS := 240;
FMaxL := 100; FMaxL := 100;
PBack := TBitmap.Create; PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit; PBack.PixelFormat := pf32bit;
ParentColor := true; ParentColor := true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF}{$ENDIF}
{$IFDEF DELPHI}
Width := 297;
Height := 271;
{$ELSE}
SetInitialBounds(0, 0, WSL + DIST + WH, HSL + 2*VDELTA); 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);
@ -148,15 +123,7 @@ begin
InsertControl(FSLPicker); InsertControl(FSLPicker);
with FSLPicker do with FSLPicker do
begin begin
{$IFDEF DELPHI}
Left := 0;
Top := DELTA;
Width := 255;
Height := self.Height - 2 * VDELTA;
{$ELSE}
SetInitialBounds(0, VDELTA, WSL, HSL); SetInitialBounds(0, VDELTA, WSL, HSL);
{$ENDIF}
//Anchors := [akLeft, akRight, akTop, akBottom];
Visible := true; Visible := true;
SelectedColor := clRed; SelectedColor := clRed;
MaxHue := FMaxH; MaxHue := FMaxH;
@ -172,22 +139,13 @@ begin
with FHPicker do with FHPicker do
begin begin
Layout := lyVertical; // put before setting width and height Layout := lyVertical; // put before setting width and height
{$IFDEF DELPHI}
Left := 257;
Top := 0;
Width := 40;
Height := 271;
{$ELSE}
SetInitialBounds(WSL + DIST, 0, WH, HSL + 2*VDELTA); SetInitialBounds(WSL + DIST, 0, WH, HSL + 2*VDELTA);
{$ENDIF}
MaxHue := self.FMaxH; MaxHue := self.FMaxH;
MaxSaturation := 255; MaxSaturation := 255;
MaxValue := 255; MaxValue := 255;
Saturation := MaxSaturation; Saturation := MaxSaturation;
Value := MaxValue; Value := MaxValue;
// Anchors := [akTop, akRight, akBottom];
Visible := true; Visible := true;
// Layout := lyVertical;
ArrowPlacement := spBoth; ArrowPlacement := spBoth;
NewArrowStyle := true; NewArrowStyle := true;
OnChange := HPickerChange; OnChange := HPickerChange;
@ -207,23 +165,9 @@ end;
destructor TSLHColorPicker.Destroy; destructor TSLHColorPicker.Destroy;
begin begin
PBack.Free; PBack.Free;
// FHPicker.Free;
// FSLPicker.Free;
inherited Destroy; inherited Destroy;
end; end;
procedure TSLHColorPicker.HPickerChange(Sender: TObject);
begin
FSLPicker.Hue := FHPicker.Hue;
DoChange;
end;
procedure TSLHColorPicker.SLPickerChange(Sender: TObject);
begin
FSelectedColor := FSLPicker.SelectedColor;
DoChange;
end;
procedure TSLHColorPicker.DoChange; procedure TSLHColorPicker.DoChange;
begin begin
FHValue := FHPicker.Hue / FHPicker.MaxHue; FHValue := FHPicker.Hue / FHPicker.MaxHue;
@ -236,113 +180,6 @@ begin
FOnChange(Self); FOnChange(Self);
end; end;
procedure TSLHColorPicker.SelectColor(c: TColor);
begin
FSelectedColor := c;
FHPicker.Hue := GetHValue(c);
FSLPicker.SelectedColor := c;
end;
function TSLHColorPicker.GetH: Integer;
begin
Result := Round(FHValue * FMaxH);
end;
function TSLHColorPicker.GetS: Integer;
begin
Result := Round(FSValue * FMaxS);
end;
function TSLHColorPicker.GetL: Integer;
begin
Result := ROund(FLValue * FMaxL);
end;
procedure TSLHColorPicker.SetH(H: integer);
begin
FHValue := H / FMaxH;
FSLPicker.Hue := H;
FHPicker.Hue := H;
end;
procedure TSLHColorPicker.SetS(S: integer);
begin
FSValue := S / FMaxS;
FSLPicker.Saturation := S;
end;
procedure TSLHColorPicker.SetL(L: integer);
begin
FLValue := L / FMaxL;
FSLPicker.Luminance := L;
end;
procedure TSLHColorPicker.SetR(R: integer);
begin
FRValue := R;
SelectColor(RGB(FRValue, FGValue, FBValue));
end;
procedure TSLHColorPicker.SetG(G: integer);
begin
FGValue := G;
SelectColor(RGB(FRValue, FGValue, FBValue));
end;
procedure TSLHColorPicker.SetB(B: integer);
begin
FBValue := B;
SelectColor(RGB(FRValue, FGValue, FBValue));
end;
procedure TSLHColorPicker.SetMaxH(H: Integer);
begin
FMaxH := H;
FSLPicker.MaxHue := H;
FHPicker.MaxHue := H;
end;
procedure TSLHColorPicker.SetMaxS(S: Integer);
begin
FMaxS := S;
FSLPicker.MaxSaturation := S;
end;
procedure TSLHColorPicker.SetMaxL(L: Integer);
begin
FMaxL := L;
FSLPicker.MaxLuminance := L;
end;
function TSLHColorPicker.GetSelectedHexColor: string;
begin
Result := ColorToHex(FSelectedColor);
end;
procedure TSLHColorPicker.SetHHint(h: string);
begin
FHHint := h;
FHPicker.HintFormat := h;
end;
procedure TSLHColorPicker.SetSLHint(h: string);
begin
FSLHint := h;
FSLPicker.HintFormat := h;
end;
procedure TSLHColorPicker.SetSLMenu(m: TPopupMenu);
begin
FSLMenu := m;
FSLPicker.PopupMenu := m;
end;
procedure TSLHColorPicker.SetHMenu(m: TPopupMenu);
begin
FHMenu := m;
FHPicker.PopupMenu := m;
end;
procedure TSLHColorPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure TSLHColorPicker.DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin begin
if Assigned(OnMouseMove) then if Assigned(OnMouseMove) then
@ -355,41 +192,47 @@ begin
Result := FSLPicker.ColorUnderCursor; Result := FSLPicker.ColorUnderCursor;
end; end;
function TSLHColorPicker.GetH: Integer;
begin
Result := Round(FHValue * FMaxH);
end;
function TSLHColorPicker.GetHexColorUnderCursor: string; function TSLHColorPicker.GetHexColorUnderCursor: string;
begin begin
Result := FSLPicker.GetHexColorUnderCursor; Result := FSLPicker.GetHexColorUnderCursor;
end; end;
procedure TSLHColorPicker.SetHCursor(c: TCursor); function TSLHColorPicker.GetL: Integer;
begin begin
FHCursor := c; Result := ROund(FLValue * FMaxL);
FHPicker.Cursor := c;
end; end;
procedure TSLHColorPicker.SetSLCursor(c: TCursor);
begin
FSLCursor := c;
FSLPicker.Cursor := c;
end;
procedure TSLHColorPicker.SetFocus;
begin
FSLPicker.SetFocus;
end;
(*
procedure TSLHColorPicker.WMSetFocus(
var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF} );
begin
FSLPicker.SetFocus;
Message.Result := 1;
end;
*)
function TSLHColorPicker.GetManual:boolean; function TSLHColorPicker.GetManual:boolean;
begin begin
Result := FHPicker.Manual or FSLPicker.Manual; Result := FHPicker.Manual or FSLPicker.Manual;
end; end;
function TSLHColorPicker.GetS: Integer;
begin
Result := Round(FSValue * FMaxS);
end;
function TSLHColorPicker.GetSelectedHexColor: string;
begin
Result := ColorToHex(FSelectedColor);
end;
procedure TSLHColorPicker.HPickerChange(Sender: TObject);
begin
FSLPicker.Hue := FHPicker.Hue;
DoChange;
end;
procedure TSLHColorPicker.Paint;
begin
PaintParentBack(Canvas);
end;
procedure TSLHColorPicker.Resize; procedure TSLHColorPicker.Resize;
begin begin
inherited; inherited;
@ -404,29 +247,116 @@ begin
FHPicker.Left := Width - FHPicker.Width; FHPicker.Left := Width - FHPicker.Width;
FHPicker.Height := Height; FHPicker.Height := Height;
end; end;
{
procedure TSLHColorPicker.PaintParentBack;
begin
if PBack = nil then
begin
PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit;
end;
PBack.Width := Width;
PBack.Height := Height;
PaintParentBack(PBack);
end; }
procedure TSLHColorPicker.Paint; procedure TSLHColorPicker.SelectColor(c: TColor);
begin begin
PaintParentBack(Canvas); FSelectedColor := c;
// Canvas.Draw(0, 0, PBack); FHPicker.Hue := GetHValue(c);
FSLPicker.SelectedColor := c;
end; end;
(*
procedure TSLHColorPicker.CreateWnd; procedure TSLHColorPicker.SetB(B: integer);
begin begin
inherited; FBValue := B;
PaintParentBack; SelectColor(RGB(FRValue, FGValue, FBValue));
end; end;
*)
procedure TSLHColorPicker.SetFocus;
begin
FSLPicker.SetFocus;
end;
procedure TSLHColorPicker.SetH(H: integer);
begin
FHValue := H / FMaxH;
FSLPicker.Hue := H;
FHPicker.Hue := H;
end;
procedure TSLHColorPicker.SetG(G: integer);
begin
FGValue := G;
SelectColor(RGB(FRValue, FGValue, FBValue));
end;
procedure TSLHColorPicker.SetHHint(h: string);
begin
FHHint := h;
FHPicker.HintFormat := h;
end;
procedure TSLHColorPicker.SetHMenu(m: TPopupMenu);
begin
FHMenu := m;
FHPicker.PopupMenu := m;
end;
procedure TSLHColorPicker.SetL(L: integer);
begin
FLValue := L / FMaxL;
FSLPicker.Luminance := L;
end;
procedure TSLHColorPicker.SetMaxH(H: Integer);
begin
FMaxH := H;
FSLPicker.MaxHue := H;
FHPicker.MaxHue := H;
end;
procedure TSLHColorPicker.SetMaxL(L: Integer);
begin
FMaxL := L;
FSLPicker.MaxLuminance := L;
end;
procedure TSLHColorPicker.SetMaxS(S: Integer);
begin
FMaxS := S;
FSLPicker.MaxSaturation := S;
end;
procedure TSLHColorPicker.SetR(R: integer);
begin
FRValue := R;
SelectColor(RGB(FRValue, FGValue, FBValue));
end;
procedure TSLHColorPicker.SetS(S: integer);
begin
FSValue := S / FMaxS;
FSLPicker.Saturation := S;
end;
procedure TSLHColorPicker.SetSLHint(h: string);
begin
FSLHint := h;
FSLPicker.HintFormat := h;
end;
procedure TSLHColorPicker.SetSLMenu(m: TPopupMenu);
begin
FSLMenu := m;
FSLPicker.PopupMenu := m;
end;
procedure TSLHColorPicker.SetHCursor(c: TCursor);
begin
FHCursor := c;
FHPicker.Cursor := c;
end;
procedure TSLHColorPicker.SetSLCursor(c: TCursor);
begin
FSLCursor := c;
FSLPicker.Cursor := c;
end;
procedure TSLHColorPicker.SLPickerChange(Sender: TObject);
begin
FSelectedColor := FSLPicker.SelectedColor;
DoChange;
end;
end. end.

21
components/mbColorLib/examples/fulldemo/main.lfm
View File

@ -3,7 +3,7 @@ object Form1: TForm1
Height = 397 Height = 397
Top = 197 Top = 197
Width = 539 Width = 539
Caption = 'mbColor Lib v2.0.1 Demo' Caption = 'mbColor Lib v2.1 Demo'
ClientHeight = 397 ClientHeight = 397
ClientWidth = 539 ClientWidth = 539
Font.Color = clWindowText Font.Color = clWindowText
@ -43,9 +43,9 @@ object Form1: TForm1
Height = 384 Height = 384
Top = 6 Top = 6
Width = 403 Width = 403
ActivePage = TabSheet1 ActivePage = TabSheet3
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
TabIndex = 0 TabIndex = 2
TabOrder = 0 TabOrder = 0
OnChange = PageControl1Change OnChange = PageControl1Change
OnMouseMove = PageControl1MouseMove OnMouseMove = PageControl1MouseMove
@ -89,8 +89,8 @@ object Form1: TForm1
Width = 289 Width = 289
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
HintFormat = 'RGB(%r, %g, %b)'#13'Hex: #%hex' HintFormat = 'RGB(%r, %g, %b)'#13'Hex: #%hex'
SliderMarker = smRect
IntensityText = 'Intensity' IntensityText = 'Intensity'
SliderMarker = smRect
TabOrder = 0 TabOrder = 0
Constraints.MinHeight = 85 Constraints.MinHeight = 85
Constraints.MinWidth = 93 Constraints.MinWidth = 93
@ -697,9 +697,9 @@ object Form1: TForm1
Width = 104 Width = 104
Caption = 'Pick from screen' Caption = 'Pick from screen'
TabOrder = 0 TabOrder = 0
OnSelColorChange = mbDeskPickerButton1SelColorChange
ScreenHintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h' ScreenHintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h'
ShowScreenHint = True ShowScreenHint = True
OnSelColorChange = mbDeskPickerButton1SelColorChange
end end
object OfficeColorDialogButton: TButton object OfficeColorDialogButton: TButton
Left = 8 Left = 8
@ -721,8 +721,8 @@ object Form1: TForm1
TabOrder = 2 TabOrder = 2
Hue = 0 Hue = 0
Saturation = 0 Saturation = 0
Luminance = 94 Luminance = 78
SelectedColor = 6184542 SelectedColor = 5131854
end end
object VColorPicker1: TVColorPicker object VColorPicker1: TVColorPicker
Left = 34 Left = 34
@ -835,7 +835,6 @@ object Form1: TForm1
HintFormat = 'H: %h S: %s'#13'Hex: %hex' HintFormat = 'H: %h S: %s'#13'Hex: %hex'
TabOrder = 0 TabOrder = 0
OnMouseMove = HSColorPicker1MouseMove OnMouseMove = HSColorPicker1MouseMove
Luminance = 120
MarkerStyle = msSquare MarkerStyle = msSquare
OnChange = HSColorPicker1Change OnChange = HSColorPicker1Change
end end
@ -957,8 +956,8 @@ object Form1: TForm1
HintFormat = 'Blue: %b (selected)' HintFormat = 'Blue: %b (selected)'
SelectionIndicator = siRect SelectionIndicator = siRect
TabOrder = 6 TabOrder = 6
Red = 122
Green = 122 Green = 122
Red = 122
SelectedColor = 16743034 SelectedColor = 16743034
end end
object KColorPicker2: TKColorPicker object KColorPicker2: TKColorPicker
@ -1063,9 +1062,9 @@ object Form1: TForm1
SelectedColor = 16119089 SelectedColor = 16119089
HintFormat = 'A: %cieA B: %cieB'#13'Hex: #%hex' HintFormat = 'A: %cieA B: %cieB'#13'Hex: #%hex'
TabOrder = 3 TabOrder = 3
LValue = 88
AValue = -47 AValue = -47
BValue = -32 BValue = -32
LValue = 88
OnChange = CIELColorPicker1Change OnChange = CIELColorPicker1Change
end end
object CIEAColorPicker1: TCIEAColorPicker object CIEAColorPicker1: TCIEAColorPicker
@ -1090,9 +1089,9 @@ object Form1: TForm1
SelectedColor = 130823 SelectedColor = 130823
HintFormat = 'L: %cieL A: %cieA'#13'Hex: #%hex' HintFormat = 'L: %cieL A: %cieA'#13'Hex: #%hex'
TabOrder = 5 TabOrder = 5
LValue = 88
AValue = -88 AValue = -88
BValue = 74 BValue = 74
LValue = 88
OnChange = CIEBColorPicker1Change OnChange = CIEBColorPicker1Change
end end
object Label10: TLabel object Label10: TLabel

84
components/mbColorLib/examples/fulldemo/main.pas
View File

@ -190,28 +190,28 @@ uses
procedure TForm1.tb1Change(Sender: TObject); procedure TForm1.tb1Change(Sender: TObject);
begin begin
sc.opacity := tb1.position; sc.opacity := tb1.position;
end; end;
procedure TForm1.tb2Change(Sender: TObject); procedure TForm1.tb2Change(Sender: TObject);
begin begin
uc.opacity := tb2.position; uc.opacity := tb2.position;
end; end;
procedure TForm1.HSLColorPicker1Change(Sender: TObject); procedure TForm1.HSLColorPicker1Change(Sender: TObject);
begin begin
sc.color := HSLColorPicker1.SelectedColor; sc.color := HSLColorPicker1.SelectedColor;
end; end;
procedure TForm1.HSLColorPicker1MouseMove(Sender: TObject; procedure TForm1.HSLColorPicker1MouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer); Shift: TShiftState; X, Y: Integer);
begin begin
uc.color := HSLColorPicker1.ColorUnderCursor; uc.color := HSLColorPicker1.ColorUnderCursor;
end; end;
procedure TForm1.HexaColorPicker1Change(Sender: TObject); procedure TForm1.HexaColorPicker1Change(Sender: TObject);
begin begin
sc.color := hexacolorpicker1.selectedcolor; sc.color := hexacolorpicker1.selectedcolor;
end; end;
procedure TForm1.HexaColorPicker1MouseMove(Sender: TObject; procedure TForm1.HexaColorPicker1MouseMove(Sender: TObject;
@ -227,28 +227,28 @@ end;
procedure TForm1.Button1Click(Sender: TObject); procedure TForm1.Button1Click(Sender: TObject);
begin begin
mbColorPalette1.GeneratePalette(clblue); mbColorPalette1.GeneratePalette(clblue);
end; end;
procedure TForm1.Button2Click(Sender: TObject); procedure TForm1.Button2Click(Sender: TObject);
begin begin
mbColorpalette1.GenerateGradientPalette([clblue, clred]); mbColorpalette1.GenerateGradientPalette([clblue, clred]);
end; end;
procedure TForm1.mbColorPalette1SelColorChange(Sender: TObject); procedure TForm1.mbColorPalette1SelColorChange(Sender: TObject);
begin begin
uc.Color := mbColorPalette1.SelectedColor; sc.Color := mbColorPalette1.SelectedColor;
end; end;
procedure TForm1.mbColorPalette1MouseMove(Sender: TObject; procedure TForm1.mbColorPalette1MouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer); Shift: TShiftState; X, Y: Integer);
begin begin
uc.color := mbcolorpalette1.ColorUnderCursor; uc.color := mbcolorpalette1.ColorUnderCursor;
end; end;
procedure TForm1.HSLRingPicker1Change(Sender: TObject); procedure TForm1.HSLRingPicker1Change(Sender: TObject);
begin begin
sc.color := HSLRingPicker1.SelectedColor; sc.color := HSLRingPicker1.SelectedColor;
end; end;
procedure TForm1.HSLRingPicker1MouseMove(Sender: TObject; procedure TForm1.HSLRingPicker1MouseMove(Sender: TObject;
@ -259,9 +259,9 @@ end;
procedure TForm1.HSVColorPicker1Change(Sender: TObject); procedure TForm1.HSVColorPicker1Change(Sender: TObject);
begin begin
sc.color := HSVColorPicker1.SelectedColor; sc.color := HSVColorPicker1.SelectedColor;
VColorPicker2.Saturation := HSVColorPicker1.Saturation; VColorPicker2.Saturation := HSVColorPicker1.Saturation;
VColorPicker2.Hue := HSVColorPicker1.Hue; VColorPicker2.Hue := HSVColorPicker1.Hue;
end; end;
procedure TForm1.HSVColorPicker1MouseMove(Sender: TObject; procedure TForm1.HSVColorPicker1MouseMove(Sender: TObject;
@ -272,7 +272,7 @@ end;
procedure TForm1.SLHColorPicker1Change(Sender: TObject); procedure TForm1.SLHColorPicker1Change(Sender: TObject);
begin begin
sc.color := SLHColorPicker1.SelectedColor; sc.color := SLHColorPicker1.SelectedColor;
end; end;
procedure TForm1.SLHColorPicker1MouseMove(Sender: TObject; procedure TForm1.SLHColorPicker1MouseMove(Sender: TObject;
@ -283,8 +283,8 @@ end;
procedure TForm1.mbDeskPickerButton1SelColorChange(Sender: TObject); procedure TForm1.mbDeskPickerButton1SelColorChange(Sender: TObject);
begin begin
sc.color := mbDeskPickerButton1.SelectedColor; sc.color := mbDeskPickerButton1.SelectedColor;
uc.color := mbDeskPickerButton1.SelectedColor; uc.color := mbDeskPickerButton1.SelectedColor;
end; end;
procedure TForm1.PageControl1Change(Sender: TObject); procedure TForm1.PageControl1Change(Sender: TObject);
@ -333,18 +333,18 @@ end;
procedure TForm1.HRingPicker1Change(Sender: TObject); procedure TForm1.HRingPicker1Change(Sender: TObject);
begin begin
sc.color := hringpicker1.SelectedColor; sc.color := hringpicker1.SelectedColor;
end; end;
procedure TForm1.HRingPicker1MouseMove(Sender: TObject; Shift: TShiftState; procedure TForm1.HRingPicker1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer); X, Y: Integer);
begin begin
uc.color := hringpicker1.ColorUnderCursor; uc.color := hringpicker1.ColorUnderCursor;
end; end;
procedure TForm1.VColorPicker2Change(Sender: TObject); procedure TForm1.VColorPicker2Change(Sender: TObject);
begin begin
HSVColorPicker1.Value := VColorPicker2.Value; HSVColorPicker1.Value := VColorPicker2.Value;
end; end;
// only for internet shortcuts // only for internet shortcuts
@ -376,27 +376,27 @@ end;
procedure TForm1.CheckBox1Click(Sender: TObject); procedure TForm1.CheckBox1Click(Sender: TObject);
begin begin
HexaColorPicker1.SliderVisible := checkbox1.Checked; HexaColorPicker1.SliderVisible := checkbox1.Checked;
end; end;
procedure TForm1.ComboBox1Change(Sender: TObject); procedure TForm1.ComboBox1Change(Sender: TObject);
begin begin
hexacolorpicker1.SliderMarker := TMArker(ComboBox1.ItemIndex); hexacolorpicker1.SliderMarker := TMArker(ComboBox1.ItemIndex);
end; end;
procedure TForm1.CheckBox2Click(Sender: TObject); procedure TForm1.CheckBox2Click(Sender: TObject);
begin begin
hexacolorpicker1.NewArrowStyle := checkbox2.checked; hexacolorpicker1.NewArrowStyle := checkbox2.checked;
end; end;
procedure TForm1.CIEAColorPicker1Change(Sender: TObject); procedure TForm1.CIEAColorPicker1Change(Sender: TObject);
begin begin
CIEAIndicator.Brush.Color := CIEAColorPicker1.SelectedColor; CIEAIndicator.Brush.Color := CIEAColorPicker1.SelectedColor;
end; end;
procedure TForm1.CIEBColorPicker1Change(Sender: TObject); procedure TForm1.CIEBColorPicker1Change(Sender: TObject);
begin begin
CIEBIndicator.Brush.Color := CIEBColorPicker1.SelectedColor; CIEBIndicator.Brush.Color := CIEBColorPicker1.SelectedColor;
end; end;
procedure TForm1.CIELColorPicker1Change(Sender: TObject); procedure TForm1.CIELColorPicker1Change(Sender: TObject);
@ -406,54 +406,54 @@ end;
procedure TForm1.Button4Click(Sender: TObject); procedure TForm1.Button4Click(Sender: TObject);
begin begin
if opendialog1.Execute then if opendialog1.Execute then
mbcolorpalette1.Palette := opendialog1.FileName; mbcolorpalette1.Palette := opendialog1.FileName;
end; end;
procedure TForm1.ComboBox2Change(Sender: TObject); procedure TForm1.ComboBox2Change(Sender: TObject);
begin begin
mbcolorpalette1.SortOrder := tsortorder(combobox2.itemindex); mbcolorpalette1.SortOrder := tsortorder(combobox2.itemindex);
end; end;
procedure TForm1.ComboBox3Change(Sender: TObject); procedure TForm1.ComboBox3Change(Sender: TObject);
begin begin
mbcolorpalette1.Sortmode := tsortmode(combobox3.ItemIndex); mbcolorpalette1.Sortmode := tsortmode(combobox3.ItemIndex);
end; end;
procedure TForm1.ComboBox4Change(Sender: TObject); procedure TForm1.ComboBox4Change(Sender: TObject);
begin begin
mbcolorpalette1.CellStyle := tcellstyle(combobox4.ItemIndex); mbcolorpalette1.CellStyle := tcellstyle(combobox4.ItemIndex);
end; end;
procedure TForm1.UpDown1ChangingEx(Sender: TObject; var AllowChange: Boolean; procedure TForm1.UpDown1ChangingEx(Sender: TObject; var AllowChange: Boolean;
NewValue: SmallInt; Direction: TUpDownDirection); NewValue: SmallInt; Direction: TUpDownDirection);
begin begin
allowchange := true; allowchange := true;
mbcolorpalette1.CellSize := abs(NewValue); mbcolorpalette1.CellSize := abs(NewValue);
end; end;
procedure TForm1.CbWebSsafeClick(Sender: TObject); procedure TForm1.CbWebSsafeClick(Sender: TObject);
var var
i: integer; i: integer;
begin begin
for i := 0 to ComponentCount - 1 do for i := 0 to ComponentCount - 1 do
if IsPublishedProp(components[i], 'WebSafe') = true then if IsPublishedProp(components[i], 'WebSafe') = true then
SetOrdProp(components[i], 'WebSafe', integer(CbWebSsafe.checked)); SetOrdProp(components[i], 'WebSafe', integer(CbWebSsafe.checked));
end; end;
procedure TForm1.Button5Click(Sender: TObject); procedure TForm1.Button5Click(Sender: TObject);
var var
i: integer; i: integer;
begin begin
mbcolortree1.ClearColors; mbcolortree1.ClearColors;
mbcolorlist1.ClearColors; mbcolorlist1.ClearColors;
for i := 0 to mbcolorpalette1.Colors.Count - 1 do for i := 0 to mbcolorpalette1.Colors.Count - 1 do
begin begin
mbcolortree1.AddColor('Color '+inttostr(i), StringtoColor(mbcolorpalette1.colors.Strings[i]), false); mbcolortree1.AddColor('Color '+inttostr(i), StringtoColor(mbcolorpalette1.colors.Strings[i]), false);
mbcolorlist1.AddColor('Color '+inttostr(i), StringtoColor(mbcolorpalette1.colors.Strings[i]), false); mbcolorlist1.AddColor('Color '+inttostr(i), StringtoColor(mbcolorpalette1.colors.Strings[i]), false);
end; end;
mbcolortree1.UpdateColors; mbcolortree1.UpdateColors;
mbcolorlist1.UpdateColors; mbcolorlist1.UpdateColors;
end; end;
procedure TForm1.CbEnabledChange(Sender: TObject); procedure TForm1.CbEnabledChange(Sender: TObject);

197
components/mbColorLib/mbBasicPicker.pas
View File

@ -5,16 +5,10 @@ unit mbBasicPicker;
interface interface
uses uses
{$IFDEF FPC} LMessages, Classes, SysUtils, Graphics, Controls, ExtCtrls, Forms;
LMessages,
{$ELSE}
Messages,
{$ENDIF}
Classes, SysUtils, Graphics, Controls, ExtCtrls, Forms;
type type
THintState = (hsOff, hsWaitingToShow, hsWaitingToHide); THintState = (hsOff, hsWaitingToShow, hsWaitingToHide);
TGetHintStrEvent = procedure (Sender: TObject; X, Y: Integer; var AText: String) of object; TGetHintStrEvent = procedure (Sender: TObject; X, Y: Integer; var AText: String) of object;
{ TmbBasicPicker } { TmbBasicPicker }
@ -22,12 +16,6 @@ type
TmbBasicPicker = class(TCustomControl) TmbBasicPicker = class(TCustomControl)
private private
FOnGetHintStr: TGetHintStrEvent; FOnGetHintStr: TGetHintStrEvent;
{
FHintWindow: THintWindow;
FHintTimer: TTimer;
FHintState: THintState;
procedure HintTimer(Sender: TObject);
}
protected protected
FBufferBmp: TBitmap; FBufferBmp: TBitmap;
FGradientWidth: Integer; FGradientWidth: Integer;
@ -39,20 +27,12 @@ type
function GetGradientColor2D(X, Y: Integer): TColor; virtual; function GetGradientColor2D(X, Y: Integer): TColor; virtual;
function GetHintPos(X, Y: Integer): TPoint; virtual; function GetHintPos(X, Y: Integer): TPoint; virtual;
function GetHintStr(X, Y: Integer): String; virtual; function GetHintStr(X, Y: Integer): String; virtual;
procedure MouseLeave; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure PaintParentBack; virtual; overload; procedure PaintParentBack; virtual; overload;
procedure PaintParentBack(ACanvas: TCanvas); overload; procedure PaintParentBack(ACanvas: TCanvas); overload;
procedure PaintParentBack(ACanvas: TCanvas; ARect: TRect); overload; procedure PaintParentBack(ACanvas: TCanvas; ARect: TRect); overload;
procedure PaintParentBack(ABitmap: TBitmap); overload; procedure PaintParentBack(ABitmap: TBitmap); overload;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
{$IFDEF DELPHI}
procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
{$ELSE}
procedure CMParentColorChanged(var Message: TLMessage); message CM_PARENTCOLORCHANGED; procedure CMParentColorChanged(var Message: TLMessage); message CM_PARENTCOLORCHANGED;
// procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
{$ENDIF}
property ColorUnderCursor: TColor read GetColorUnderCursor; property ColorUnderCursor: TColor read GetColorUnderCursor;
property OnGetHintStr: TGetHintStrEvent read FOnGetHintStr write FOnGetHintStr; property OnGetHintStr: TGetHintStrEvent read FOnGetHintStr write FOnGetHintStr;
public public
@ -61,7 +41,6 @@ type
function GetColorAtPoint(X, Y: Integer): TColor; virtual; function GetColorAtPoint(X, Y: Integer): TColor; virtual;
function GetHexColorAtPoint(X, Y: integer): string; function GetHexColorAtPoint(X, Y: integer): string;
function GetHexColorUnderCursor: string; virtual; function GetHexColorUnderCursor: string; virtual;
// function GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; override;
published published
property ParentColor default true; property ParentColor default true;
end; end;
@ -72,22 +51,11 @@ uses
LCLIntf, LCLIntf,
HTMLColors, mbUtils; HTMLColors, mbUtils;
const
HINT_SHOW_DELAY = 50;
HINT_HIDE_DELAY = 3000;
constructor TmbBasicPicker.Create(AOwner: TComponent); constructor TmbBasicPicker.Create(AOwner: TComponent);
begin begin
inherited Create(AOwner); inherited Create(AOwner);
// ControlStyle := ControlStyle - [csOpaque]; // ControlStyle := ControlStyle - [csOpaque];
ParentColor := true; ParentColor := true;
{
FHintTimer := TTimer.Create(self);
FHintTimer.Interval := HINT_SHOW_DELAY;
FHintTimer.Enabled := false;
FHintTimer.OnTimer := @HintTimer;
FHintState := hsOff;
}
end; end;
destructor TmbBasicPicker.Destroy; destructor TmbBasicPicker.Destroy;
@ -152,22 +120,6 @@ begin
Result := GetColorAtPoint(P.X, P.Y); Result := GetColorAtPoint(P.X, P.Y);
end; end;
function TmbBasicPicker.GetHexColorAtPoint(X, Y: integer): string;
begin
Result := ColorToHex(GetColorAtPoint(x, y));
end;
function TmbBasicPicker.GetHexColorUnderCursor: string;
begin
Result := ColorToHex(GetColorUnderCursor);
end;
{
function TmbBasicPicker.GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor;
begin
result := inherited GetDefaultColor(DefaultColorType);
end; }
function TmbBasicPicker.GetGradientColor(AValue: Integer): TColor; function TmbBasicPicker.GetGradientColor(AValue: Integer): TColor;
begin begin
Result := clNone; Result := clNone;
@ -178,6 +130,16 @@ begin
Result := clNone; Result := clNone;
end; end;
function TmbBasicPicker.GetHexColorAtPoint(X, Y: integer): string;
begin
Result := ColorToHex(GetColorAtPoint(x, y));
end;
function TmbBasicPicker.GetHexColorUnderCursor: string;
begin
Result := ColorToHex(GetColorUnderCursor);
end;
function TmbBasicPicker.GetHintPos(X, Y: Integer): TPoint; function TmbBasicPicker.GetHintPos(X, Y: Integer): TPoint;
begin begin
Result := Point(X, Y); Result := Point(X, Y);
@ -190,58 +152,6 @@ begin
FOnGetHintStr(Self, X, Y, Result); FOnGetHintStr(Self, X, Y, Result);
end; end;
(*
function TmbBasicPicker.GetHintText: String;
begin
Result := Hint;
end;
procedure TmbBasicPicker.HideHintWindow;
begin
FHintTimer.Enabled := false;
FHintState := hsOff;
FreeAndNil(FHintWindow);
end;
procedure TmbBasicPicker.HintTimer(Sender: TObject);
begin
case FHintState of
hsWaitingToShow:
ShowHintWindow(Mouse.CursorPos, GetHintText);
hsWaitingToHide:
HideHintWindow;
end;
end;
*)
procedure TmbBasicPicker.MouseLeave;
begin
inherited;
{
HideHintWindow;
FHintTimer.Enabled := false;
FHintState := hsOff;
}
end;
procedure TmbBasicPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
{
if ShowHint and not FHintShown then
begin
if MouseOnPicker(X, Y) then
begin
FHintTimer.Enabled := false;
FHintState := hsWaitingToShow;
FHintTimer.Interval := HINT_SHOW_DELAY;
FHintTimer.Enabled := true;
end
else
HideHintWindow;
end;
}
end;
procedure TmbBasicPicker.PaintParentBack; procedure TmbBasicPicker.PaintParentBack;
begin begin
PaintParentBack(Canvas); PaintParentBack(Canvas);
@ -251,28 +161,13 @@ procedure TmbBasicPicker.PaintParentBack(ABitmap: TBitmap);
begin begin
ABitmap.Width := Width; ABitmap.Width := Width;
ABitmap.Height := Height; ABitmap.Height := Height;
{$IFNDEF DELPHI}
if Color = clDefault then begin if Color = clDefault then begin
ABitmap.Transparent := true; ABitmap.Transparent := true;
ABitmap.TransparentColor := clForm; ABitmap.TransparentColor := clForm;
ABitmap.Canvas.Brush.Color := clForm; //GetDefaultColor(dctBrush) ABitmap.Canvas.Brush.Color := clForm;
end else end else
{$ENDIF}
ABitmap.Canvas.Brush.Color := Color; ABitmap.Canvas.Brush.Color := Color;
ABitmap.Canvas.FillRect(ABitmap.Canvas.ClipRect); ABitmap.Canvas.FillRect(ABitmap.Canvas.ClipRect);
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
if ParentBackground then
with ThemeServices do
if ThemesEnabled then
begin
MemDC := CreateCompatibleDC(0);
OldBMP := SelectObject(MemDC, ABitmap.Handle);
DrawParentBackground(Handle, MemDC, nil, False);
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF}{$ENDIF}
end; end;
procedure TmbBasicPicker.PaintParentBack(ACanvas: TCanvas); procedure TmbBasicPicker.PaintParentBack(ACanvas: TCanvas);
@ -281,25 +176,6 @@ var
begin begin
R := Rect(0, 0, Width, Height); R := Rect(0, 0, Width, Height);
PaintParentBack(ACanvas, R); PaintParentBack(ACanvas, R);
(*
var
OffScreen: TBitmap;
begin
Offscreen := TBitmap.Create;
try
// Offscreen.PixelFormat := pf32bit;
if Color = clDefault then begin
Offscreen.Transparent := true;
Offscreen.TransparentColor := clForm; //GetDefaultColor(dctBrush);
end;
Offscreen.Width := Width;
Offscreen.Height := Height;
PaintParentBack(Offscreen);
ACanvas.Draw(0, 0, Offscreen);
finally
Offscreen.Free;
end;
*)
end; end;
procedure TmbBasicPicker.PaintParentBack(ACanvas: TCanvas; ARect: TRect); procedure TmbBasicPicker.PaintParentBack(ACanvas: TCanvas; ARect: TRect);
@ -308,10 +184,9 @@ var
begin begin
Offscreen := TBitmap.Create; Offscreen := TBitmap.Create;
try try
// Offscreen.PixelFormat := pf32bit;
if Color = clDefault then begin if Color = clDefault then begin
Offscreen.Transparent := true; Offscreen.Transparent := true;
Offscreen.TransparentColor := clForm; //GetDefaultColor(dctBrush); Offscreen.TransparentColor := clForm;
end; end;
Offscreen.Width := WidthOfRect(ARect); Offscreen.Width := WidthOfRect(ARect);
Offscreen.Height := HeightOfRect(ARect); Offscreen.Height := HeightOfRect(ARect);
@ -321,52 +196,6 @@ begin
Offscreen.Free; Offscreen.Free;
end; end;
end; end;
(*
// Build and show the hint window
function TmbBasicPicker.ShowHintWindow(APoint: TPoint; AText: String): Boolean;
const
MAXWIDTH = 400;
var
RScr, RHint, R: TRect;
begin
FHintTimer.Enabled := false;
if AText = '' then
begin
HideHintWindow;
exit(false);
end;
if FHintWindow = nil then
FHintWindow := THintWindow.Create(nil);
RScr := Screen.WorkAreaRect;
RHint := FHintWindow.CalcHintRect(MAXWIDTH, AText, nil);
OffsetRect(RHint, APoint.X, APoint.Y);
OffsetRect(RHint, 0, -(RHint.Bottom - RHint.Top));
R := RHint;
if R.Left < RScr.Left then
R := RHint;
RHint := R;
if (R.Bottom > RScr.Bottom) then begin
R := RHint;
OffsetRect(R, 0, R.Bottom - RScr.Bottom);
end;
FHintWindow.ActivateHint(R, AText);
FHintState := hsWaitingToHide;
FHintTimer.Interval := HINT_HIDE_DELAY;
FHintTimer.Enabled := true;
Result := true;
end;
*)
(* !!!!!!!!!!!!!!!!!
procedure TmbBasicPicker.WMEraseBkgnd(
var Message: {$IFDEF DELPHI}TWMEraseBkgnd{$ELSE}TLMEraseBkgnd{$ENDIF} );
begin
inherited;
// Message.Result := 1;
end; *)
end. end.

507
components/mbColorLib/mbColorList.pas
View File

@ -2,26 +2,14 @@ unit mbColorList;
interface interface
{$I mxs.inc} {$MODE DELPHI}
{$IFDEF FPC}{$MODE DELPHI}{$ENDIF}
uses uses
SysUtils, SysUtils, LCLIntf, LCLType, Classes, Controls, StdCtrls,
{$IFDEF FPC} Graphics, GraphUtil, Forms, Themes,
LCLIntf, LCLType, LMessages, HTMLColors, RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, PalUtils;
{$ELSE}
Windows, Messages,
{$ENDIF}
Classes, Controls, StdCtrls, Graphics,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} {$IFDEF DELPHI_6_UP}GraphUtil,{$ENDIF}
HTMLColors, RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, Forms,
PalUtils;
type type
{$IFNDEF DELPHI_6_UP}
TScrollDirection = (sdLeft, sdRight, sdUp, sdDown);
{$ENDIF}
TmbColor = record TmbColor = record
name: string; name: string;
value: TColor; value: TColor;
@ -43,35 +31,17 @@ type
Colors: array of TmbColor; Colors: array of TmbColor;
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
procedure UpdateColors; procedure UpdateColors;
procedure AddColor(Name: string; Value: TColor; refresh: boolean = true); procedure AddColor(AName: string; AValue: TColor; ARefresh: boolean = true);
procedure ClearColors; procedure ClearColors;
procedure DeleteColor(Index: integer; refresh: boolean = true);
procedure DeleteColorByName(Name: string; All: boolean);
procedure DeleteColorByValue(Value: TColor; All: boolean);
procedure InsertColor(Index: integer; Name: string; Value: TColor);
function ColorCount: integer; function ColorCount: integer;
procedure DeleteColor(AIndex: integer; ARefresh: boolean = true);
procedure DeleteColorByName(AName: string; All: boolean);
procedure DeleteColorByValue(Value: TColor; All: boolean);
procedure InsertColor(AIndex: integer; AName: string; AValue: TColor);
published published
{$IFDEF DELPHI}
property BevelKind default bkNone;
property BevelEdges;
property BevelInner;
property BevelOuter;
property Ctl3D;
property ImeMode;
property ImeName;
property ParentCtl3D;
property TabWidth;
{$ENDIF}
property ParentColor default False; property ParentColor default False;
property TabStop default True; property TabStop default True;
{$IFDEF DELPHI_7_UP}
{$IFDEF DELPHI}
property AutoComplete;
{$ENDIF}
property ScrollWidth;
{$ENDIF}
property Align; property Align;
property Anchors; property Anchors;
property BiDiMode; property BiDiMode;
@ -97,17 +67,9 @@ type
property Sorted; property Sorted;
property TabOrder; property TabOrder;
property Visible; property Visible;
property OnDrawCaption: TDrawCaptionEvent read FDraw write FDraw; property OnDrawCaption: TDrawCaptionEvent read FDraw write FDraw;
property OnGetHint: TGetHintEvent read FGetHint write FGetHint; property OnGetHint: TGetHintEvent read FGetHint write FGetHint;
property OnContextPopup; property OnContextPopup;
{$IFDEF DELPHI_7_UP}
{$IFDEF DELPHI}
property OnData;
property OnDataFind;
property OnDataObject;
{$ENDIF}
{$ENDIF}
property OnDblClick; property OnDblClick;
property OnDragDrop; property OnDragDrop;
property OnDragOver; property OnDragOver;
@ -129,49 +91,9 @@ type
implementation implementation
//taken from GraphUtil, only for Delphi 5
{$IFNDEF DELPHI_6_UP}
procedure DrawArrow(ACanvas: TCanvas; Direction: TScrollDirection;
Location: TPoint; Size: Integer);
const
ArrowPts: array[TScrollDirection, 0..2] of TPoint =
(((X:1; Y:0), (X:0; Y:1), (X:1; Y:2)),
((X:0; Y:0), (X:1; Y:1), (X:0; Y:2)),
((X:0; Y:1), (X:1; Y:0), (X:2; Y:1)),
((X:0; Y:0), (X:1; Y:1), (X:2; Y:0)));
var
I: Integer;
Pts: array[0..2] of TPoint;
OldWidth: Integer;
OldColor: TColor;
begin
if ACanvas = nil then exit;
OldColor := ACanvas.Brush.Color;
ACanvas.Brush.Color := ACanvas.Pen.Color;
Move(ArrowPts[Direction], Pts, SizeOf(Pts));
for I := 0 to 2 do
Pts[I] := Point(Pts[I].x * Size + Location.X, Pts[I].y * Size + Location.Y);
with ACanvas do
begin
OldWidth := Pen.Width;
Pen.Width := 1;
Polygon(Pts);
Pen.Width := OldWidth;
Brush.Color := OldColor;
end;
end;
{$ENDIF}
constructor TmbColorList.Create(AOwner: TComponent); constructor TmbColorList.Create(AOwner: TComponent);
begin begin
inherited; inherited;
{
MaxHue := 360;
MaxSat := 255;
MaxLum := 255;
}
style := lbOwnerDrawFixed; style := lbOwnerDrawFixed;
SetLength(Colors, 0); SetLength(Colors, 0);
ItemHeight := 48; ItemHeight := 48;
@ -180,223 +102,19 @@ begin
my := -1; my := -1;
end; end;
procedure TmbColorList.UpdateColors; procedure TmbColorList.AddColor(AName: string; AValue: TColor;
var ARefresh: boolean = true);
i: integer;
begin
Items.Clear;
for i := 0 to Length(Colors) - 1 do
Items.Add(Colors[i].name);
end;
procedure TmbColorList.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
SR, TR, R: TRect;
itemText: string;
begin
if Length(Colors) = 0 then Exit;
R := Rect;
with Canvas do
begin
//background
Pen.Color := clWindow;
if odSelected in State then
Brush.Color := clHighlight
else
Brush.Color := self.Color; //clBtnFace;
FillRect(R);
MoveTo(R.Left, R.Bottom - 1);
LineTo(R.Right, R.Bottom - 1);
//swatches
SR := Classes.Rect(R.Left + 6, R.Top + 6, R.Left + ItemHeight - 6, R.Top + ItemHeight - 6);
Brush.Color := Self.Colors[Index].value;
if odSelected in State then
begin
{$IFDEF DELPHI_7_UP}
if ThemeServices.ThemesEnabled then
begin
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
InflateRect(SR, -2, -2);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80);
FillRect(SR);
InflateRect(SR, -1, -1);
Brush.Color := Blend(self.Colors[Index].value, clBlack, 90);
FillRect(SR);
InflateRect(SR, -1, -1);
Brush.Color := Self.Colors[Index].value;
FillRect(SR);
end
else
//windows 9x
begin
{$ENDIF}
Pen.Color := clBackground;
Brush.Color := clWindow;
Rectangle(SR);
InflateRect(SR, -1, -1);
FillRect(SR);
InflateRect(SR, 1, 1);
InflateRect(SR, -2, -2);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 75);
FillRect(SR);
InflateRect(SR, -1, -1);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 87);
FillRect(SR);
InflateRect(SR, -1, -1);
Brush.Color := Self.Colors[Index].value;
FillRect(SR);
{$IFDEF DELPHI_7_UP}
end;
{$ENDIF}
end
else
//not selected
begin
//windows XP
{$IFDEF DELPHI_7_UP}
if ThemeServices.ThemesEnabled then
begin
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
InflateRect(SR, -2, -2);
Brush.Color := Self.Colors[Index].value;
FillRect(SR);
end
else
//windows 9x
begin
{$ENDIF}
DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT);
InflateRect(SR, -2, -2);
Brush.Color := Self.Colors[Index].value;
Pen.Color := clBlack;
Rectangle(SR);
InflateRect(SR, -1, -1);
FillRect(SR);
InflateRect(SR, 1, 1);
{$IFDEF DELPHI_7_UP}
end;
{$ENDIF}
end;
//names
Font.Style := [fsBold];
if odSelected in State then
begin
Brush.Color := clHighlight;
Pen.Color := clHighlightText;
Font.Color := clHighlightText;
end
else
begin
Brush.Color := clBtnFace;
Pen.Color := clWindowText;
Font.Color := clWindowText;
end;
itemText := Items.Strings[Index];
Canvas.Brush.Style := bsClear;
TR := Classes.Rect(R.Left + ItemHeight, R.Top + (ItemHeight - TextHeight(itemText)) div 2, R.Right, R.Bottom - (ItemHeight - TextHeight(itemText)) div 2);
if Assigned(FDraw) then FDraw(Self, Index, Canvas.Font, itemText, odSelected in State);
DrawText(Canvas.Handle, PChar(itemText), Length(itemText), TR, DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS);
end;
end;
procedure TmbColorList.AddColor(Name: string; Value: TColor; refresh: boolean = true);
var var
l: integer; l: integer;
begin begin
l := Length(Colors); l := Length(Colors);
SetLength(Colors, l + 1); SetLength(Colors, l + 1);
Colors[l].name := Name; Colors[l].name := AName;
Colors[l].value := Value; Colors[l].value := AValue;
if refresh then if ARefresh then
UpdateColors; UpdateColors;
end; end;
procedure TmbColorList.ClearColors;
begin
SetLength(Colors, 0);
UpdateColors;
end;
function TmbColorList.ColorCount: integer;
begin
Result := Length(Colors);
end;
procedure TmbColorList.DeleteColor(Index: integer; refresh: boolean = true);
var
i: integer;
begin
if Length(Colors) = 0 then
raise Exception.Create('There''s nothing to delete! The length of the array is 0.');
if Index > Length(Colors) - 1 then
raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
for i := Index to Length(Colors) - 2 do
Colors[i] := Colors[i+1];
SetLength(Colors, Length(Colors) - 1);
if refresh then
UpdateColors;
end;
procedure TmbColorList.DeleteColorByName(Name: string; All: boolean);
var
i: integer;
begin
for i := Length(Colors) - 1 downto 0 do
if SameText(Colors[i].name, Name) then
begin
DeleteColor(i, false);
if not All then
begin
UpdateColors;
Exit;
end;
end;
UpdateColors;
end;
procedure TmbColorList.DeleteColorByValue(Value: TColor; All: boolean);
var
i: integer;
begin
for i := Length(Colors) - 1 downto 0 do
if Colors[i].Value = Value then
begin
DeleteColor(i, false);
if not All then
begin
UpdateColors;
Exit;
end;
end;
UpdateColors;
end;
procedure TmbColorList.InsertColor(Index: integer; Name: string; Value: TColor);
var
i: integer;
begin
if Index > Length(Colors) - 1 then
raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
SetLength(Colors, Length(Colors) + 1);
for i := Length(Colors) - 1 downto Index do
Colors[i] := Colors[i-1];
Colors[Index].Name := Name;
Colors[Index].Value := Value;
UpdateColors;
end;
procedure TmbColorList.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
mx := x;
my := y;
end;
procedure TmbColorList.CMHintShow(var Message: TCMHintShow); procedure TmbColorList.CMHintShow(var Message: TCMHintShow);
var var
Handled: boolean; Handled: boolean;
@ -426,4 +144,201 @@ begin
inherited; inherited;
end; end;
procedure TmbColorList.ClearColors;
begin
SetLength(Colors, 0);
UpdateColors;
end;
function TmbColorList.ColorCount: integer;
begin
Result := Length(Colors);
end;
procedure TmbColorList.DeleteColor(AIndex: integer; ARefresh: boolean = true);
var
i: integer;
begin
if Length(Colors) = 0 then
raise Exception.Create('There''s nothing to delete! The length of the array is 0.');
if AIndex > Length(Colors) - 1 then
raise Exception.Create(Format('List index out of bounds (%d)', [AIndex]));
for i := AIndex to Length(Colors) - 2 do
Colors[i] := Colors[i+1];
SetLength(Colors, Length(Colors) - 1);
if ARefresh then
UpdateColors;
end;
procedure TmbColorList.DeleteColorByName(AName: string; All: boolean);
var
i: integer;
begin
for i := Length(Colors) - 1 downto 0 do
if SameText(Colors[i].name, AName) then
begin
DeleteColor(i, false);
if not All then
begin
UpdateColors;
Exit;
end;
end;
UpdateColors;
end;
procedure TmbColorList.DeleteColorByValue(Value: TColor; All: boolean);
var
i: integer;
begin
for i := Length(Colors) - 1 downto 0 do
if Colors[i].Value = Value then
begin
DeleteColor(i, false);
if not All then
begin
UpdateColors;
Exit;
end;
end;
UpdateColors;
end;
procedure TmbColorList.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
SR, TR, R: TRect;
itemText: string;
begin
if Length(Colors) = 0 then Exit;
R := Rect;
with Canvas do
begin
//background
Pen.Color := clWindow;
if odSelected in State then
Brush.Color := clHighlight
else
Brush.Color := self.Color; //clBtnFace;
FillRect(R);
MoveTo(R.Left, R.Bottom - 1);
LineTo(R.Right, R.Bottom - 1);
//swatches
SR := Classes.Rect(R.Left + 6, R.Top + 6, R.Left + ItemHeight - 6, R.Top + ItemHeight - 6);
Brush.Color := Self.Colors[Index].value;
if odSelected in State then
begin
if ThemeServices.ThemesEnabled then
begin
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
InflateRect(SR, -2, -2);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80);
FillRect(SR);
InflateRect(SR, -1, -1);
Brush.Color := Blend(self.Colors[Index].value, clBlack, 90);
FillRect(SR);
InflateRect(SR, -1, -1);
Brush.Color := Self.Colors[Index].value;
FillRect(SR);
end
else
//windows 9x
begin
Pen.Color := clBackground;
Brush.Color := clWindow;
Rectangle(SR);
InflateRect(SR, -1, -1);
FillRect(SR);
InflateRect(SR, 1, 1);
InflateRect(SR, -2, -2);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 75);
FillRect(SR);
InflateRect(SR, -1, -1);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 87);
FillRect(SR);
InflateRect(SR, -1, -1);
Brush.Color := Self.Colors[Index].value;
FillRect(SR);
end;
end
else
//not selected
begin
//windows XP
if ThemeServices.ThemesEnabled then
begin
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
InflateRect(SR, -2, -2);
Brush.Color := Self.Colors[Index].value;
FillRect(SR);
end
else
//windows 9x
begin
DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT);
InflateRect(SR, -2, -2);
Brush.Color := Self.Colors[Index].value;
Pen.Color := clBlack;
Rectangle(SR);
InflateRect(SR, -1, -1);
FillRect(SR);
InflateRect(SR, 1, 1);
end;
end;
//names
Font.Style := [fsBold];
if odSelected in State then
begin
Brush.Color := clHighlight;
Pen.Color := clHighlightText;
Font.Color := clHighlightText;
end
else
begin
Brush.Color := clBtnFace;
Pen.Color := clWindowText;
Font.Color := clWindowText;
end;
itemText := Items.Strings[Index];
Canvas.Brush.Style := bsClear;
TR := Classes.Rect(R.Left + ItemHeight, R.Top + (ItemHeight - TextHeight(itemText)) div 2, R.Right, R.Bottom - (ItemHeight - TextHeight(itemText)) div 2);
if Assigned(FDraw) then FDraw(Self, Index, Canvas.Font, itemText, odSelected in State);
DrawText(Canvas.Handle, PChar(itemText), Length(itemText), TR, DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS);
end;
end;
procedure TmbColorList.InsertColor(AIndex: integer; AName: string; AValue: TColor);
var
i: integer;
begin
if AIndex > Length(Colors) - 1 then
raise Exception.Create(Format('List index out of bounds (%d)', [AIndex]));
SetLength(Colors, Length(Colors) + 1);
for i := Length(Colors) - 1 downto AIndex do
Colors[i] := Colors[i-1];
Colors[AIndex].Name := AName;
Colors[AIndex].Value := AValue;
UpdateColors;
end;
procedure TmbColorList.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
mx := x;
my := y;
end;
procedure TmbColorList.UpdateColors;
var
i: integer;
begin
Items.Clear;
for i := 0 to Length(Colors) - 1 do
Items.Add(Colors[i].name);
end;
end. end.

1453
components/mbColorLib/mbColorPalette.pas
View File

File diff suppressed because it is too large Load Diff

104
components/mbColorLib/mbColorPickerControl.pas
View File

@ -1,21 +1,11 @@
unit mbColorPickerControl; unit mbColorPickerControl;
{$IFDEF FPC} {$MODE DELPHI}
{$MODE DELPHI}
{$ENDIF}
interface interface
{$I mxs.inc}
uses uses
{$IFDEF FPC} LCLIntf, LCLType, LMessages, SysUtils, Classes, Controls, Graphics, Forms, Themes,
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
{$IFDEF DELPHI_7_UP} Themes,{$ENDIF}
RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors, mbBasicPicker; RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors, mbBasicPicker;
type type
@ -36,18 +26,14 @@ type
mx, my, mdx, mdy: integer; mx, my, mdx, mdy: integer;
FOnChange: TNotifyEvent; FOnChange: TNotifyEvent;
procedure CreateGradient; override; procedure CreateGradient; override;
// function GetColorAtPoint(x, y: integer): TColor; override;
// function GetHintText: String; override;
function GetHintStr(X, Y: Integer): String; override; function GetHintStr(X, Y: Integer): String; override;
function GetSelectedColor: TColor; virtual; function GetSelectedColor: TColor; virtual;
procedure SetSelectedColor(C: TColor); virtual;
procedure InternalDrawMarker(X, Y: Integer; C: TColor); 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 MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CreateWnd; override; procedure SetSelectedColor(C: TColor); virtual;
procedure WebSafeChanged; dynamic; procedure WebSafeChanged; dynamic;
// 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;
procedure CMLostFocus(var Message: TCMLostFocus); message CM_EXIT; procedure CMLostFocus(var Message: TCMLostFocus); message CM_EXIT;
@ -118,11 +104,8 @@ constructor TmbCustomPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
//ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls]; //ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls];
DoubleBuffered := true;
TabStop := true; TabStop := true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF}{$ENDIF}
mx := 0; mx := 0;
my := 0; my := 0;
mdx := 0; mdx := 0;
@ -131,11 +114,6 @@ begin
FWebSafe := false; FWebSafe := false;
end; end;
procedure TmbCustomPicker.CreateWnd;
begin
inherited;
end;
procedure TmbCustomPicker.CMGotFocus( procedure TmbCustomPicker.CMGotFocus(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF} ); var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF} );
begin begin
@ -160,14 +138,11 @@ end;
procedure TmbCustomPicker.CreateGradient; procedure TmbCustomPicker.CreateGradient;
var var
// x, y, skip: integer;
x, y: Integer; x, y: Integer;
row: pRGBQuadArray; row: pRGBQuadArray;
c: TColor; c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage; intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap; imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin begin
if FBufferBmp = nil then if FBufferBmp = nil then
begin begin
@ -177,20 +152,13 @@ begin
FBufferBmp.Width := FGradientWidth; FBufferBmp.Width := FGradientWidth;
FBufferBmp.Height := FGradientHeight; FBufferBmp.Height := FGradientHeight;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(FBufferBmp.Width, FBufferBmp.Height); intfimg := TLazIntfImage.Create(FBufferBmp.Width, FBufferBmp.Height);
try try
intfImg.LoadFromBitmap(FBufferBmp.Handle, FBufferBmp.MaskHandle); intfImg.LoadFromBitmap(FBufferBmp.Handle, FBufferBmp.MaskHandle);
{$ENDIF}
for y := 0 to FBufferBmp.Height - 1 do for y := 0 to FBufferBmp.Height - 1 do
begin begin
{$IFDEF FPC}
row := intfImg.GetDataLineStart(y); //FBufferBmp.Height - 1 - y); row := intfImg.GetDataLineStart(y); //FBufferBmp.Height - 1 - y);
{$ELSE}
row := FHSVBmp.Scanline(y); //FGradientBmp.Height - 1 - y);
{$ENDIF}
for x := 0 to FBufferBmp.Width - 1 do for x := 0 to FBufferBmp.Width - 1 do
begin begin
c := GetGradientColor2D(x, y); c := GetGradientColor2D(x, y);
@ -200,32 +168,24 @@ begin
end; end;
end; end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false); intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBufferBmp.Handle := imgHandle; FBufferBmp.Handle := imgHandle;
FBufferBmp.MaskHandle := imgMaskHandle; FBufferBmp.MaskHandle := imgMaskHandle;
finally finally
intfimg.Free; intfimg.Free;
end; end;
{$ENDIF}
end; end;
(*
function TmbCustomPicker.GetHintText: String; function TmbCustomPicker.GetHintStr(X, Y: Integer): String;
begin begin
Result := FormatHint(FHintFormat, GetColorUnderCursor) Result := FormatHint(FHintFormat, GetColorUnderCursor);
end; *) end;
function TmbCustomPicker.GetSelectedColor: TColor; function TmbCustomPicker.GetSelectedColor: TColor;
begin begin
Result := FSelected; // valid for most descendents Result := FSelected; // valid for most descendents
end; end;
procedure TmbCustomPicker.SetSelectedColor(C: TColor);
begin
FSelected := C;
//handled in descendents
end;
procedure TmbCustomPicker.InternalDrawMarker(X, Y: Integer; C: TColor); procedure TmbCustomPicker.InternalDrawMarker(X, Y: Integer; C: TColor);
begin begin
case MarkerStyle of case MarkerStyle of
@ -236,49 +196,15 @@ begin
end; end;
end; end;
function TmbCustomPicker.GetHintStr(X, Y: Integer): String; procedure TmbCustomPicker.MouseDown(Button: TMouseButton; Shift: TShiftState;
begin X, Y: Integer);
Result := FormatHint(FHintFormat, GetColorUnderCursor);
end;
(*
procedure TmbCustomPicker.CMHintShow(var Message: TCMHintShow);
var
cp: TPoint;
begin
if GetColorUnderCursor <> clNone then
with TCMHintShow(Message) do
if not ShowHint then
Message.Result := 1
else
begin
cp := HintInfo^.CursorPos;
HintInfo^.ReshowTimeout := 0; // was: 1
HintInfo^.HideTimeout := Application.HintHidePause; // was: 5000
HintInfo^.HintStr := FormatHint(FHintFormat, GetColorUnderCursor);
HintInfo^.CursorRect := Rect(cp.X, cp.Y, cp.X+1, cp.Y+1);
Result := 0; // 0 means: show hint
end;
{
with HintInfo^ do
begin
Result := 0;
ReshowTimeout := 1;
HideTimeout := 5000;
HintStr := FormatHint(FHintFormat, GetColorUnderCursor);;
end; }
inherited;
end;
*)
procedure TmbCustomPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
mx := x; mx := x;
my := y; my := y;
end; end;
procedure TmbCustomPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; procedure TmbCustomPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
X, Y: Integer);
begin begin
inherited; inherited;
mx := x; mx := x;
@ -302,6 +228,12 @@ begin
end; end;
end; end;
procedure TmbCustomPicker.SetSelectedColor(C: TColor);
begin
FSelected := C;
//handled in descendents
end;
procedure TmbCustomPicker.SetWebSafe(s: boolean); procedure TmbCustomPicker.SetWebSafe(s: boolean);
begin begin
if FWebSafe <> s then if FWebSafe <> s then

42
components/mbColorLib/mbColorPreview.pas
View File

@ -1,18 +1,11 @@
unit mbColorPreview; unit mbColorPreview;
{$IFDEF FPC} {$MODE DELPHI}
{$MODE DELPHI}
{$ENDIF}
interface interface
uses uses
{$IFDEF FPC} LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics;
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics;
type type
TmbColorPreview = class(TCustomControl) TmbColorPreview = class(TCustomControl)
@ -23,22 +16,19 @@ type
FOnOpacityChange: TNotifyEvent; FOnOpacityChange: TNotifyEvent;
FBlockSize: integer; FBlockSize: integer;
FSwatchStyle: boolean; FSwatchStyle: boolean;
function MakeBmp: TBitmap;
procedure SetSwatchStyle(Value: boolean); procedure SetSwatchStyle(Value: boolean);
procedure SetSelColor(c: TColor); procedure SetSelColor(c: TColor);
procedure SetOpacity(o: integer); procedure SetOpacity(o: integer);
procedure SetBlockSize(s: integer); procedure SetBlockSize(s: integer);
function MakeBmp: TBitmap;
protected protected
procedure Paint; override; procedure Paint; override;
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
published published
property BlockSize: integer read FBlockSize write SetBlockSize default 6;
property Color: TColor read FSelColor write SetSelColor default clWhite; property Color: TColor read FSelColor write SetSelColor default clWhite;
property Opacity: integer read FOpacity write SetOpacity default 100; property Opacity: integer read FOpacity write SetOpacity default 100;
property BlockSize: integer read FBlockSize write SetBlockSize default 6;
property SwatchStyle: boolean read FSwatchStyle write SetSwatchStyle default false; property SwatchStyle: boolean read FSwatchStyle write SetSwatchStyle default false;
property Anchors; property Anchors;
property Align; property Align;
@ -81,8 +71,8 @@ uses
constructor TmbColorPreview.Create(AOwner: TComponent); constructor TmbColorPreview.Create(AOwner: TComponent);
begin begin
inherited; inherited;
DoubleBuffered := true; //ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];
ControlStyle := COntrolStyle - [csAcceptsControls] + [csOpaque];
FSelColor := clWhite; FSelColor := clWhite;
SetInitialBounds(0, 0, 68, 32); SetInitialBounds(0, 0, 68, 32);
TabStop := false; TabStop := false;
@ -194,19 +184,12 @@ begin
end; end;
end; end;
procedure TmbColorPreview.WMEraseBkgnd( procedure TmbColorPreview.SetBlockSize(s: integer);
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
begin begin
Message.Result := 1; if (FBlockSize <> s) and (s > 0) then
end;
procedure TmbColorPreview.SetSelColor(c: TColor);
begin
if c <> FSelColor then
begin begin
FSelColor := c; FBlockSize := s;
Invalidate; Invalidate;
if Assigned(FOnColorChange) then FOnColorChange(Self);
end; end;
end; end;
@ -220,12 +203,13 @@ begin
end; end;
end; end;
procedure TmbColorPreview.SetBlockSize(s: integer); procedure TmbColorPreview.SetSelColor(c: TColor);
begin begin
if (FBlockSize <> s) and (s > 0) then if c <> FSelColor then
begin begin
FBlockSize := s; FSelColor := c;
Invalidate; Invalidate;
if Assigned(FOnColorChange) then FOnColorChange(Self);
end; end;
end; end;

414
components/mbColorLib/mbColorTree.pas
View File

@ -1,29 +1,15 @@
unit mbColorTree; unit mbColorTree;
{$IFDEF FPC} {$MODE DELPHI}
{$MODE DELPHI}
{$ENDIF}
interface interface
{$I mxs.inc}
uses uses
{$IFDEF FPC} LCLIntf, LCLType, SysUtils, Classes, Controls, ComCtrls, Graphics, Themes,
LCLIntf, LCLType, GraphUtil, ImgList, Forms,
{$ELSE} HTMLColors, RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils;
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, ComCtrls, Graphics,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} {$IFDEF DELPHI_6_UP}GraphUtil,{$ENDIF}
ImgList, HTMLColors, RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils,
Forms;
type type
{$IFNDEF DELPHI_6_UP}
TScrollDirection = (sdLeft, sdRight, sdUp, sdDown);
{$ENDIF}
TmbColor = record TmbColor = record
Name: string; Name: string;
Value: TColor; Value: TColor;
@ -46,30 +32,28 @@ type
procedure SetInfo1(Value: string); procedure SetInfo1(Value: string);
procedure SetInfo2(Value: string); procedure SetInfo2(Value: string);
procedure SetInfoLabel(Value: string); procedure SetInfoLabel(Value: string);
protected protected
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
function CustomDrawItem(Node: TTreeNode; State: TCustomDrawState; function CustomDrawItem(Node: TTreeNode; State: TCustomDrawState;
Stage: TCustomDrawStage; var PaintImages: Boolean): Boolean; override; Stage: TCustomDrawStage; var PaintImages: Boolean): Boolean; override;
function IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean; {$IFDEF DELPHI_7_UP}override;{$ENDIF}
procedure DrawColorItem(R: TRect; Selected: boolean; Index: integer; itemText: string; Expanded: boolean); dynamic;
procedure DrawInfoItem(R: TRect; Index: integer); dynamic;
procedure DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean); procedure DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean);
procedure DrawColorItem(R: TRect; Selected: boolean; AIndex: Integer;
AItemText: String; Expanded: boolean); dynamic;
procedure DrawInfoItem(R: TRect; Index: integer); dynamic;
function IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
public public
Colors: array of TmbColor; Colors: array of TmbColor;
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
procedure UpdateColors;
procedure AddColor(AName: string; AValue: TColor; ARefresh: boolean = true); procedure AddColor(AName: string; AValue: TColor; ARefresh: boolean = true);
procedure ClearColors; procedure ClearColors;
function ColorCount: integer;
procedure DeleteColor(AIndex: integer; ARefresh: boolean = true); procedure DeleteColor(AIndex: integer; ARefresh: boolean = true);
procedure DeleteColorByName(AName: string; All: boolean); procedure DeleteColorByName(AName: string; All: boolean);
procedure DeleteColorByValue(AValue: TColor; All: boolean); procedure DeleteColorByValue(AValue: TColor; All: boolean);
procedure InsertColor(AIndex: integer; AName: string; AValue: TColor); procedure InsertColor(AIndex: integer; AName: string; AValue: TColor);
function ColorCount: integer; procedure UpdateColors;
published published
property InfoLabelText: string read FInfoLabel write SetInfoLabel; property InfoLabelText: string read FInfoLabel write SetInfoLabel;
property InfoDisplay1: string read FInfo1 write SetInfo1; property InfoDisplay1: string read FInfo1 write SetInfo1;
@ -77,20 +61,8 @@ type
property Align; property Align;
property Anchors; property Anchors;
property AutoExpand; property AutoExpand;
{$IFDEF DELPHI}
property BevelEdges;
property BevelInner;
property BevelOuter;
property BevelKind default bkNone;
property BevelWidth;
{$ENDIF}
property BorderStyle; property BorderStyle;
property BorderWidth; property BorderWidth;
{$IFDEF DELPHI}
property ChangeDelay;
property Ctl3D;
property ParentCtl3D;
{$ENDIF}
property Constraints; property Constraints;
property Color; property Color;
property DragKind; property DragKind;
@ -99,10 +71,6 @@ type
property Enabled; property Enabled;
property Font; property Font;
property Indent; property Indent;
{$IFDEF DELPHI_7_UP}
property MultiSelect;
property MultiSelectStyle;
{$ENDIF}
property ParentColor default False; property ParentColor default False;
property ParentFont; property ParentFont;
property ParentShowHint; property ParentShowHint;
@ -119,10 +87,6 @@ type
property OnDrawInfoLabel: TDrawLabelEvent read FDraw1 write FDraw1; property OnDrawInfoLabel: TDrawLabelEvent read FDraw1 write FDraw1;
property OnDrawInfoDisplay1: TDrawLabelEvent read FDraw2 write FDraw2; property OnDrawInfoDisplay1: TDrawLabelEvent read FDraw2 write FDraw2;
property OnDrawInfoDisplay2: TDrawLabelEvent read FDraw3 write FDraw3; property OnDrawInfoDisplay2: TDrawLabelEvent read FDraw3 write FDraw3;
{$IFDEF DELPHI_7_UP}
property OnAddition;
property OnCreateNodeClass;
{$ENDIF}
property OnAdvancedCustomDraw; property OnAdvancedCustomDraw;
property OnAdvancedCustomDrawItem; property OnAdvancedCustomDrawItem;
property OnChange; property OnChange;
@ -160,52 +124,12 @@ implementation
uses uses
PalUtils, mbUtils; PalUtils, mbUtils;
//taken from GraphUtil, only for Delphi 5
{$IFNDEF DELPHI_6_UP}
procedure DrawArrow(ACanvas: TCanvas; Direction: TScrollDirection;
Location: TPoint; Size: Integer);
const
ArrowPts: array[TScrollDirection, 0..2] of TPoint =
(((X:1; Y:0), (X:0; Y:1), (X:1; Y:2)),
((X:0; Y:0), (X:1; Y:1), (X:0; Y:2)),
((X:0; Y:1), (X:1; Y:0), (X:2; Y:1)),
((X:0; Y:0), (X:1; Y:1), (X:2; Y:0)));
var
I: Integer;
Pts: array[0..2] of TPoint;
OldWidth: Integer;
OldColor: TColor;
begin
if ACanvas = nil then exit;
OldColor := ACanvas.Brush.Color;
ACanvas.Brush.Color := ACanvas.Pen.Color;
Move(ArrowPts[Direction], Pts, SizeOf(Pts));
for I := 0 to 2 do
Pts[I] := Point(Pts[I].x * Size + Location.X, Pts[I].y * Size + Location.Y);
with ACanvas do
begin
OldWidth := Pen.Width;
Pen.Width := 1;
Polygon(Pts);
Pen.Width := OldWidth;
Brush.Color := OldColor;
end;
end;
{$ENDIF}
{ TmbColorTree } { TmbColorTree }
constructor TmbColorTree.Create(AOwner: TComponent); constructor TmbColorTree.Create(AOwner: TComponent);
begin begin
inherited; inherited;
ControlStyle := ControlStyle + [csDisplayDragImage]; ControlStyle := ControlStyle + [csDisplayDragImage];
{
MaxHue := 360;
MaxSat := 255;
MaxLum := 255;
}
ReadOnly := true; ReadOnly := true;
ShowButtons := false; ShowButtons := false;
ShowLines := false; ShowLines := false;
@ -221,64 +145,65 @@ begin
FInfo2 := 'HEX: #%hex'; FInfo2 := 'HEX: #%hex';
end; end;
procedure TmbColorTree.UpdateColors; procedure TmbColorTree.AddColor(AName: string; AValue: TColor;
ARefresh: boolean = true);
var var
L: integer;
begin
L := Length(Colors);
SetLength(Colors, L + 1);
Colors[L].Name := AName;
Colors[L].Value := AValue;
if ARefresh then
UpdateColors;
end;
procedure TmbColorTree.ClearColors;
begin
SetLength(Colors, 0);
UpdateColors;
end;
procedure TmbColorTree.CMHintShow(var Message: TCMHintShow);
var
Handled: boolean;
i: integer; i: integer;
n: TTreeNode; n: TTreeNode;
begin begin
Items.Clear; if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then
for i := 0 to Length(Colors) - 1 do
begin begin
n := Items.Add(TopItem, Colors[i].name); n := GetNodeAt(mx, my);
Items.AddChild(n, ''); if n <> nil then
end;
end;
procedure TmbColorTree.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
r: TRect;
begin
inherited;
if (ssShift in Shift) or (ssCtrl in Shift) then Exit;
if Selected <> nil then
r := Selected.DisplayRect(false)
else
exit;
if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then
if (Selected.HasChildren) and PtInRect(r, Point(x, y)) then
begin begin
if selected.Expanded then if not n.HasChildren then
Selected.Collapse(false) i := n.Parent.Index
else else
Selected.Expand(false); i := n.Index;
Invalidate; with TCMHintShow(Message) do
if not ShowHint then
Message.Result := 1
else
with HintInfo^ do
begin
Result := 0;
ReshowTimeout := 2000;
HideTimeout := 1000;
Handled := false;
if Assigned(FGetHint) then
FGetHint(i, HintStr, Handled);
if Handled then
HintStr := FormatHint(HintStr, Colors[i].Value)
else
HintStr := Colors[i].Name;
end;
end; end;
end;
inherited;
end; end;
procedure TmbColorTree.MouseMove(Shift: TShiftState; X, Y: Integer); function TmbColorTree.ColorCount: integer;
var
r: TRect;
begin begin
inherited; Result := Length(Colors);
mx := x;
my := y;
if GetNodeAt(x, y) <> nil then
r := GetNodeAt(x, y).DisplayRect(false)
else
begin
Cursor := crDefault;
exit;
end;
if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then
begin
if (GetNodeAt(x, y).HasChildren) and PtInRect(r, Point(x, y)) then
Cursor := crHandPoint
else
Cursor := crDefault;
end
else
Cursor := crDefault;
end; end;
function TmbColorTree.CustomDrawItem(Node: TTreeNode; State: TCustomDrawState; function TmbColorTree.CustomDrawItem(Node: TTreeNode; State: TCustomDrawState;
@ -292,6 +217,23 @@ begin
DrawInfoItem(Node.DisplayRect(false), node.Parent.Index); DrawInfoItem(Node.DisplayRect(false), node.Parent.Index);
end; end;
procedure TmbColorTree.DeleteColorByValue(AValue: TColor; All: boolean);
var
i: integer;
begin
for i := Length(Colors) - 1 downto 0 do
if Colors[i].Value = AValue then
begin
DeleteColor(i, false);
if not All then
begin
UpdateColors;
Exit;
end;
end;
UpdateColors;
end;
procedure TmbColorTree.DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; procedure TmbColorTree.DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint;
sel: boolean); sel: boolean);
var var
@ -324,8 +266,10 @@ begin
end; end;
end; end;
procedure TmbColorTree.DrawColorItem(R: TRect; Selected: boolean; Index: integer; procedure TmbColorTree.DrawColorItem(R: TRect; Selected: boolean; AIndex: integer;
itemText: string; Expanded: boolean); AItemText: string; Expanded: boolean);
const
FLAGS = DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS;
var var
SR, TR: TRect; SR, TR: TRect;
begin begin
@ -343,27 +287,26 @@ begin
//swatches //swatches
SR := Rect(R.Left + 6, R.Top + 6, R.Left + 42, R.Top + 42); SR := Rect(R.Left + 6, R.Top + 6, R.Left + 42, R.Top + 42);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[AIndex].value;
if Selected then if Selected then
begin begin
{$IFDEF DELPHI_7_UP}
if ThemeServices.ThemesEnabled then if ThemeServices.ThemesEnabled then
begin begin
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR); ThemeServices.DrawElement(Canvas.Handle,
ThemeServices.GetElementDetails(teEditTextNormal), SR);
InflateRect(SR, -2, -2); InflateRect(SR, -2, -2);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80); Brush.Color := Blend(Self.Colors[AIndex].value, clBlack, 80);
FillRect(SR); FillRect(SR);
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 90); Brush.Color := Blend(Self.Colors[AIndex].value, clBlack, 90);
FillRect(SR); FillRect(SR);
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[AIndex].value;
FillRect(SR); FillRect(SR);
end end
else else
//windows 9x //windows 9x
begin begin
{$ENDIF}
Pen.Color := clBackground; Pen.Color := clBackground;
Brush.Color := clWindow; Brush.Color := clWindow;
Rectangle(SR); Rectangle(SR);
@ -371,45 +314,39 @@ begin
FillRect(SR); FillRect(SR);
InflateRect(SR, 1, 1); InflateRect(SR, 1, 1);
InflateRect(SR, -2, -2); InflateRect(SR, -2, -2);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 75); Brush.Color := Blend(Self.Colors[AIndex].value, clBlack, 75);
FillRect(SR); FillRect(SR);
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 87); Brush.Color := Blend(Self.Colors[AIndex].value, clBlack, 87);
FillRect(SR); FillRect(SR);
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[AIndex].value;
FillRect(SR); FillRect(SR);
{$IFDEF DELPHI_7_UP}
end; end;
{$ENDIF}
end end
else else
//not selected //not selected
begin begin
//windows XP //windows XP
{$IFDEF DELPHI_7_UP}
if ThemeServices.ThemesEnabled then if ThemeServices.ThemesEnabled then
begin begin
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR); ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
InflateRect(SR, -2, -2); InflateRect(SR, -2, -2);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[AIndex].value;
FillRect(SR); FillRect(SR);
end end
else else
//windows 9x //windows 9x
begin begin
{$ENDIF}
DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT); DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT);
InflateRect(SR, -2, -2); InflateRect(SR, -2, -2);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[AIndex].value;
Pen.Color := clBlack; Pen.Color := clBlack;
Rectangle(SR); Rectangle(SR);
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
FillRect(SR); FillRect(SR);
InflateRect(SR, 1, 1); InflateRect(SR, 1, 1);
{$IFDEF DELPHI_7_UP}
end; end;
{$ENDIF}
end; end;
//names //names
Font.Style := [fsBold]; Font.Style := [fsBold];
@ -425,10 +362,10 @@ begin
Pen.Color := clWindowText; Pen.Color := clWindowText;
Font.Color := clWindowText; Font.Color := clWindowText;
end; end;
TR := Rect(R.Left + 48, R.Top + (48 - TextHeight(itemText)) div 2, R.Right - 15, R.Bottom); TR := Rect(R.Left + 48, R.Top + (48 - TextHeight(AItemText)) div 2, R.Right - 15, R.Bottom);
if Assigned(FDraw) then FDraw(Self, Index, Canvas.Font, itemText, Selected); if Assigned(FDraw) then FDraw(Self, AIndex, Canvas.Font, AItemText, Selected);
SetBkMode(Canvas.Handle, TRANSPARENT); SetBkMode(Canvas.Handle, TRANSPARENT);
DrawText(Canvas.Handle, PChar(itemText), Length(itemText), TR, DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS); DrawText(Canvas.Handle, PChar(AItemText), Length(AItemText), TR, FLAGS);
SetBkMode(Canvas.Handle, OPAQUE); SetBkMode(Canvas.Handle, OPAQUE);
if R.Right > 60 then if R.Right > 60 then
begin begin
@ -496,11 +433,78 @@ begin
end; end;
end; end;
function TmbColorTree.IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean; procedure TmbColorTree.InsertColor(AIndex: integer; AName: string; AValue: TColor);
var
i: integer;
begin
if AIndex > Length(Colors) - 1 then
raise Exception.Create(Format('List index out of bounds (%d)', [AIndex]));
SetLength(Colors, Length(Colors) + 1);
for i := Length(Colors) - 1 downto AIndex do
Colors[i] := Colors[i-1];
Colors[AIndex].Name := AName;
Colors[AIndex].Value := AValue;
UpdateColors;
end;
function TmbColorTree.IsCustomDrawn(Target: TCustomDrawTarget;
Stage: TCustomDrawStage): Boolean;
begin begin
Result := true; Result := true;
end; end;
procedure TmbColorTree.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
r: TRect;
begin
inherited;
if (ssShift in Shift) or (ssCtrl in Shift) then
Exit;
if Selected <> nil then
r := Selected.DisplayRect(false)
else
exit;
if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then
if (Selected.HasChildren) and PtInRect(r, Point(x, y)) then
begin
if selected.Expanded then
Selected.Collapse(false)
else
Selected.Expand(false);
Invalidate;
end;
end;
procedure TmbColorTree.MouseMove(Shift: TShiftState; X, Y: Integer);
var
r: TRect;
begin
inherited;
mx := x;
my := y;
if GetNodeAt(x, y) <> nil then
r := GetNodeAt(x, y).DisplayRect(false)
else
begin
Cursor := crDefault;
exit;
end;
if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then
begin
if (GetNodeAt(x, y).HasChildren) and PtInRect(r, Point(x, y)) then
Cursor := crHandPoint
else
Cursor := crDefault;
end
else
Cursor := crDefault;
end;
procedure TmbColorTree.SetInfoLabel(Value: string); procedure TmbColorTree.SetInfoLabel(Value: string);
begin begin
if FInfoLabel <> Value then if FInfoLabel <> Value then
@ -528,30 +532,6 @@ begin
end; end;
end; end;
procedure TmbColorTree.AddColor(AName: string; AValue: TColor;
ARefresh: boolean = true);
var
L: integer;
begin
L := Length(Colors);
SetLength(Colors, L + 1);
Colors[L].Name := AName;
Colors[L].Value := AValue;
if ARefresh then
UpdateColors;
end;
procedure TmbColorTree.ClearColors;
begin
SetLength(Colors, 0);
UpdateColors;
end;
function TmbColorTree.ColorCount: integer;
begin
Result := Length(Colors);
end;
procedure TmbColorTree.DeleteColor(AIndex: integer; ARefresh: boolean = true); procedure TmbColorTree.DeleteColor(AIndex: integer; ARefresh: boolean = true);
var var
i: integer; i: integer;
@ -586,75 +566,17 @@ begin
UpdateColors; UpdateColors;
end; end;
procedure TmbColorTree.DeleteColorByValue(AValue: TColor; All: boolean); procedure TmbColorTree.UpdateColors;
var var
i: integer; i: integer;
begin
for i := Length(Colors) - 1 downto 0 do
if Colors[i].Value = AValue then
begin
DeleteColor(i, false);
if not All then
begin
UpdateColors;
Exit;
end;
end;
UpdateColors;
end;
procedure TmbColorTree.InsertColor(AIndex: integer; AName: string; AValue: TColor);
var
i: integer;
begin
if AIndex > Length(Colors) - 1 then
raise Exception.Create(Format('List index out of bounds (%d)', [AIndex]));
SetLength(Colors, Length(Colors) + 1);
for i := Length(Colors) - 1 downto AIndex do
Colors[i] := Colors[i-1];
Colors[AIndex].Name := AName;
Colors[AIndex].Value := AValue;
UpdateColors;
end;
procedure TmbColorTree.CMHintShow(var Message: TCMHintShow);
var
Handled: boolean;
i: integer;
n: TTreeNode; n: TTreeNode;
begin begin
if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then Items.Clear;
for i := 0 to Length(Colors) - 1 do
begin begin
n := GetNodeAt(mx, my); n := Items.Add(TopItem, Colors[i].name);
if n <> nil then Items.AddChild(n, '');
begin
if not n.HasChildren then
i := n.Parent.Index
else
i := n.Index;
with TCMHintShow(Message) do
if not ShowHint then
Message.Result := 1
else
with HintInfo^ do
begin
Result := 0;
ReshowTimeout := 2000;
HideTimeout := 1000;
Handled := false;
if Assigned(FGetHint) then
FGetHint(i, HintStr, Handled);
if Handled then
HintStr := FormatHint(HintStr, Colors[i].Value)
else
HintStr := Colors[i].Name;
end;
end;
end; end;
inherited;
end; end;
end. end.

107
components/mbColorLib/mbDeskPickerButton.pas
View File

@ -1,46 +1,41 @@
unit mbDeskPickerButton; unit mbDeskPickerButton;
{$IFDEF FPC} {$MODE DELPHI}
{$MODE DELPHI}
{$ENDIF}
interface interface
uses uses
{$IFDEF FPC} LCLIntf, LCLType, SysUtils, Classes, Controls, StdCtrls, Graphics, Forms, ScreenWin;
LCLIntf, LCLType,
{$ELSE}
Windows,
{$ENDIF}
SysUtils, Classes, Controls, StdCtrls, Graphics, Forms, ScreenWin;
type type
TmbDeskPickerButton = class(TButton) TmbDeskPickerButton = class(TButton)
private private
FSelColor: TColor; FHintFmt: string;
ScreenFrm: TScreenForm; FSelColor: TColor;
FOnColorPicked: TNotifyEvent; FScreenFrm: TScreenForm;
FOnKeyDown: TKeyEvent; FShowScreenHint: boolean;
FHintFmt: string; FOnWheelUp, FOnWheelDown: TMouseWheelUpDownEvent;
FShowScreenHint: boolean; FOnColorPicked: TNotifyEvent;
OnWUp, OnWDown: TMouseWheelUpDownEvent; FOnKeyDown: TKeyEvent;
protected protected
procedure StartPicking; procedure ColorPicked(Sender: TObject);
procedure ColorPicked(Sender: TObject); procedure ScreenKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure ScreenKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure StartPicking;
procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint;
procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); var Handled: Boolean);
procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint;
var Handled: Boolean);
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
procedure Click; override; procedure Click; override;
property SelectedColor: TColor read FSelColor; property SelectedColor: TColor read FSelColor;
published published
property OnSelColorChange: TNotifyEvent read FOnColorPicked write FOnColorPicked; property ScreenHintFormat: string read FHintFmt write FHintFmt;
property OnScreenKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown; property ShowScreenHint: boolean read FShowScreenHint write FShowScreenHint default false;
property OnSelMouseWheelUp: TMouseWheelUpDownEvent read OnWUp write OnWUp; property OnScreenKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;
property OnSelMouseWheelDown: TMouseWheelUpDownEvent read OnWDown write OnWDown; property OnSelColorChange: TNotifyEvent read FOnColorPicked write FOnColorPicked;
property ScreenHintFormat: string read FHintFmt write FHintFmt; property OnSelMouseWheelDown: TMouseWheelUpDownEvent read FOnWheelDown write FOnWheelDown;
property ShowScreenHint: boolean read FShowScreenHint write FShowScreenHint default false; property OnSelMouseWheelUp: TMouseWheelUpDownEvent read FOnWheelUp write FOnWheelUp;
end; end;
@ -61,41 +56,47 @@ begin
StartPicking; StartPicking;
end; end;
procedure TmbDeskPickerButton.StartPicking;
begin
ScreenFrm := TScreenForm.Create(Application);
try
ScreenFrm.OnSelColorChange := ColorPicked;
ScreenFrm.OnScreenKeyDown := ScreenKeyDown;
ScreenFrm.OnMouseWheelDown := WheelDown;
ScreenFrm.OnMouseWheelUp := WheelUp;
ScreenFrm.ShowHint := FShowScreenHint;
ScreenFrm.FHintFormat := FHintFmt;
ScreenFrm.ShowModal;
finally
ScreenFrm.Free;
end;
end;
procedure TmbDeskPickerButton.ColorPicked(Sender: TObject); procedure TmbDeskPickerButton.ColorPicked(Sender: TObject);
begin begin
FSelColor := ScreenFrm.SelectedColor; FSelColor := FScreenFrm.SelectedColor;
if Assigned(FOnColorPicked) then FOnColorPicked(Self); if Assigned(FOnColorPicked) then
FOnColorPicked(Self);
end;
procedure TmbDeskPickerButton.StartPicking;
begin
FScreenFrm := TScreenForm.Create(Application);
try
FScreenFrm.OnSelColorChange := ColorPicked;
FScreenFrm.OnScreenKeyDown := ScreenKeyDown;
FScreenFrm.OnMouseWheelDown := WheelDown;
FScreenFrm.OnMouseWheelUp := WheelUp;
FScreenFrm.ShowHint := FShowScreenHint;
FScreenFrm.FHintFormat := FHintFmt;
FScreenFrm.ShowModal;
finally
FScreenFrm.Free;
end;
end; end;
procedure TmbDeskPickerButton.ScreenKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure TmbDeskPickerButton.ScreenKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin begin
if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift); if Assigned(FOnKeyDown) then
FOnKeyDown(Self, Key, Shift);
end; end;
procedure TmbDeskPickerButton.WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure TmbDeskPickerButton.WheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin begin
if Assigned(OnWUp) then OnWUp(Self, Shift, MousePos, Handled); if Assigned(FOnWheelUp) then
FOnWheelUp(Self, Shift, MousePos, Handled);
end; end;
procedure TmbDeskPickerButton.WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure TmbDeskPickerButton.WheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin begin
if Assigned(OnWDown) then OnWDown(Self, Shift, MousePos, Handled); if Assigned(FOnWheelDown) then
FOnWheelDown(Self, Shift, MousePos, Handled);
end; end;
end. end.

8
components/mbColorLib/mbOfficeColorDialog.pas
View File

@ -1,17 +1,11 @@
unit mbOfficeColorDialog; unit mbOfficeColorDialog;
{$IFDEF FPC} {$MODE DELPHI}
{$MODE DELPHI}
{$ENDIF}
interface interface
uses uses
{$IFDEF FPC}
LCLIntf, LCLType, LCLIntf, LCLType,
{$ELSE}
Windows,
{$ENDIF}
SysUtils, Classes, Graphics, Forms, OfficeMoreColorsDialog; SysUtils, Classes, Graphics, Forms, OfficeMoreColorsDialog;
type type

688
components/mbColorLib/mbTrackBarPicker.pas
View File

@ -1,21 +1,13 @@
unit mbTrackBarPicker; unit mbTrackBarPicker;
{$IFDEF FPC} {$MODE DELPHI}
{$MODE DELPHI}
{$ENDIF}
interface interface
{$I mxs.inc}
uses uses
{$IFDEF FPC} LCLIntf, LCLType, LMessages, SysUtils, Classes, Controls, Graphics, Forms,
LCLIntf, LCLType, LMessages, Themes, ExtCtrls,
{$ELSE} PalUtils, mbBasicPicker;
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} ExtCtrls, PalUtils, mbBasicPicker;
const const
TBA_Resize = 0; TBA_Resize = 0;
@ -44,52 +36,47 @@ type
TmbTrackBarPicker = class(TmbBasicPicker) TmbTrackBarPicker = class(TmbBasicPicker)
private private
mx, my: integer;
FOnChange: TNotifyEvent;
FIncrement: integer;
FHintFormat: string;
FPlacement: TSliderPlacement;
FNewArrowStyle: boolean;
Aw, Ah: integer; Aw, Ah: integer;
FDoChange: boolean; mx, my: integer;
FSelIndicator: TSelIndicator;
FWebSafe: boolean;
FBevelInner: TBevelCut; FBevelInner: TBevelCut;
FBevelOuter: TBevelCut; FBevelOuter: TBevelCut;
FBevelWidth: TBevelWidth; FBevelWidth: TBevelWidth;
FBorderStyle: TBorderStyle; FBorderStyle: TBorderStyle;
FDoChange: boolean;
FHintFormat: string;
FIncrement: integer;
FNewArrowStyle: boolean;
FPlacement: TSliderPlacement;
FSelIndicator: TSelIndicator;
FWebSafe: boolean;
FOnChange: TNotifyEvent;
procedure CalcPickRect;
procedure DrawMarker(p: integer);
procedure SetBevelInner(Value: TBevelCut); procedure SetBevelInner(Value: TBevelCut);
procedure SetBevelOuter(Value: TBevelCut); procedure SetBevelOuter(Value: TBevelCut);
procedure SetBevelWidth(Value: TBevelWidth); procedure SetBevelWidth(Value: TBevelWidth);
procedure SetBorderStyle(Value: TBorderStyle);
procedure SetWebSafe(s: boolean);
function XToArrowPos(p: integer): integer;
function YToArrowPos(p: integer): integer;
procedure SetLayout(Value: TTrackBarLayout); procedure SetLayout(Value: TTrackBarLayout);
procedure SetNewArrowStyle(s: boolean); procedure SetNewArrowStyle(s: boolean);
procedure SetPlacement(Value: TSliderPlacement); procedure SetPlacement(Value: TSliderPlacement);
procedure DrawMarker(p: integer);
procedure SetSelIndicator(Value: TSelIndicator); procedure SetSelIndicator(Value: TSelIndicator);
procedure CalcPickRect; procedure SetWebSafe(s: boolean);
function XToArrowPos(p: integer): integer;
function YToArrowPos(p: integer): integer;
protected protected
FArrowPos: integer; FArrowPos: integer;
FManual: boolean; FBack: TBitmap;
FChange: boolean; FChange: boolean;
FPickRect: TRect; FManual: boolean;
FLayout: TTrackBarLayout; FLayout: TTrackBarLayout;
FLimit: integer; FLimit: integer;
FBack: TBitmap; FPickRect: TRect;
procedure CreateGradient; override; procedure CreateGradient; override;
procedure CreateWnd; override;
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean; override; MousePos: TPoint): Boolean; override;
procedure Paint; override;
// procedure PaintParentBack;
procedure DrawFrames; dynamic; procedure DrawFrames; dynamic;
procedure Resize; override;
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); dynamic; procedure Execute(tbaAction: integer); dynamic;
function GetArrowPos: integer; dynamic; function GetArrowPos: integer; dynamic;
// function GetColorUnderCursor: TColor; override;
function GetHintPos(X, Y: Integer): TPoint; override; function GetHintPos(X, Y: Integer): TPoint; override;
function GetHintStr(X, Y: Integer): String; override; function GetHintStr(X, Y: Integer): String; override;
function GetSelectedValue: integer; virtual; abstract; function GetSelectedValue: integer; virtual; abstract;
@ -97,21 +84,12 @@ type
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseLeave; override; procedure MouseLeave; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
// function MouseOnPicker(X, Y: Integer): Boolean;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
{ procedure Paint; override;
procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure Resize; override;
procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure SetBorderStyle(Value: TBorderStyle); override;
}
{$IFDEF DELPHI}
// procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER;
procedure CMLostFocus(var Message: TCMLostFocus); message CM_EXIT;
{$ELSE}
// procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN;
procedure CMGotFocus(var Message: TLMessage); message CM_ENTER; procedure CMGotFocus(var Message: TLMessage); message CM_ENTER;
procedure CMLostFocus(var Message: TLMessage); message CM_EXIT; procedure CMLostFocus(var Message: TLMessage); message CM_EXIT;
{$ENDIF}
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
@ -134,9 +112,6 @@ type
property ShowHint; property ShowHint;
property Color; property Color;
property ParentColor; property ParentColor;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
property ParentBackground default true;
{$ENDIF}{$ENDIF}
property ParentShowHint default true; property ParentShowHint default true;
property Anchors; property Anchors;
property Align; property Align;
@ -172,9 +147,7 @@ type
implementation implementation
uses uses
{$IFDEF FPC}
IntfGraphics, fpimage, IntfGraphics, fpimage,
{$ENDIF}
ScanLines, HTMLColors; ScanLines, HTMLColors;
const const
@ -201,19 +174,18 @@ constructor TmbTrackBarPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
//ControlStyle := ControlStyle - [csAcceptsControls]; // + [csOpaque]; // !!!!!!!! //ControlStyle := ControlStyle - [csAcceptsControls]; // + [csOpaque]; // !!!!!!!!
DoubleBuffered := true; //DoubleBuffered := true;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF} {$ENDIF}
Width := 267; Width := 267;
Height := 22; Height := 22;
TabStop := true; TabStop := true;
ParentShowHint := true; ParentShowHint := true;
FGradientWidth := 256;
FGradientHeight := 1;
FBack := TBitmap.Create; FBack := TBitmap.Create;
FGradientWidth := 256;
FGradientHeight := 12;
FBufferBmp := TBitmap.Create; FBufferBmp := TBitmap.Create;
FBufferBmp.PixelFormat := pf32bit; FBufferBmp.PixelFormat := pf32bit;
@ -222,8 +194,6 @@ begin
FIncrement := 1; FIncrement := 1;
FArrowPos := GetArrowPos; FArrowPos := GetArrowPos;
FHintFormat := ''; FHintFormat := '';
// OnMouseWheelUp := WheelUp;
// OnMouseWheelDown := WheelDown;
FManual := false; FManual := false;
FChange := true; FChange := true;
FLayout := lyHorizontal; FLayout := lyHorizontal;
@ -236,10 +206,10 @@ begin
FSelIndicator := siArrows; FSelIndicator := siArrows;
FLimit := 7; FLimit := 7;
FWebSafe := false; FWebSafe := false;
FBevelInner:= bvNone; FBevelInner := bvNone;
FBevelOuter:= bvNone; FBevelOuter := bvNone;
FBevelWidth:= 1; FBevelWidth := 1;
FBorderStyle:= bsNone; FBorderStyle := bsNone;
end; end;
destructor TmbTrackbarPicker.Destroy; destructor TmbTrackbarPicker.Destroy;
@ -248,88 +218,6 @@ begin
inherited; inherited;
end; 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;
{$ENDIF}
begin
if FBufferBmp = nil then
exit;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(0, 0);
try
{$ENDIF}
if Layout = lyHorizontal then
begin
FBufferBmp.Width := FGradientWidth;
FBufferBmp.Height := FGradientHeight;
{$IFDEF FPC}
intfImg.LoadFromBitmap(FBufferBmp.Handle, FBufferBmp.MaskHandle);
{$ENDIF}
for i := 0 to FBufferBmp.Width-1 do
begin
c := GetGradientColor(i);
if WebSafe then c := GetWebSafe(c);
q := RGBToRGBQuad(c);
for j := 0 to FBufferBmp.Height-1 do
begin
{$IFDEF FPC}
row := intfImg.GetDataLineStart(j);
{$ELSE}
row := FGradientBmp.ScanLine[j];
{$ENDIF}
row[i] := q;
end;
end;
end
else
begin
FBufferBmp.Width := FGradientHeight;
FBufferBmp.Height := FGradientWidth;
{$IFDEF FPC}
intfImg.LoadFromBitmap(FBufferBmp.Handle, FBufferBmp.MaskHandle);
{$ENDIF}
for i := 0 to FBufferBmp.Height-1 do
begin
{$IFDEF FPC}
row := intfImg.GetDataLineStart(i);
{$ELSE}
row := FGradientBmp.ScanLine[i];
{$ENDIF}
c := GetGradientColor(FBufferBmp.Height - 1 - i);
if WebSafe then c := GetWebSafe(c);
q := RGBtoRGBQuad(c);
for j := 0 to FBufferBmp.Width-1 do
row[j] := q;
end;
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBufferBmp.Handle := imgHandle;
FBufferBmp.MaskHandle := imgMaskHandle;
finally
intfImg.Free;
end;
{$ENDIF}
end;
procedure TmbTrackBarPicker.CreateWnd;
begin
inherited;
CalcPickRect;
CreateGradient;
end;
procedure TmbTrackBarPicker.CalcPickRect; procedure TmbTrackBarPicker.CalcPickRect;
var var
f: integer; f: integer;
@ -395,19 +283,98 @@ begin
end; end;
end; end;
procedure TmbTrackBarPicker.Paint; procedure TmbTrackBarPicker.CMGotFocus(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF});
begin begin
CalcPickRect; inherited;
PaintParentBack(Canvas); Invalidate;
FArrowPos := GetArrowPos; end;
Execute(TBA_Paint);
if FBorderStyle <> bsNone then procedure TmbTrackBarPicker.CMLostFocus(
DrawFrames; var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF});
DrawMarker(FArrowPos); begin
if FDoChange then inherited;
Invalidate;
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;
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
begin
if FBufferBmp = nil then
exit;
intfimg := TLazIntfImage.Create(0, 0);
try
if Layout = lyHorizontal then
begin
FBufferBmp.Width := FGradientWidth;
FBufferBmp.Height := FGradientHeight;
intfImg.LoadFromBitmap(FBufferBmp.Handle, FBufferBmp.MaskHandle);
for i := 0 to FBufferBmp.Width-1 do
begin
c := GetGradientColor(i);
if WebSafe then c := GetWebSafe(c);
q := RGBToRGBQuad(c);
for j := 0 to FBufferBmp.Height-1 do
begin
row := intfImg.GetDataLineStart(j);
row[i] := q;
end;
end;
end
else
begin
FBufferBmp.Width := FGradientHeight;
FBufferBmp.Height := FGradientWidth;
intfImg.LoadFromBitmap(FBufferBmp.Handle, FBufferBmp.MaskHandle);
for i := 0 to FBufferBmp.Height-1 do
begin
row := intfImg.GetDataLineStart(i);
c := GetGradientColor(FBufferBmp.Height - 1 - i);
if WebSafe then c := GetWebSafe(c);
q := RGBtoRGBQuad(c);
for j := 0 to FBufferBmp.Width-1 do
row[j] := q;
end;
end;
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBufferBmp.Handle := imgHandle;
FBufferBmp.MaskHandle := imgMaskHandle;
finally
intfImg.Free;
end;
end;
procedure TmbTrackbarPicker.CreateWnd;
begin
inherited;
CreateGradient;
end;
function TmbTrackbarPicker.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean;
begin
Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);
if not Result then
begin begin
Result := True;
FChange := false;
if WheelDelta > 0 then
Execute(TBA_WheelUp)
else
Execute(TBA_WheelDown);
FManual := true;
FChange := true;
if Assigned(FOnChange) then FOnChange(Self); if Assigned(FOnChange) then FOnChange(Self);
FDoChange := false;
end; end;
end; end;
@ -585,32 +552,37 @@ begin
end; // case FSelIndicator end; // case FSelIndicator
end; end;
procedure TmbTrackBarPicker.Resize; procedure TmbTrackBarPicker.Execute(tbaAction: integer);
begin begin
inherited; case tbaAction of
FChange := false; TBA_Paint : Canvas.StretchDraw(FPickRect, FBufferBmp);
Execute(TBA_Resize); TBA_RedoBMP : CreateGradient;
FChange := true; // Rest handled in descendants
end;
end; end;
function TmbTrackBarPicker.XToArrowPos(p: integer): integer; function TmbTrackBarPicker.GetArrowPos: integer;
var
pos: integer;
begin begin
pos := p - Aw; Result := 0;
if pos < 0 then pos := 0; //handled in descendants
if pos > Width - Aw - 1 then pos := Width - Aw - 1;
Result := pos;
end; end;
function TmbTrackBarPicker.YToArrowPos(p: integer): integer; function TmbTrackBarPicker.GetHintPos(X, Y: Integer): TPoint;
var
pos: integer;
begin begin
pos := p - Aw; case FLayout of
if pos < 0 then pos := 0; lyHorizontal:
if pos > Height - Aw - 1 then pos := Height - Aw - 1; Result := Point(X - 8, Height + 2);
Result := pos; lyVertical:
Result := Point(Width + 2, Y - 8);
end;
end;
function TmbTrackBarPicker.GetHintStr(X, Y: Integer): string;
begin
Result := inherited GetHintStr(X, Y);
if Result = '' then
Result := ReplaceFlags(FHintFormat, ['%value', '%h', '%s', '%l', '%v', '%c',
'%m', '%y', '%k', '%r', '%g', '%b'], GetSelectedValue);
end; end;
procedure TmbTrackBarPicker.KeyDown(var Key: Word; Shift: TShiftState); procedure TmbTrackBarPicker.KeyDown(var Key: Word; Shift: TShiftState);
@ -685,6 +657,23 @@ begin
inherited; inherited;
end; end;
procedure TmbTrackBarPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button <> mbLeft then Exit;
mx := x;
my := y;
SetFocus;
if FLayout = lyHorizontal then
FArrowPos := XToArrowPos(x)
else
FArrowPos := YToArrowPos(y);
Execute(TBA_MouseDown);
FManual := true;
FDoChange := true;
Invalidate;
inherited;
end;
procedure TmbTrackBarPicker.MouseLeave; procedure TmbTrackBarPicker.MouseLeave;
begin begin
inherited; inherited;
@ -716,28 +705,6 @@ begin
end; end;
inherited; inherited;
end; end;
(*
function TmbTrackBarPicker.MouseOnPicker(X, Y: Integer): Boolean;
begin
Result := PtInRect(FPickRect, Point(X, Y));
end; *)
procedure TmbTrackBarPicker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button <> mbLeft then Exit;
mx := x;
my := y;
SetFocus;
if FLayout = lyHorizontal then
FArrowPos := XToArrowPos(x)
else
FArrowPos := YToArrowPos(y);
Execute(TBA_MouseDown);
FManual := true;
FDoChange := true;
Invalidate;
inherited;
end;
procedure TmbTrackBarPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TmbTrackBarPicker.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin begin
@ -758,209 +725,66 @@ begin
Invalidate; Invalidate;
inherited; inherited;
end; end;
(*
procedure TmbTrackBarPicker.CNKeyDown(
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
var
Shift: TShiftState;
FInherited: boolean;
begin
FInherited := false;
Shift := KeyDataToShiftState(Message.KeyData);
case Message.CharCode of
VK_UP:
begin
if FLayout = lyHorizontal then
begin
inherited;
Exit;
end;
FChange := false;
if not (ssCtrl in Shift) then
Execute(TBA_VKUp)
else
Execute(TBA_VKCtrlUp);
FManual := true;
FChange := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
VK_LEFT:
begin
if FLayout = lyVertical then
begin
inherited;
Exit;
end;
FChange := false;
if not (ssCtrl in Shift) then
Execute(TBA_VKLeft)
else
Execute(TBA_VKCtrlLeft);
FManual := true;
FChange := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
VK_RIGHT:
begin
if FLayout = lyVertical then
begin
inherited;
Exit;
end;
FChange := false;
if not (ssCtrl in Shift) then
Execute(TBA_VKRight)
else
Execute(TBA_VKCtrlRight);
FManual := true;
FChange := true;
if Assigned(FOnChange) then FOnChange(Self);
end;
VK_DOWN:
begin
if FLayout = lyHorizontal then
begin
inherited;
Exit;
end;
FChange := false;
if not (ssCtrl in Shift) then
Execute(TBA_VKDown)
else
Execute(TBA_VKCtrlDown);
FManual := true;
FChange := true;
if Assigned(FOnChange) then FOnChange(Self);
end
else
begin
FInherited := true;
inherited;
end;
end; // case
if not FInherited and Assigned(OnKeyDown) then
OnKeyDown(Self, Message.CharCode, Shift);
end;
*)
function TmbTrackBarPicker.GetHintPos(X, Y: Integer): TPoint;
begin
case FLayout of
lyHorizontal:
Result := Point(X - 8, Height + 2);
lyVertical:
Result := Point(Width + 2, Y - 8);
end;
end;
function TmbTrackBarPicker.GetHintStr(X, Y: Integer): string; procedure TmbTrackBarPicker.Paint;
begin begin
Result := inherited GetHintStr(X, Y); CalcPickRect;
if Result = '' then PaintParentBack(Canvas);
Result := ReplaceFlags(FHintFormat, ['%value', '%h', '%s', '%l', '%v', '%c', FArrowPos := GetArrowPos;
'%m', '%y', '%k', '%r', '%g', '%b'], GetSelectedValue); Execute(TBA_Paint);
end; if FBorderStyle <> bsNone then
(* DrawFrames;
procedure TmbTrackBarPicker.CMHintShow(var Message: TCMHintShow); DrawMarker(FArrowPos);
var if FDoChange then
cp: TPoint;
begin
with TCMHintShow(Message) do
if not ShowHint then
Message.Result := 1 // 1 means: hide hint
else
begin
cp := HintInfo^.CursorPos;
HintInfo^.ReshowTimeout := 0; // was: 1
HintInfo^.HideTimeout := Application.HintHidePause; // was: 5000
HintInfo
case FLayout of
lyHorizontal:
HintInfo^.HintPos := ClientToScreen(Point(cp.X - 8, Height + 2));
lyVertical:
HintInfo^.HintPos := ClientToScreen(Point(Width +2, cp.Y - 8));
end;
HintInfo^.HintStr := GetHintStr;
HintInfo^.CursorRect := Rect(cp.X, cp.Y, cp.X+1, cp.Y+1);
Result := 0; // 0 means: show hint
end;
inherited;
end; *)
{
with HintInfo^ do
begin
if HintControl <> self then
begin
Message.Result := -1;
exit;
end;
Result := 0;
ReshowTimeout := 1;
HideTimeout := 0; //5000;
if FLayout = lyHorizontal then
HintPos := ClientToScreen(Point(CursorPos.X - 8, Height + 2))
else
HintPos := ClientToScreen(Point(Width + 2, CursorPos.Y - 8));
HintStr := GetHintStr;
end;
inherited;
end;
}
procedure TmbTrackBarPicker.CMGotFocus(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF});
begin
inherited;
Invalidate;
end;
procedure TmbTrackBarPicker.CMLostFocus(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF});
begin
inherited;
Invalidate;
end;
function TmbTrackbarPicker.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean;
begin
Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);
if not Result then
begin begin
Result := True;
FChange := false;
if WheelDelta > 0 then
Execute(TBA_WheelUp)
else
Execute(TBA_WheelDown);
FManual := true;
FChange := true;
if Assigned(FOnChange) then FOnChange(Self); if Assigned(FOnChange) then FOnChange(Self);
FDoChange := false;
end; end;
end; end;
(* procedure TmbTrackBarPicker.Resize;
procedure TmbTrackBarPicker.WheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin begin
Handled := true; inherited;
FChange := false; FChange := false;
Execute(TBA_WheelUp); Execute(TBA_Resize);
FManual := true;
FChange := true; FChange := true;
if Assigned(FOnChange) then FOnChange(Self);
end; end;
procedure TmbTrackBarPicker.WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure TmbTrackBarPicker.SetBevelInner(Value: TBevelCut);
begin begin
Handled := true; if FBevelInner <> Value then
FChange := false; begin
Execute(TBA_WheelDown); FBevelInner := Value;
FManual := true; Invalidate;
FChange := true; end;
if Assigned(FOnChange) then FOnChange(Self); end;
end; *)
procedure TmbTrackBarPicker.SetBevelOuter(Value: TBevelCut);
begin
if FBevelOuter <> Value then
begin
FBevelOuter := Value;
Invalidate;
end;
end;
procedure TmbTrackBarPicker.SetBorderStyle(Value: TBorderStyle);
begin
if FBorderStyle <> Value then
begin
FBorderStyle := Value;
Invalidate;
end;
end;
procedure TmbTrackBarPicker.SetBevelWidth(Value: TBevelWidth);
begin
if FBevelWidth <> Value then
begin
FBevelWidth := Value;
Invalidate;
end;
end;
{ IMPORTANT: If pickers are created at designtime the layout must be set before { IMPORTANT: If pickers are created at designtime the layout must be set before
defining the picker width and height because changing the layout will flip the defining the picker width and height because changing the layout will flip the
@ -977,15 +801,6 @@ begin
end; end;
end; end;
procedure TmbTrackBarPicker.SetPlacement(Value: TSliderPlacement);
begin
if FPlacement <> Value then
begin
FPlacement := Value;
Invalidate;
end;
end;
procedure TmbTrackBarPicker.SetNewArrowStyle(s: boolean); procedure TmbTrackBarPicker.SetNewArrowStyle(s: boolean);
begin begin
if FNewArrowStyle <> s then if FNewArrowStyle <> s then
@ -995,6 +810,15 @@ begin
end; end;
end; end;
procedure TmbTrackBarPicker.SetPlacement(Value: TSliderPlacement);
begin
if FPlacement <> Value then
begin
FPlacement := Value;
Invalidate;
end;
end;
procedure TmbTrackBarPicker.SetSelIndicator(Value: TSelIndicator); procedure TmbTrackBarPicker.SetSelIndicator(Value: TSelIndicator);
begin begin
if FSelIndicator <> Value then if FSelIndicator <> Value then
@ -1014,70 +838,24 @@ begin
end; end;
end; end;
procedure TmbTrackBarPicker.Execute(tbaAction: integer); function TmbTrackBarPicker.XToArrowPos(p: integer): integer;
var
pos: integer;
begin begin
case tbaAction of pos := p - Aw;
TBA_Paint : Canvas.StretchDraw(FPickRect, FBufferBmp); if pos < 0 then pos := 0;
TBA_RedoBMP : CreateGradient; if pos > Width - Aw - 1 then pos := Width - Aw - 1;
// Rest handled in descendants Result := pos;
end;
end; end;
function TmbTrackBarPicker.GetArrowPos: integer; function TmbTrackBarPicker.YToArrowPos(p: integer): integer;
var
pos: integer;
begin begin
Result := 0; pos := p - Aw;
//handled in descendants if pos < 0 then pos := 0;
if pos > Height - Aw - 1 then pos := Height - Aw - 1;
Result := pos;
end; end;
(*
function TmbTrackBarPicker.GetHintText: string;
begin
Result := ReplaceFlags(FHintFormat, ['%value', '%h', '%s', '%l', '%v', '%c',
'%m', '%y', '%k', '%r', '%g', '%b'], GetSelectedValue);
end; *)
procedure TmbTrackBarPicker.SetBevelInner(Value: TBevelCut);
begin
if FBevelInner <> Value then
begin
FBevelInner := Value;
Invalidate;
end;
end;
procedure TmbTrackBarPicker.SetBevelOuter(Value: TBevelCut);
begin
if FBevelOuter <> Value then
begin
FBevelOuter := Value;
Invalidate;
end;
end;
procedure TmbTrackBarPicker.SetBevelWidth(Value: TBevelWidth);
begin
if FBevelWidth <> Value then
begin
FBevelWidth := Value;
Invalidate;
end;
end;
procedure TmbTrackBarPicker.SetBorderStyle(Value: TBorderStyle);
begin
if FBorderStyle <> Value then
begin
FBorderStyle := Value;
Invalidate;
end;
end;
(*
function TmbTrackbarPicker.ShowHintWindow(APoint: TPoint; AText: String): Boolean;
begin
Result := inherited;
if Result then
FHintShown := true;
end;
*)
end. end.

2
components/mbColorLib/mbcolorliblaz.lpk
View File

@ -14,7 +14,7 @@
</CompilerOptions> </CompilerOptions>
<Description Value="Comprehensive color selection library with more than 30 components"/> <Description Value="Comprehensive color selection library with more than 30 components"/>
<License Value="License is granted to use, modify and redistribute these units in your applications as you see fit. You are given COMPLETE FREEDOM with the sources found in this pack; you're free to use it in ANY kind of app without even mentioning my name, my site or any other stuff, that depends on your good will and nothing else. I will accept any modifications and incorporate them in this pack if they'll help make it better. You are under NO obligation to pay for these components to neither me nor anyone else trying to sell them in their current form. If you wish to support development of these components you can do so by contributing some source or making a donation, again this solely depends on your good will."/> <License Value="License is granted to use, modify and redistribute these units in your applications as you see fit. You are given COMPLETE FREEDOM with the sources found in this pack; you're free to use it in ANY kind of app without even mentioning my name, my site or any other stuff, that depends on your good will and nothing else. I will accept any modifications and incorporate them in this pack if they'll help make it better. You are under NO obligation to pay for these components to neither me nor anyone else trying to sell them in their current form. If you wish to support development of these components you can do so by contributing some source or making a donation, again this solely depends on your good will."/>
<Version Major="2" Release="2"/> <Version Major="2" Minor="1"/>
<Files Count="46"> <Files Count="46">
<Item1> <Item1>
<Filename Value="PalUtils.pas"/> <Filename Value="PalUtils.pas"/>