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

221
components/mbColorLib/GAxisColorPicker.pas
View File

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

194
components/mbColorLib/GColorPicker.pas
View File

@ -1,29 +1,26 @@
unit GColorPicker;
{$IFDEF FPC}{$MODE DELPHI}{$ENDIF}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
mbTrackBarPicker, HTMLColors;
LCLIntf, LCLType, LMessages, SysUtils, Classes, Controls, Graphics, Forms,
HTMLColors, mbTrackBarPicker;
type
TGColorPicker = class(TmbTrackBarPicker)
private
FRed, FGreen, FBlue: integer;
function ArrowPosFromGreen(g: integer): integer;
function GreenFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
procedure SetRed(r: integer);
procedure SetGreen(g: integer);
function GreenFromArrowPos(p: integer): integer;
procedure SetBlue(b: integer);
procedure SetGreen(g: integer);
procedure SetRed(r: integer);
procedure SetSelectedColor(c: TColor);
protected
procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override;
@ -39,6 +36,7 @@ type
property Layout default lyVertical;
end;
implementation
uses
@ -63,50 +61,6 @@ begin
FChange := true;
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;
var
a: integer;
@ -126,48 +80,6 @@ begin
Result := a;
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);
begin
case tbaAction of
@ -204,4 +116,90 @@ begin
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.

203
components/mbColorLib/HColorPicker.pas
View File

@ -7,13 +7,8 @@ unit HColorPicker;
interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
RGBHSVUtils, mbTrackBarPicker, HTMLColors;
LCLIntf, LCLType, LMessages, SysUtils, Classes, Controls, Graphics, Forms,
RGBHSVUtils, HTMLColors, mbTrackBarPicker;
type
THColorPicker = class(TmbTrackBarPicker)
@ -24,14 +19,14 @@ type
function HueFromArrowPos(p: integer): integer;
function GetHue: Integer;
function GetSat: Integer;
function GetVal: Integer;
function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
function GetVal: Integer;
procedure SetHue(h: integer);
procedure SetMaxHue(h: Integer);
procedure SetMaxSat(s: Integer);
procedure SetMaxVal(v: Integer);
procedure SetSat(s: integer);
procedure SetSelectedColor(c: TColor);
procedure SetVal(v: integer);
protected
procedure Execute(tbaAction: integer); override;
@ -75,6 +70,68 @@ begin
FChange := true;
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;
var
h: Double;
@ -94,11 +151,35 @@ begin
Result := round(FSat * FMaxSat);
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;
begin
Result := round(FVal * FMaxVal);
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);
begin
Clamp(h, 0, FMaxHue);
@ -156,61 +237,6 @@ begin
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);
var
h, s, v: integer;
@ -226,47 +252,16 @@ begin
if Assigned(OnChange) then OnChange(Self);
end;
function THColorPicker.GetArrowPos: integer;
procedure THColorPicker.SetVal(v: integer);
begin
if FMaxHue = 0 then
Result := inherited GetArrowPos
else
Result := ArrowPosFromHue(GetHue());
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;
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;

538
components/mbColorLib/HRingPicker.pas
View File

@ -7,13 +7,8 @@ unit HRingPicker;
interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, RGBHSVUtils,
Forms, {IFDEF DELPHI_7_UP Themes, $ENDIF} HTMLColors, mbColorPickerControl;
LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics, Math, Forms,
RGBHSVUtils, HTMLColors, mbColorPickerControl;
type
THRingPicker = class(TmbColorPickerControl)
@ -47,19 +42,14 @@ type
procedure CreateGradient; override;
function GetGradientColor2D(X, Y: Integer): 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 MouseMove(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;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
(*
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
*)
procedure Paint; override;
procedure Resize; override;
procedure SetSelectedColor(c: TColor); override;
public
constructor Create(AOwner: TComponent); override;
function GetColorAtPoint(x, y: integer): TColor; override;
@ -72,8 +62,8 @@ type
property MaxSaturation: Integer read FMaxSat write SetMaxSat default 255;
property MaxValue: Integer read FMaxValue write SetMaxValue default 255;
property HueLineColor: TColor read FHueLineColor write SetHueLineColor default clGray;
property SelectedColor default clNone;
property Radius: integer read FRadius write SetRadius default 40;
property SelectedColor default clNone;
property OnChange;
end;
@ -88,12 +78,7 @@ uses
constructor THRingPicker.Create(AOwner: TComponent);
begin
inherited;
{$IFDEF DELPHI}
Width := 204;
Height := 204;
{$ELSE}
SetInitialBounds(0, 0, 204, 204);
{$ENDIF}
FMaxHue := 359;
FMaxSat := 255;
FMaxValue := 255;
@ -107,6 +92,7 @@ begin
FRadius := 40;
FDoChange := false;
HintFormat := 'Hue: %h (selected)';
TabStop := true;
end;
procedure THRingPicker.CreateGradient;
@ -116,6 +102,49 @@ begin
inherited;
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 }
function THRingPicker.GetGradientColor2D(X, Y: Integer): TColor;
var
@ -143,34 +172,6 @@ begin
Result := GetDefaultColor(dctBrush);
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;
begin
Result := round(FHue * FMaxHue);
@ -181,168 +182,23 @@ begin
Result := round(FSat * FMaxSat);
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;
begin
Result := round(FValue * FMaxValue);
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);
var
eraseKey: Boolean;
@ -379,31 +235,8 @@ begin
inherited;
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;
X, Y: Integer);
{$IFDEF DELPHI}
var
R: TRect;
{$ENDIF}
begin
inherited;
if csDesigning in ComponentState then
@ -412,13 +245,6 @@ begin
then begin
mdx := x;
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;
SelectionChanged(X, Y);
FManual := true;
@ -453,42 +279,161 @@ begin
end;
end;
function THRingPicker.GetSelectedColor: TColor;
procedure THRingPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
if FSelectedColor <> clNone then
inherited;
if csDesigning in ComponentState then Exit;
if (Button = mbLeft) and FDragging then
begin
Result := HSVtoColor(FHue, FSat, FValue);
if WebSafe then
Result := GetWebSafe(Result);
end
else
Result := clNone;
mdx := x;
mdy := y;
FDoChange := true;
SelectionChanged(X, Y);
FManual := true;
FDragging := false;
end;
end;
function THRingPicker.GetColorAtPoint(x, y: integer): TColor;
procedure THRingPicker.Paint;
var
angle: Double;
dx, dy, radius: integer;
h: Double;
rgn, r1, r2: HRGN;
r: TRect;
size: Integer;
ringwidth: Integer;
begin
radius := Min(Width, Height) div 2;
if PointInCircle(Point(x, y), Min(Width, Height)) then
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
dx := x - Radius;
dy := y - Radius;
angle := 360 + 180 * arctan2(-dy, dx) / pi;
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;
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
angle := angle + 360
inc(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;
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;
procedure THRingPicker.SetSelectedColor(c: TColor);
@ -509,52 +454,31 @@ begin
FChange := true;
end;
function THRingPicker.RadHue(New: integer): integer;
procedure THRingPicker.SetValue(v: integer);
begin
if New < 0 then New := New + (FMaxHue + 1);
if New > (FMaxHue + 1) then New := New - (FMaxHue + 1);
Result := New;
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.CNKeyDown(
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF} );
procedure THRingPicker.UpdateCoords;
var
shift: TShiftState;
FInherited: boolean;
delta: Integer;
r, angle: double;
radius: integer;
sinAngle, cosAngle: Double;
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;
if not FInherited then
if Assigned(OnKeyDown) then
OnKeyDown(Self, Message.CharCode, Shift);
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.

219
components/mbColorLib/HSColorPicker.pas
View File

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

365
components/mbColorLib/HSLColorPicker.pas
View File

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

367
components/mbColorLib/HSLRingPicker.pas
View File

@ -6,16 +6,9 @@ unit HSLRingPicker;
interface
{$I mxs.inc}
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, Menus, Math,
{$IFDEF DELPHI_7_UP}Themes,{$ENDIF}
LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics,
Forms, Menus, Math, Themes,
RGBHSLUtils, HRingPicker, SLColorPicker, HTMLColors, mbBasicPicker;
type
@ -61,20 +54,13 @@ type
procedure Paint; override;
procedure Resize; override;
procedure RingPickerChange(Sender: TObject);
procedure SetFocus; override;
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
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetHexColorUnderCursor: string; override;
function GetSelectedHexColor: string;
procedure SetFocus; override;
property ColorUnderCursor;
property Hue: integer read GetHue write SetHue;
property Saturation: integer read GetSat write SetSat;
@ -119,22 +105,13 @@ constructor THSLRingPicker.Create(AOwner: TComponent);
begin
inherited;
// ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}];
//DoubleBuffered := true;
FRValue := 255;
FGValue := 0;
FBValue := 0;
PBack := TBitmap.Create;
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);
{$ENDIF}
TabStop := true;
FSelectedColor := clRed;
FRingCursor := crDefault;
@ -146,14 +123,7 @@ begin
InsertControl(FRingPicker);
with FRingPicker do
begin
{$IFDEF DELPHI}
Left := 0;
Top := 0;
Width := 246;
Height := 246;
{$ELSE}
SetInitialBounds(0, 0, 246, 246);
{$ENDIF}
//Radius := 40;
Align := alClient;
Visible := true;
@ -168,14 +138,7 @@ begin
InsertControl(FSLPicker);
with FSLPicker do
begin
{$IFDEF DELPHI}
Left := 63;
Top := 63;
Width := 120;
Height := 120;
{$ELSE}
SetInitialBounds(63, 63, 120, 120);
{$ENDIF}
MaxSaturation := 240;
MaxLuminance := 240;
Saturation := 240;
@ -189,11 +152,90 @@ end;
destructor THSLRingPicker.Destroy;
begin
PBack.Free;
//FRingPicker.Free;
//FSLPicker.Free;
inherited Destroy;
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;
var
circ: TPoint;
@ -225,26 +267,6 @@ begin
DoChange;
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);
begin
if (FRingPicker = nil) or (FSLPicker = nil) then
@ -258,6 +280,24 @@ begin
FSelectedColor := c;
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);
begin
if (FRingPicker = nil) or (FSLPicker = nil) then
@ -267,13 +307,6 @@ begin
FSLPicker.Hue := H;
end;
procedure THSLRingPicker.SetSat(S: integer);
begin
if (FSLPicker = nil) then
exit;
FSLPicker.Saturation := S;
end;
procedure THSLRingPicker.SetLum(L: integer);
begin
if (FSLPicker = nil) then
@ -281,143 +314,6 @@ begin
FSLPicker.Luminance := L;
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);
begin
FRingPicker.MaxHue := H;
@ -433,4 +329,61 @@ begin
FSLPicker.MaxSaturation := S;
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.

649
components/mbColorLib/HSVColorPicker.pas
View File

@ -7,14 +7,8 @@ unit HSVColorPicker;
interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, RGBHSVUtils, Scanlines,
Forms, {$IFDEF DELPHI_7_UP}Themes,{$ENDIF}
HTMLColors, mbColorPickerControl;
LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics, Math, Forms, Themes,
RGBHSVUtils, Scanlines, HTMLColors, mbColorPickerControl;
type
THSVColorPicker = class(TmbColorPickerControl)
@ -50,21 +44,16 @@ type
procedure UpdateCoords;
protected
procedure CreateGradient; override;
procedure CreateWnd; override;
function GetGradientColor2D(X, Y: Integer): 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 MouseMove(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 CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
*)
procedure SetSelectedColor(c: TColor); override;
public
constructor Create(AOwner: TComponent); override;
function GetColorAtPoint(x, y: integer): TColor; override;
@ -95,12 +84,7 @@ uses
constructor THSVColorPicker.Create(AOwner: TComponent);
begin
inherited;
{$IFDEF DELPHI}
Width := 204;
Height := 204;
{$ELSE}
SetInitialBounds(0, 0, 204, 204);
{$ENDIF}
FMaxHue := 359;
FMaxSat := 255;
FMaxValue := 255;
@ -119,30 +103,6 @@ begin
MarkerStyle := msCrossCirc;
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;
begin
FGradientWidth := Min(Width, Height);
@ -150,59 +110,6 @@ begin
inherited;
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;
begin
inherited;
@ -210,136 +117,6 @@ begin
UpdateCoords;
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;
var
delta: integer;
@ -389,39 +166,89 @@ begin
InternalDrawMarker(x, y, c);
end;
procedure THSVColorPicker.SelectionChanged(x, y: integer);
function THSVColorPicker.GetColorAtPoint(x, y: integer): TColor;
var
angle: Double;
dx, dy, r, radius: integer;
h, s: double;
begin
radius := Min(Width, Height) div 2;
dx := x - radius;
dy := y - radius;
dx := x - Radius;
dy := y - Radius;
r := round(sqrt(sqr(dx) + sqr(dy)));
if r > radius then // point outside circle
if r <= radius then
begin
FChange := false;
SetSelectedColor(clNone);
FChange := true;
exit;
end;
FSelectedColor := clWhite;
angle := 360 + 180*arctan2(-dy, dx) / pi; // wp: "-y, x" correct? The others have "x, y"
angle := 360 + 180 * arctan2(-dy, dx) / pi;
if angle < 0 then
angle := angle + 360
else if angle > 360 then
angle := angle - 360;
FChange := false;
FHue := angle / 360;
if r > radius then
FSat := 1.0
else
FSat := r / radius;
FChange := true;
h := angle / 360;
s := r / radius;
Result := HSVtoColor(h, s, FValue);
if WebSafe then
Result := GetWebSafe(Result);
end else
Result := clNone;
end;
Invalidate;
{ 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.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 THSVColorPicker.GetValue: Integer;
begin
Result := round(FValue * FMaxValue);
end;
procedure THSVColorPicker.KeyDown(var Key: Word; Shift: TShiftState);
@ -476,31 +303,8 @@ begin
inherited;
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;
X, Y: Integer);
{$IFDEF DELPHI}
var
R: TRect;
{$ENDIF}
begin
inherited;
if csDesigning in ComponentState then
@ -509,13 +313,6 @@ begin
begin
mdx := x;
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;
SelectionChanged(X, Y);
FManual := true;
@ -537,56 +334,169 @@ begin
FManual := true;
end;
end;
(*
function THSVColorPicker.MouseOnPicker(X, Y: Integer): Boolean;
var
diameter, r: Integer;
P, ctr: TPoint;
procedure THSVColorPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
diameter := Min(Width, Height);
r := diameter div 2;
P := Point(x, y);
ctr := Point(r, r);
Result := PtInCircle(P, ctr, r);
end;
*)
function THSVColorPicker.GetSelectedColor: TColor;
begin
if FSelectedColor <> clNone then
inherited;
if csDesigning in ComponentState then
exit;
if (Button = mbLeft) and PointInCircle(Point(x, y), Min(Width, Height)) then
begin
Result := HSVtoColor(FHue, FSat, FValue);
if WebSafe then
Result := GetWebSafe(Result);
end
else
Result := clNone;
mdx := x;
mdy := y;
FDoChange := true;
SelectionChanged(X, Y);
FManual := true;
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
angle: Double;
dx, dy, r, radius: integer;
h, s: double;
begin
radius := Min(Width, Height) div 2;
dx := x - Radius;
dy := y - Radius;
dx := x - radius;
dy := y - radius;
r := round(sqrt(sqr(dx) + sqr(dy)));
if r <= radius then
if r > radius then // point outside circle
begin
angle := 360 + 180 * arctan2(-dy, dx) / pi;
FChange := false;
SetSelectedColor(clNone);
FChange := true;
exit;
end;
FSelectedColor := clWhite;
angle := 360 + 180*arctan2(-dy, dx) / pi; // wp: "-y, x" correct? The others have "x, y"
if angle < 0 then
angle := angle + 360
else if angle > 360 then
angle := angle - 360;
h := angle / 360;
s := r / radius;
Result := HSVtoColor(h, s, FValue);
if WebSafe then
Result := GetWebSafe(Result);
end else
Result := clNone;
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;
procedure THSVColorPicker.SetSelectedColor(c: TColor);
@ -607,69 +517,58 @@ begin
FChange := true;
end;
function THSVColorPicker.RadHue(New: integer): integer;
procedure THSVColorPicker.SetShowHueLine(s: boolean);
begin
if New < 0 then New := New + (FMaxHue + 1);
if New > (FMaxHue + 1) then New := New - (FMaxHue + 1);
Result := New;
if FShowHueLine <> s then
begin
FShowHueLine := s;
Invalidate;
end;
end;
(*
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;
if not FInherited then
if Assigned(OnKeyDown) then
OnKeyDown(Self, Message.CharCode, Shift);
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.

82
components/mbColorLib/HTMLColors.pas
View File

@ -2,23 +2,16 @@ unit HTMLColors;
interface
{$I mxs.inc}
uses
SysUtils,
{$IFDEF FPC}
LCLIntf,
{$ELSE}
Windows,
{$ENDIF}
Graphics{$IFDEF DELPHI_6_UP}, Variants{$ENDIF};
SysUtils, LCLIntf, Graphics, Variants;
const
SPECIAL_COUNT = 140;
WEBSAFE_COUNT = 216;
SYSTEM_COUNT = 28;
BASIC_COUNT = 16;
SPECIAL_HEX: array [0..139] of string = ('000000', 'FAEBD7', '00FFFF', '7FFFD4', 'F0FFFF', 'F5F5DC', 'FFE4C4',
SPECIAL_HEX: array [0..139] of string = (
'000000', 'FAEBD7', '00FFFF', '7FFFD4', 'F0FFFF', 'F5F5DC', 'FFE4C4',
'F0F8FF', 'FFEBCD', '0000FF', '8A2BE2', 'A52A2A', 'DEB887', '5F9EA0',
'7FFF00', 'D2691E', 'FF7F50', '6495ED', 'FFF8DC', 'DC143C', '00FFFF',
'00008B', '008B8B', 'B8860B', 'A9A9A9', '006400', 'BDB76B', '8B008B',
@ -37,8 +30,10 @@ const
'800080', 'FF0000', 'BC8F8F', '4169E1', '8B4513', 'FA8072', 'F4A460',
'2E8B57', 'FFF5EE', 'A0522D', 'C0C0C0', '87CEEB', '6A5ACD', '708090',
'FFFAFA', '00FF7F', '4682B4', 'D2B48C', '008080', 'D8BFD8', 'FF6347',
'40E0D0', 'EE82EE', 'F5DEB3', 'FFFFFF', 'F5F5F5', 'FFFF00', '9ACD32');
SPECIAL_NAMES: array [0..139] of string = ('black', 'antiquewhite', 'aqua', 'aquamarine', 'azure', 'beige',
'40E0D0', 'EE82EE', 'F5DEB3', 'FFFFFF', 'F5F5F5', 'FFFF00', '9ACD32'
);
SPECIAL_NAMES: array [0..139] of string = (
'black', 'antiquewhite', 'aqua', 'aquamarine', 'azure', 'beige',
'bisque', 'aliceblue', 'blanchedalmond', 'blue', 'blueviolet', 'brown',
'burlywood', 'cadetblue', 'chartreuse', 'chocolate', 'coral',
'cornflower', 'cornsilk', 'crimson', 'cyan', 'darkblue', 'darkcyan',
@ -63,8 +58,10 @@ const
'seagreen', 'seashell', 'sienna', 'silver', 'skyblue', 'slateblue',
'slategray', 'snow', 'springgreen', 'steelblue', 'tan', 'teal', 'thistle',
'tomato', 'turquoise', 'violet', 'wheat', 'white', 'whitesmoke', 'yellow',
'yellowgreen');
WEBSAFE_HEX: array [0..215] of string = ('000000' ,'000033' ,'000066' ,'000099' ,'0000cc' ,'0000ff',
'yellowgreen'
);
WEBSAFE_HEX: array [0..215] of string = (
'000000' ,'000033' ,'000066' ,'000099' ,'0000cc' ,'0000ff',
'003300' ,'003333' ,'003366' ,'003399' ,'0033cc' ,'0033ff',
'006600' ,'006633' ,'006666' ,'006699' ,'0066cc' ,'0066ff',
'009900' ,'009933' ,'009966' ,'009999' ,'0099cc' ,'0099ff',
@ -99,28 +96,37 @@ const
'ff6600' ,'ff6633' ,'ff6666' ,'ff6699' ,'ff66cc' ,'ff66ff',
'ff9900' ,'ff9933' ,'ff9966' ,'ff9999' ,'ff99cc' ,'ff99ff',
'ffcc00' ,'ffcc33' ,'ffcc66' ,'ffcc99' ,'ffcccc' ,'ffccff',
'ffff00' ,'ffff33' ,'ffff66' ,'ffff99' ,'ffffcc' ,'ffffff');
SYSTEM_VALUES: array [0..27] of TColor = (clActiveBorder, clActiveCaption, clAppWorkspace, clBackground,
'ffff00' ,'ffff33' ,'ffff66' ,'ffff99' ,'ffffcc' ,'ffffff'
);
SYSTEM_VALUES: array [0..27] of TColor = (
clActiveBorder, clActiveCaption, clAppWorkspace, clBackground,
clBtnFace, clBtnHighlight, clBtnShadow, clBtnText, clCaptionText,
clGrayText, clHighlight, clHighlightText, clInactiveBorder,
clInactiveCaption, clInactiveCaptionText, clInfoBk, clInfoText,
clMenu, clMenuText, clScrollbar, cl3dDkShadow, cl3dLight,
clBtnHighlight, clActiveBorder, clBtnShadow, clWindow,
clWindowFrame, clWindowText);
SYSTEM_NAMES: array [0..27] of string = ('activeborder', 'activecaption', 'appworkspace', 'background',
clWindowFrame, clWindowText
);
SYSTEM_NAMES: array [0..27] of string = (
'activeborder', 'activecaption', 'appworkspace', 'background',
'buttonface', 'buttonhighlight', 'buttonshadow', 'buttontext',
'captiontext', 'graytext', 'highlight', 'highlighttext',
'inactiveborder', 'inactivecaption', 'inactivecaptiontext',
'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,
'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',
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');
'white', 'yellow'
);
procedure MakeIntoHex(var s: string);
function IsMember(a: array of string; n: integer; s: string): boolean;
@ -139,8 +145,6 @@ implementation
var
WS: array [0..255] of byte;
//------------------------------------------------------------------------------
//checks membership of a string array
function IsMember(a: array of string; n: integer; s: string): boolean;
var
@ -152,16 +156,12 @@ begin
Result := true;
end;
//------------------------------------------------------------------------------
//checks if the color's nam was used instead of hex
//checks if the color's name was used instead of hex
function IsSpecialColor(s: string): boolean;
begin
Result := IsMember(BASIC_NAMES, BASIC_COUNT, s) or IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) or IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s);
end;
//------------------------------------------------------------------------------
//is hex was used then remove the wrong characters
procedure MakeIntoHex(var s: string);
var
@ -173,8 +173,6 @@ begin
s[i] := '0';
end;
//------------------------------------------------------------------------------
//formats entered text into a true hex value
function FormatHexColor(S: string): string;
var
@ -209,8 +207,6 @@ begin
Result := s;
end;
//------------------------------------------------------------------------------
//gets a hex value from a color name from special colors
function GetHexFromName(s: string): string;
var
@ -226,8 +222,6 @@ begin
Result := SPECIAL_HEX[k];
end;
//------------------------------------------------------------------------------
// gets a TColor value from a color name from basic or system colors
function GetValueFromName(s: string): TColor;
var
@ -259,19 +253,12 @@ begin
Result := clNone;
end;
//------------------------------------------------------------------------------
//converts a TColor value to a hex value
function ColorToHex(Color: TColor): string;
begin
// if Color <> $ then
Result := IntToHex(GetRValue(Color), 2) + IntToHex(GetGValue(Color), 2) + IntToHex(GetBValue(Color), 2)
// else
// Result := '000000';
end;
//------------------------------------------------------------------------------
//converts a hex value to a TColor
function HexToTColor(s: OleVariant): TColor;
begin
@ -297,8 +284,6 @@ begin
Result := clNone;
end;
//------------------------------------------------------------------------------
//checks if a hex value belongs to the websafe palette
function IsWebSafe(s: string): boolean;
begin
@ -306,8 +291,6 @@ begin
Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s);
end;
//------------------------------------------------------------------------------
//checks if a color belongs to the websafe palette
function IsWebSafe(c: TColor): boolean;
var
@ -317,8 +300,6 @@ begin
Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s);
end;
//------------------------------------------------------------------------------
//initializes the websafe comparison array
procedure InitializeWS;
var
@ -328,15 +309,12 @@ begin
WS[I] := ((i + $19) div $33) * $33;
end;
//------------------------------------------------------------------------------
//returns the closest web safe color to the one given
function GetWebSafe(C: TColor): TColor;
begin
Result := RGB(WS[GetRValue(C)], WS[GetGValue(C)], WS[GetBValue(C)]);
end;
//------------------------------------------------------------------------------
initialization
InitializeWS;

882
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
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
LCLIntf, LCLType,
SysUtils, Classes, Controls, Graphics, Forms,
RGBCMYKUtils, mbTrackBarPicker, HTMLColors;
@ -22,9 +18,9 @@ type
function ArrowPosFromBlack(k: integer): integer;
function BlackFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor);
procedure SetCyan(c: integer);
procedure SetMagenta(m: integer);
procedure SetSelectedColor(c: TColor);
procedure SetYellow(y: integer);
procedure SetBlack(k: integer);
protected
@ -68,63 +64,6 @@ begin
FChange := true;
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;
var
a: integer;
@ -156,39 +95,6 @@ begin
Result := k;
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);
begin
case tbaAction of
@ -225,4 +131,94 @@ begin
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.

191
components/mbColorLib/LColorPicker.pas
View File

@ -7,13 +7,8 @@ interface
{$ENDIF}
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
RGBHSLUtils, mbTrackBarPicker, HTMLColors;
LCLIntf, LCLType, SysUtils, Classes, Controls, Graphics, Forms,
HTMLColors, RGBHSLUtils, mbTrackBarPicker;
type
TLColorPicker = class(TmbTrackBarPicker)
@ -21,17 +16,17 @@ type
FHue, FSat, FLuminance: Double;
FMaxHue, FMaxSat, FMaxLum: Integer;
function ArrowPosFromLum(L: integer): integer;
function LumFromArrowPos(p: integer): integer;
function GetHue: Integer;
function GetSat: Integer;
function GetLuminance: Integer;
function GetSat: Integer;
function GetSelectedColor: TColor;
function LumFromArrowPos(p: integer): integer;
procedure SetHue(H: integer);
procedure SetSat(S: integer);
procedure SetLuminance(L: integer);
procedure SetMaxHue(H: Integer);
procedure SetMaxSat(S: Integer);
procedure SetMaxLum(L: Integer);
function GetSelectedColor: TColor;
procedure SetMaxSat(S: Integer);
procedure SetSat(S: integer);
procedure SetSelectedColor(c: TColor);
protected
procedure Execute(tbaAction: integer); override;
@ -74,6 +69,68 @@ begin
FChange := true;
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;
begin
Result := HSLToRGB(FHue, FSat, AValue/FMaxLum);
@ -94,6 +151,30 @@ begin
Result := Round(FSat * FMaxSat);
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);
begin
Clamp(H, 0, FMaxHue);
@ -164,48 +245,6 @@ begin
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);
begin
if WebSafe then c := GetWebSafe(c);
@ -217,48 +256,4 @@ begin
if FChange and Assigned(OnChange) then OnChange(Self);
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.

228
components/mbColorLib/MColorPicker.pas
View File

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

424
components/mbColorLib/OfficeMoreColorsDialog.pas
View File

@ -2,18 +2,11 @@ unit OfficeMoreColorsDialog;
interface
{$I mxs.inc}
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$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}
LCLIntf, LCLType, SysUtils, Variants, Classes, Graphics, Controls, Forms,
StdCtrls, ExtCtrls, ComCtrls,
HexaColorPicker, HSLColorPicker, RGBHSLUtils, mbColorPreview,
{$IFDEF mbXP_Lib}mbXPSpinEdit, mbXPSizeGrip,{$ELSE} Spin,{$ENDIF}
HTMLColors, SLHColorPicker, HSLRingPicker, RColorPicker, GColorPicker,
BColorPicker;
@ -102,11 +95,7 @@ var
implementation
{$IFDEF DELPHI}
{$R *.dfm}
{$ELSE}
{$R *.lfm}
{$ENDIF}
{$R *.lfm}
procedure TOfficeMoreColorsWin.ColorPickerChange(Sender: TObject);
begin
@ -132,23 +121,15 @@ begin
Params.Style := WS_CAPTION or WS_SIZEBOX or WS_SYSMENU;
Params.ExStyle := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
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);
begin
PickerNotebook.PageIndex := cbColorDisplay.ItemIndex;
SetAllCustom(NewSwatch.Color);
exit;
{
HSL.Visible := cbColorDisplay.ItemIndex = 0;
HSLRing.Visible := cbColorDisplay.ItemIndex = 1;
@ -162,55 +143,9 @@ begin
SLH.SelectedColor := NewSwatch.Color;
end;
function TOfficeMoreColorsWin.GetShowHint: Boolean;
begin
Result := inherited ShowHint;
end;
procedure TOfficeMoreColorsWin.HSLChange(Sender: TObject);
begin
if FLockChange <> 0 then
exit;
SetAllCustom(HSL.SelectedColor);
end;
procedure TOfficeMoreColorsWin.HSLRingChange(Sender: TObject);
begin
if FLockChange <> 0 then
exit;
SetAllCustom(HSLRing.SelectedColor);
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
if (EBlue.Text <> '') and EBlue.Focused then
begin
inc(FLockChange);
HSL.Blue := EBlue.Value;
@ -220,10 +155,21 @@ begin
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 {$IFDEF DELPHI} or EHue.Button.Focused{$ENDIF}) then
if (EHue.Text <> '') and EHue.Focused then
begin
inc(FLockChange);
HSL.Hue := EHue.Value;
@ -233,23 +179,9 @@ begin
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
if (ELum.Text <> '') and ELum.Focused then
begin
inc(FLockChange);
HSL.Luminance := ELum.Value;
@ -258,158 +190,28 @@ begin
end;
end;
procedure TOfficeMoreColorsWin.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure TOfficeMoreColorsWin.ERedChange(Sender: TObject);
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);
var
r,g,b: Integer;
h,s,l: Integer;
begin
NewSwatch.Hint := GetHint(NewSwatch.Color);
if (ERed = nil) or (EBlue = nil) or (EGreen = nil) or
(EHue = nil) or (ESat = nil) or (ELum = nil) or (FLockChange <> 0)
then
exit;
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;
procedure TOfficeMoreColorsWin.OldSwatchColorChange(Sender: TObject);
begin
OldSwatch.Hint := GetHint(OldSwatch.Color);
SetAllToSel(OldSwatch.Color);
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.SetAllCustom(c: TColor);
var
r, g, b: Integer;
h, s, l: Integer;
begin
if (ERed = nil) or (EGreen = nil) or (EBlue = nil) or
(EHue = nil) or (ESat = nil) or (ELum = nil) or
(PickerNotebook = nil) or (HSL = nil) or (HSLRing = nil) or (SLH = nil)
then
exit;
inc(FLockChange);
try
NewSwatch.Color := c;
r := GetRValue(c);
g := GetGValue(c);
b := GetBValue(c);
RGBtoHSLRange(c, h, s, l);
if PickerNotebook.ActivePage = nbHSL.Name then
HSL.SelectedColor := c
else
if PickerNotebook.ActivePage = nbHSLRing.Name then
HSLRing.SelectedColor := c
else
if PickerNotebook.ActivePage = nbSLH.Name then
SLH.SelectedColor := c
else
if PickerNotebook.ActivePage = nbRGB.Name then
if (ERed.Text <> '') and ERed.Focused then
begin
RTrackbar.SelectedColor := c;
GTrackbar.SelectedColor := c;
BTrackbar.SelectedColor := c;
end
else
exit; //raise Exception.Create('Notbook page not prepared for color pickers');
ERed.Value := r;
EGreen.Value := g;
EBlue.Value := b;
EHue.Value := h;
ESat.Value := s;
ELum.Value := l;
finally
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.SetShowHint(AValue: Boolean);
procedure TOfficeMoreColorsWin.ESatChange(Sender: TObject);
begin
inherited ShowHint := AValue;
// Unfortunately Notebook does not have a Hint and ParentHint...
HSL.ShowHint := AValue;
HSLRing.ShowHint := AValue;
SLH.ShowHint := AValue;
end;
procedure TOfficeMoreColorsWin.SLHChange(Sender: TObject);
begin
if FLockChange <> 0 then
exit;
SetAllCustom(SLH.SelectedColor);
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}
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);
@ -541,4 +343,154 @@ begin
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;
begin
Result := inherited ShowHint;
end;
procedure TOfficeMoreColorsWin.HexaChange(Sender: TObject);
begin
NewSwatch.Color := Hexa.SelectedColor;
end;
procedure TOfficeMoreColorsWin.HSLChange(Sender: TObject);
begin
if FLockChange <> 0 then
exit;
SetAllCustom(HSL.SelectedColor);
end;
procedure TOfficeMoreColorsWin.HSLRingChange(Sender: TObject);
begin
if FLockChange <> 0 then
exit;
SetAllCustom(HSLRing.SelectedColor);
end;
procedure TOfficeMoreColorsWin.NewSwatchColorChange(Sender: TObject);
var
r,g,b: Integer;
h,s,l: Integer;
begin
NewSwatch.Hint := GetHint(NewSwatch.Color);
if (ERed = nil) or (EBlue = nil) or (EGreen = nil) or
(EHue = nil) or (ESat = nil) or (ELum = nil) or (FLockChange <> 0)
then
exit;
SetAllCustom(NewSwatch.Color);
end;
procedure TOfficeMoreColorsWin.OldSwatchColorChange(Sender: TObject);
begin
OldSwatch.Hint := GetHint(OldSwatch.Color);
SetAllToSel(OldSwatch.Color);
end;
procedure TOfficeMoreColorsWin.PagesChange(Sender: TObject);
begin
SetAllToSel(NewSwatch.Color);
end;
procedure TOfficeMoreColorsWin.SetAllCustom(c: TColor);
var
r, g, b: Integer;
h, s, l: Integer;
begin
if (ERed = nil) or (EGreen = nil) or (EBlue = nil) or
(EHue = nil) or (ESat = nil) or (ELum = nil) or
(PickerNotebook = nil) or (HSL = nil) or (HSLRing = nil) or (SLH = nil)
then
exit;
inc(FLockChange);
try
NewSwatch.Color := c;
r := GetRValue(c);
g := GetGValue(c);
b := GetBValue(c);
RGBtoHSLRange(c, h, s, l);
if PickerNotebook.ActivePage = nbHSL.Name then
HSL.SelectedColor := c
else
if PickerNotebook.ActivePage = nbHSLRing.Name then
HSLRing.SelectedColor := c
else
if PickerNotebook.ActivePage = nbSLH.Name then
SLH.SelectedColor := c
else
if PickerNotebook.ActivePage = nbRGB.Name then
begin
RTrackbar.SelectedColor := c;
GTrackbar.SelectedColor := c;
BTrackbar.SelectedColor := c;
end
else
exit; //raise Exception.Create('Notbook page not prepared for color pickers');
ERed.Value := r;
EGreen.Value := g;
EBlue.Value := b;
EHue.Value := h;
ESat.Value := s;
ELum.Value := l;
finally
dec(FLockChange);
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);
begin
inherited ShowHint := AValue;
// Unfortunately Notebook does not have a Hint and ParentHint...
HSL.ShowHint := AValue;
HSLRing.ShowHint := AValue;
SLH.ShowHint := AValue;
end;
procedure TOfficeMoreColorsWin.SLHChange(Sender: TObject);
begin
if FLockChange <> 0 then
exit;
SetAllCustom(SLH.SelectedColor);
end;
end.

195
components/mbColorLib/RAxisColorPicker.pas
View File

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

198
components/mbColorLib/RColorPicker.pas
View File

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

359
components/mbColorLib/SLColorPicker.pas
View File

@ -1,17 +1,11 @@
unit SLColorPicker;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$MODE DELPHI}
interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
mbColorPickerControl;
@ -44,8 +38,6 @@ type
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
// procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
// message CN_KEYDOWN;
public
constructor Create(AOwner: TComponent); override;
function GetColorAtPoint(x, y: integer): TColor; override;
@ -77,12 +69,7 @@ begin
FMaxLum := 240;
FGradientWidth := FMaxSat + 1; // x --> Saturation
FGradientHeight := FMaxLum + 1; // y --> Luminance
{$IFDEF DELPHI}
Width := 255;
Height := 255;
{$ELSE}
SetInitialBounds(0, 0, FGradientWidth, FGradientHeight);
{$ENDIF}
FHue := 0.0;
FSat := 0.0;
FLum := 1.0;
@ -90,19 +77,6 @@ begin
MarkerStyle := msCircle;
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;
begin
inherited;
@ -110,12 +84,6 @@ begin
UpdateCoords;
end;
procedure TSLColorPicker.UpdateCoords;
begin
mdx := round(FSat * (Width - 1));
mdy := round((1.0 - FLum) * (Height - 1));
end;
procedure TSLColorPicker.DrawMarker(x, y: integer);
var
c: TColor;
@ -124,11 +92,18 @@ begin
InternalDrawMarker(x, y, c);
end;
procedure TSLColorPicker.Paint;
function TSLColorPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Canvas.StretchDraw(ClientRect, FBufferBMP);
UpdateCoords;
DrawMarker(mdx, mdy);
Result := HSLToRGB(FHue, x/(Width - 1), (Height - 1 - y) / (Height - 1));
if WebSafe then
Result := GetWebSafe(Result);
end;
{ This picker has Saturation along the X and Luminance along the Y axis. }
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;
function TSLColorPicker.GetHue: Integer;
@ -146,97 +121,13 @@ begin
Result := round(FSat * FMaxSat);
end;
procedure TSLColorPicker.SetHue(H: integer);
function TSLColorPicker.GetSelectedColor: TColor;
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;
Result := HSLtoRGB(FHue, FSat, FLum);
if WebSafe then
Result := GetWebSafe(Result);
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);
var
eraseKey: Boolean;
@ -291,30 +182,8 @@ begin
inherited;
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;
X, Y: Integer);
{$IFDEF DELPHI}
var
R: TRect;
{$ENDIF}
begin
inherited;
if csDesigning in ComponentState then
@ -323,15 +192,7 @@ begin
begin
mdx := x;
mdy := y;
{$IFDEF DELPHI}
R := ClientRect;
R.TopLeft := ClientToScreen(R.TopLeft);
R.BottomRight := ClientToScreen(R.BottomRight);
ClipCursor(@R);
{$ENDIF}
SelectionChanged(X, Y);
// FManual := true;
// if Assigned(FOnChange) then FOnChange(Self);
end;
SetFocus;
end;
@ -346,8 +207,118 @@ begin
mdx := x;
mdy := y;
SelectionChanged(X, Y);
// FManual := true;
// if Assigned(FOnChange) then FOnChange(Self);
end;
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;
@ -366,79 +337,11 @@ begin
FChange := true;
end;
function TSLColorPicker.GetSelectedColor: TColor;
procedure TSLColorPicker.UpdateCoords;
begin
Result := HSLtoRGB(FHue, FSat, FLum);
if WebSafe then
Result := GetWebSafe(Result);
mdx := round(FSat * (Width - 1));
mdy := round((1.0 - FLum) * (Height - 1));
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.

354
components/mbColorLib/SLHColorPicker.pas
View File

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

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

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

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

@ -190,28 +190,28 @@ uses
procedure TForm1.tb1Change(Sender: TObject);
begin
sc.opacity := tb1.position;
sc.opacity := tb1.position;
end;
procedure TForm1.tb2Change(Sender: TObject);
begin
uc.opacity := tb2.position;
uc.opacity := tb2.position;
end;
procedure TForm1.HSLColorPicker1Change(Sender: TObject);
begin
sc.color := HSLColorPicker1.SelectedColor;
sc.color := HSLColorPicker1.SelectedColor;
end;
procedure TForm1.HSLColorPicker1MouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
uc.color := HSLColorPicker1.ColorUnderCursor;
uc.color := HSLColorPicker1.ColorUnderCursor;
end;
procedure TForm1.HexaColorPicker1Change(Sender: TObject);
begin
sc.color := hexacolorpicker1.selectedcolor;
sc.color := hexacolorpicker1.selectedcolor;
end;
procedure TForm1.HexaColorPicker1MouseMove(Sender: TObject;
@ -227,28 +227,28 @@ end;
procedure TForm1.Button1Click(Sender: TObject);
begin
mbColorPalette1.GeneratePalette(clblue);
mbColorPalette1.GeneratePalette(clblue);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
mbColorpalette1.GenerateGradientPalette([clblue, clred]);
mbColorpalette1.GenerateGradientPalette([clblue, clred]);
end;
procedure TForm1.mbColorPalette1SelColorChange(Sender: TObject);
begin
uc.Color := mbColorPalette1.SelectedColor;
sc.Color := mbColorPalette1.SelectedColor;
end;
procedure TForm1.mbColorPalette1MouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
uc.color := mbcolorpalette1.ColorUnderCursor;
uc.color := mbcolorpalette1.ColorUnderCursor;
end;
procedure TForm1.HSLRingPicker1Change(Sender: TObject);
begin
sc.color := HSLRingPicker1.SelectedColor;
sc.color := HSLRingPicker1.SelectedColor;
end;
procedure TForm1.HSLRingPicker1MouseMove(Sender: TObject;
@ -259,9 +259,9 @@ end;
procedure TForm1.HSVColorPicker1Change(Sender: TObject);
begin
sc.color := HSVColorPicker1.SelectedColor;
VColorPicker2.Saturation := HSVColorPicker1.Saturation;
VColorPicker2.Hue := HSVColorPicker1.Hue;
sc.color := HSVColorPicker1.SelectedColor;
VColorPicker2.Saturation := HSVColorPicker1.Saturation;
VColorPicker2.Hue := HSVColorPicker1.Hue;
end;
procedure TForm1.HSVColorPicker1MouseMove(Sender: TObject;
@ -272,7 +272,7 @@ end;
procedure TForm1.SLHColorPicker1Change(Sender: TObject);
begin
sc.color := SLHColorPicker1.SelectedColor;
sc.color := SLHColorPicker1.SelectedColor;
end;
procedure TForm1.SLHColorPicker1MouseMove(Sender: TObject;
@ -283,8 +283,8 @@ end;
procedure TForm1.mbDeskPickerButton1SelColorChange(Sender: TObject);
begin
sc.color := mbDeskPickerButton1.SelectedColor;
uc.color := mbDeskPickerButton1.SelectedColor;
sc.color := mbDeskPickerButton1.SelectedColor;
uc.color := mbDeskPickerButton1.SelectedColor;
end;
procedure TForm1.PageControl1Change(Sender: TObject);
@ -333,18 +333,18 @@ end;
procedure TForm1.HRingPicker1Change(Sender: TObject);
begin
sc.color := hringpicker1.SelectedColor;
sc.color := hringpicker1.SelectedColor;
end;
procedure TForm1.HRingPicker1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
uc.color := hringpicker1.ColorUnderCursor;
uc.color := hringpicker1.ColorUnderCursor;
end;
procedure TForm1.VColorPicker2Change(Sender: TObject);
begin
HSVColorPicker1.Value := VColorPicker2.Value;
HSVColorPicker1.Value := VColorPicker2.Value;
end;
// only for internet shortcuts
@ -376,17 +376,17 @@ end;
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
HexaColorPicker1.SliderVisible := checkbox1.Checked;
HexaColorPicker1.SliderVisible := checkbox1.Checked;
end;
procedure TForm1.ComboBox1Change(Sender: TObject);
begin
hexacolorpicker1.SliderMarker := TMArker(ComboBox1.ItemIndex);
hexacolorpicker1.SliderMarker := TMArker(ComboBox1.ItemIndex);
end;
procedure TForm1.CheckBox2Click(Sender: TObject);
begin
hexacolorpicker1.NewArrowStyle := checkbox2.checked;
hexacolorpicker1.NewArrowStyle := checkbox2.checked;
end;
procedure TForm1.CIEAColorPicker1Change(Sender: TObject);
@ -412,17 +412,17 @@ end;
procedure TForm1.ComboBox2Change(Sender: TObject);
begin
mbcolorpalette1.SortOrder := tsortorder(combobox2.itemindex);
mbcolorpalette1.SortOrder := tsortorder(combobox2.itemindex);
end;
procedure TForm1.ComboBox3Change(Sender: TObject);
begin
mbcolorpalette1.Sortmode := tsortmode(combobox3.ItemIndex);
mbcolorpalette1.Sortmode := tsortmode(combobox3.ItemIndex);
end;
procedure TForm1.ComboBox4Change(Sender: TObject);
begin
mbcolorpalette1.CellStyle := tcellstyle(combobox4.ItemIndex);
mbcolorpalette1.CellStyle := tcellstyle(combobox4.ItemIndex);
end;
procedure TForm1.UpDown1ChangingEx(Sender: TObject; var AllowChange: Boolean;

197
components/mbColorLib/mbBasicPicker.pas
View File

@ -5,16 +5,10 @@ unit mbBasicPicker;
interface
uses
{$IFDEF FPC}
LMessages,
{$ELSE}
Messages,
{$ENDIF}
Classes, SysUtils, Graphics, Controls, ExtCtrls, Forms;
LMessages, Classes, SysUtils, Graphics, Controls, ExtCtrls, Forms;
type
THintState = (hsOff, hsWaitingToShow, hsWaitingToHide);
TGetHintStrEvent = procedure (Sender: TObject; X, Y: Integer; var AText: String) of object;
{ TmbBasicPicker }
@ -22,12 +16,6 @@ type
TmbBasicPicker = class(TCustomControl)
private
FOnGetHintStr: TGetHintStrEvent;
{
FHintWindow: THintWindow;
FHintTimer: TTimer;
FHintState: THintState;
procedure HintTimer(Sender: TObject);
}
protected
FBufferBmp: TBitmap;
FGradientWidth: Integer;
@ -39,20 +27,12 @@ type
function GetGradientColor2D(X, Y: Integer): TColor; virtual;
function GetHintPos(X, Y: Integer): TPoint; 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(ACanvas: TCanvas); overload;
procedure PaintParentBack(ACanvas: TCanvas; ARect: TRect); overload;
procedure PaintParentBack(ABitmap: TBitmap); overload;
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 WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
{$ENDIF}
property ColorUnderCursor: TColor read GetColorUnderCursor;
property OnGetHintStr: TGetHintStrEvent read FOnGetHintStr write FOnGetHintStr;
public
@ -61,7 +41,6 @@ type
function GetColorAtPoint(X, Y: Integer): TColor; virtual;
function GetHexColorAtPoint(X, Y: integer): string;
function GetHexColorUnderCursor: string; virtual;
// function GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; override;
published
property ParentColor default true;
end;
@ -72,22 +51,11 @@ uses
LCLIntf,
HTMLColors, mbUtils;
const
HINT_SHOW_DELAY = 50;
HINT_HIDE_DELAY = 3000;
constructor TmbBasicPicker.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// ControlStyle := ControlStyle - [csOpaque];
ParentColor := true;
{
FHintTimer := TTimer.Create(self);
FHintTimer.Interval := HINT_SHOW_DELAY;
FHintTimer.Enabled := false;
FHintTimer.OnTimer := @HintTimer;
FHintState := hsOff;
}
end;
destructor TmbBasicPicker.Destroy;
@ -152,22 +120,6 @@ begin
Result := GetColorAtPoint(P.X, P.Y);
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;
begin
Result := clNone;
@ -178,6 +130,16 @@ begin
Result := clNone;
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;
begin
Result := Point(X, Y);
@ -190,58 +152,6 @@ begin
FOnGetHintStr(Self, X, Y, Result);
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;
begin
PaintParentBack(Canvas);
@ -251,28 +161,13 @@ procedure TmbBasicPicker.PaintParentBack(ABitmap: TBitmap);
begin
ABitmap.Width := Width;
ABitmap.Height := Height;
{$IFNDEF DELPHI}
if Color = clDefault then begin
ABitmap.Transparent := true;
ABitmap.TransparentColor := clForm;
ABitmap.Canvas.Brush.Color := clForm; //GetDefaultColor(dctBrush)
ABitmap.Canvas.Brush.Color := clForm;
end else
{$ENDIF}
ABitmap.Canvas.Brush.Color := Color;
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;
procedure TmbBasicPicker.PaintParentBack(ACanvas: TCanvas);
@ -281,25 +176,6 @@ var
begin
R := Rect(0, 0, Width, Height);
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;
procedure TmbBasicPicker.PaintParentBack(ACanvas: TCanvas; ARect: TRect);
@ -308,10 +184,9 @@ var
begin
Offscreen := TBitmap.Create;
try
// Offscreen.PixelFormat := pf32bit;
if Color = clDefault then begin
Offscreen.Transparent := true;
Offscreen.TransparentColor := clForm; //GetDefaultColor(dctBrush);
Offscreen.TransparentColor := clForm;
end;
Offscreen.Width := WidthOfRect(ARect);
Offscreen.Height := HeightOfRect(ARect);
@ -321,52 +196,6 @@ begin
Offscreen.Free;
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.

507
components/mbColorLib/mbColorList.pas
View File

@ -2,26 +2,14 @@ unit mbColorList;
interface
{$I mxs.inc}
{$IFDEF FPC}{$MODE DELPHI}{$ENDIF}
{$MODE DELPHI}
uses
SysUtils,
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$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;
SysUtils, LCLIntf, LCLType, Classes, Controls, StdCtrls,
Graphics, GraphUtil, Forms, Themes,
HTMLColors, RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, PalUtils;
type
{$IFNDEF DELPHI_6_UP}
TScrollDirection = (sdLeft, sdRight, sdUp, sdDown);
{$ENDIF}
TmbColor = record
name: string;
value: TColor;
@ -43,35 +31,17 @@ type
Colors: array of TmbColor;
constructor Create(AOwner: TComponent); override;
procedure UpdateColors;
procedure AddColor(Name: string; Value: TColor; refresh: boolean = true);
procedure AddColor(AName: string; AValue: TColor; ARefresh: boolean = true);
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;
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
{$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 TabStop default True;
{$IFDEF DELPHI_7_UP}
{$IFDEF DELPHI}
property AutoComplete;
{$ENDIF}
property ScrollWidth;
{$ENDIF}
property Align;
property Anchors;
property BiDiMode;
@ -97,17 +67,9 @@ type
property Sorted;
property TabOrder;
property Visible;
property OnDrawCaption: TDrawCaptionEvent read FDraw write FDraw;
property OnGetHint: TGetHintEvent read FGetHint write FGetHint;
property OnContextPopup;
{$IFDEF DELPHI_7_UP}
{$IFDEF DELPHI}
property OnData;
property OnDataFind;
property OnDataObject;
{$ENDIF}
{$ENDIF}
property OnDblClick;
property OnDragDrop;
property OnDragOver;
@ -129,49 +91,9 @@ type
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);
begin
inherited;
{
MaxHue := 360;
MaxSat := 255;
MaxLum := 255;
}
style := lbOwnerDrawFixed;
SetLength(Colors, 0);
ItemHeight := 48;
@ -180,223 +102,19 @@ begin
my := -1;
end;
procedure TmbColorList.UpdateColors;
var
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);
procedure TmbColorList.AddColor(AName: string; AValue: TColor;
ARefresh: boolean = true);
var
l: integer;
begin
l := Length(Colors);
SetLength(Colors, l + 1);
Colors[l].name := Name;
Colors[l].value := Value;
if refresh then
Colors[l].name := AName;
Colors[l].value := AValue;
if ARefresh then
UpdateColors;
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);
var
Handled: boolean;
@ -426,4 +144,201 @@ begin
inherited;
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.

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

42
components/mbColorLib/mbColorPreview.pas
View File

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

418
components/mbColorLib/mbColorTree.pas
View File

@ -1,29 +1,15 @@
unit mbColorTree;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$MODE DELPHI}
interface
{$I mxs.inc}
uses
{$IFDEF FPC}
LCLIntf, LCLType,
{$ELSE}
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;
LCLIntf, LCLType, SysUtils, Classes, Controls, ComCtrls, Graphics, Themes,
GraphUtil, ImgList, Forms,
HTMLColors, RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils;
type
{$IFNDEF DELPHI_6_UP}
TScrollDirection = (sdLeft, sdRight, sdUp, sdDown);
{$ENDIF}
TmbColor = record
Name: string;
Value: TColor;
@ -46,30 +32,28 @@ type
procedure SetInfo1(Value: string);
procedure SetInfo2(Value: string);
procedure SetInfoLabel(Value: string);
protected
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;
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 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
Colors: array of TmbColor;
constructor Create(AOwner: TComponent); override;
procedure UpdateColors;
procedure AddColor(AName: string; AValue: TColor; ARefresh: boolean = true);
procedure ClearColors;
function ColorCount: integer;
procedure DeleteColor(AIndex: integer; ARefresh: boolean = true);
procedure DeleteColorByName(AName: string; All: boolean);
procedure DeleteColorByValue(AValue: TColor; All: boolean);
procedure InsertColor(AIndex: integer; AName: string; AValue: TColor);
function ColorCount: integer;
procedure UpdateColors;
published
property InfoLabelText: string read FInfoLabel write SetInfoLabel;
property InfoDisplay1: string read FInfo1 write SetInfo1;
@ -77,20 +61,8 @@ type
property Align;
property Anchors;
property AutoExpand;
{$IFDEF DELPHI}
property BevelEdges;
property BevelInner;
property BevelOuter;
property BevelKind default bkNone;
property BevelWidth;
{$ENDIF}
property BorderStyle;
property BorderWidth;
{$IFDEF DELPHI}
property ChangeDelay;
property Ctl3D;
property ParentCtl3D;
{$ENDIF}
property Constraints;
property Color;
property DragKind;
@ -99,10 +71,6 @@ type
property Enabled;
property Font;
property Indent;
{$IFDEF DELPHI_7_UP}
property MultiSelect;
property MultiSelectStyle;
{$ENDIF}
property ParentColor default False;
property ParentFont;
property ParentShowHint;
@ -119,10 +87,6 @@ type
property OnDrawInfoLabel: TDrawLabelEvent read FDraw1 write FDraw1;
property OnDrawInfoDisplay1: TDrawLabelEvent read FDraw2 write FDraw2;
property OnDrawInfoDisplay2: TDrawLabelEvent read FDraw3 write FDraw3;
{$IFDEF DELPHI_7_UP}
property OnAddition;
property OnCreateNodeClass;
{$ENDIF}
property OnAdvancedCustomDraw;
property OnAdvancedCustomDrawItem;
property OnChange;
@ -160,52 +124,12 @@ implementation
uses
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 }
constructor TmbColorTree.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle + [csDisplayDragImage];
{
MaxHue := 360;
MaxSat := 255;
MaxLum := 255;
}
ReadOnly := true;
ShowButtons := false;
ShowLines := false;
@ -221,64 +145,65 @@ begin
FInfo2 := 'HEX: #%hex';
end;
procedure TmbColorTree.UpdateColors;
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;
procedure TmbColorTree.CMHintShow(var Message: TCMHintShow);
var
Handled: boolean;
i: integer;
n: TTreeNode;
begin
Items.Clear;
for i := 0 to Length(Colors) - 1 do
if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then
begin
n := Items.Add(TopItem, Colors[i].name);
Items.AddChild(n, '');
n := GetNodeAt(mx, my);
if n <> nil then
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;
inherited;
end;
procedure TmbColorTree.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
r: TRect;
function TmbColorTree.ColorCount: integer;
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;
Result := Length(Colors);
end;
function TmbColorTree.CustomDrawItem(Node: TTreeNode; State: TCustomDrawState;
@ -292,6 +217,23 @@ begin
DrawInfoItem(Node.DisplayRect(false), node.Parent.Index);
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;
sel: boolean);
var
@ -324,8 +266,10 @@ begin
end;
end;
procedure TmbColorTree.DrawColorItem(R: TRect; Selected: boolean; Index: integer;
itemText: string; Expanded: boolean);
procedure TmbColorTree.DrawColorItem(R: TRect; Selected: boolean; AIndex: integer;
AItemText: string; Expanded: boolean);
const
FLAGS = DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS;
var
SR, TR: TRect;
begin
@ -343,27 +287,26 @@ begin
//swatches
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
begin
{$IFDEF DELPHI_7_UP}
if ThemeServices.ThemesEnabled then
begin
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
ThemeServices.DrawElement(Canvas.Handle,
ThemeServices.GetElementDetails(teEditTextNormal), SR);
InflateRect(SR, -2, -2);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80);
Brush.Color := Blend(Self.Colors[AIndex].value, clBlack, 80);
FillRect(SR);
InflateRect(SR, -1, -1);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 90);
Brush.Color := Blend(Self.Colors[AIndex].value, clBlack, 90);
FillRect(SR);
InflateRect(SR, -1, -1);
Brush.Color := Self.Colors[Index].value;
Brush.Color := Self.Colors[AIndex].value;
FillRect(SR);
end
else
//windows 9x
begin
{$ENDIF}
Pen.Color := clBackground;
Brush.Color := clWindow;
Rectangle(SR);
@ -371,45 +314,39 @@ begin
FillRect(SR);
InflateRect(SR, 1, 1);
InflateRect(SR, -2, -2);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 75);
Brush.Color := Blend(Self.Colors[AIndex].value, clBlack, 75);
FillRect(SR);
InflateRect(SR, -1, -1);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 87);
Brush.Color := Blend(Self.Colors[AIndex].value, clBlack, 87);
FillRect(SR);
InflateRect(SR, -1, -1);
Brush.Color := Self.Colors[Index].value;
Brush.Color := Self.Colors[AIndex].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;
Brush.Color := Self.Colors[AIndex].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;
Brush.Color := Self.Colors[AIndex].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];
@ -425,10 +362,10 @@ begin
Pen.Color := clWindowText;
Font.Color := clWindowText;
end;
TR := Rect(R.Left + 48, R.Top + (48 - TextHeight(itemText)) div 2, R.Right - 15, R.Bottom);
if Assigned(FDraw) then FDraw(Self, Index, Canvas.Font, itemText, Selected);
TR := Rect(R.Left + 48, R.Top + (48 - TextHeight(AItemText)) div 2, R.Right - 15, R.Bottom);
if Assigned(FDraw) then FDraw(Self, AIndex, Canvas.Font, AItemText, Selected);
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);
if R.Right > 60 then
begin
@ -496,11 +433,78 @@ begin
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
Result := true;
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);
begin
if FInfoLabel <> Value then
@ -528,30 +532,6 @@ begin
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);
var
i: integer;
@ -586,75 +566,17 @@ begin
UpdateColors;
end;
procedure TmbColorTree.DeleteColorByValue(AValue: TColor; All: boolean);
procedure TmbColorTree.UpdateColors;
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.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;
begin
if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then
Items.Clear;
for i := 0 to Length(Colors) - 1 do
begin
n := GetNodeAt(mx, my);
if n <> nil then
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;
n := Items.Add(TopItem, Colors[i].name);
Items.AddChild(n, '');
end;
end;
end;
inherited;
end;
end.

87
components/mbColorLib/mbDeskPickerButton.pas
View File

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

8
components/mbColorLib/mbOfficeColorDialog.pas
View File

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

678
components/mbColorLib/mbTrackBarPicker.pas
View File

@ -1,21 +1,13 @@
unit mbTrackBarPicker;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$MODE DELPHI}
interface
{$I mxs.inc}
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} ExtCtrls, PalUtils, mbBasicPicker;
LCLIntf, LCLType, LMessages, SysUtils, Classes, Controls, Graphics, Forms,
Themes, ExtCtrls,
PalUtils, mbBasicPicker;
const
TBA_Resize = 0;
@ -44,52 +36,47 @@ type
TmbTrackBarPicker = class(TmbBasicPicker)
private
mx, my: integer;
FOnChange: TNotifyEvent;
FIncrement: integer;
FHintFormat: string;
FPlacement: TSliderPlacement;
FNewArrowStyle: boolean;
Aw, Ah: integer;
FDoChange: boolean;
FSelIndicator: TSelIndicator;
FWebSafe: boolean;
mx, my: integer;
FBevelInner: TBevelCut;
FBevelOuter: TBevelCut;
FBevelWidth: TBevelWidth;
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 SetBevelOuter(Value: TBevelCut);
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 SetNewArrowStyle(s: boolean);
procedure SetPlacement(Value: TSliderPlacement);
procedure DrawMarker(p: integer);
procedure SetSelIndicator(Value: TSelIndicator);
procedure CalcPickRect;
procedure SetWebSafe(s: boolean);
function XToArrowPos(p: integer): integer;
function YToArrowPos(p: integer): integer;
protected
FArrowPos: integer;
FManual: boolean;
FBack: TBitmap;
FChange: boolean;
FPickRect: TRect;
FManual: boolean;
FLayout: TTrackBarLayout;
FLimit: integer;
FBack: TBitmap;
FPickRect: TRect;
procedure CreateGradient; override;
procedure CreateWnd; override;
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean; override;
procedure Paint; override;
// procedure PaintParentBack;
procedure DrawFrames; dynamic;
procedure Resize; override;
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); dynamic;
function GetArrowPos: integer; dynamic;
// function GetColorUnderCursor: TColor; override;
function GetHintPos(X, Y: Integer): TPoint; override;
function GetHintStr(X, Y: Integer): String; override;
function GetSelectedValue: integer; virtual; abstract;
@ -97,21 +84,12 @@ type
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseLeave; 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 WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
}
{$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 Paint; override;
procedure Resize; override;
procedure SetBorderStyle(Value: TBorderStyle); override;
procedure CMGotFocus(var Message: TLMessage); message CM_ENTER;
procedure CMLostFocus(var Message: TLMessage); message CM_EXIT;
{$ENDIF}
public
constructor Create(AOwner: TComponent); override;
@ -134,9 +112,6 @@ type
property ShowHint;
property Color;
property ParentColor;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
property ParentBackground default true;
{$ENDIF}{$ENDIF}
property ParentShowHint default true;
property Anchors;
property Align;
@ -172,9 +147,7 @@ type
implementation
uses
{$IFDEF FPC}
IntfGraphics, fpimage,
{$ENDIF}
ScanLines, HTMLColors;
const
@ -201,19 +174,18 @@ constructor TmbTrackBarPicker.Create(AOwner: TComponent);
begin
inherited;
//ControlStyle := ControlStyle - [csAcceptsControls]; // + [csOpaque]; // !!!!!!!!
DoubleBuffered := true;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF} {$ENDIF}
//DoubleBuffered := true;
Width := 267;
Height := 22;
TabStop := true;
ParentShowHint := true;
FGradientWidth := 256;
FGradientHeight := 1;
FBack := TBitmap.Create;
FGradientWidth := 256;
FGradientHeight := 12;
FBufferBmp := TBitmap.Create;
FBufferBmp.PixelFormat := pf32bit;
@ -222,8 +194,6 @@ begin
FIncrement := 1;
FArrowPos := GetArrowPos;
FHintFormat := '';
// OnMouseWheelUp := WheelUp;
// OnMouseWheelDown := WheelDown;
FManual := false;
FChange := true;
FLayout := lyHorizontal;
@ -236,10 +206,10 @@ begin
FSelIndicator := siArrows;
FLimit := 7;
FWebSafe := false;
FBevelInner:= bvNone;
FBevelOuter:= bvNone;
FBevelWidth:= 1;
FBorderStyle:= bsNone;
FBevelInner := bvNone;
FBevelOuter := bvNone;
FBevelWidth := 1;
FBorderStyle := bsNone;
end;
destructor TmbTrackbarPicker.Destroy;
@ -248,88 +218,6 @@ begin
inherited;
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;
var
f: integer;
@ -395,19 +283,98 @@ begin
end;
end;
procedure TmbTrackBarPicker.Paint;
procedure TmbTrackBarPicker.CMGotFocus(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF});
begin
CalcPickRect;
PaintParentBack(Canvas);
FArrowPos := GetArrowPos;
Execute(TBA_Paint);
if FBorderStyle <> bsNone then
DrawFrames;
DrawMarker(FArrowPos);
if FDoChange then
inherited;
Invalidate;
end;
procedure TmbTrackBarPicker.CMLostFocus(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF});
begin
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
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);
FDoChange := false;
end;
end;
@ -585,32 +552,37 @@ begin
end; // case FSelIndicator
end;
procedure TmbTrackBarPicker.Resize;
procedure TmbTrackBarPicker.Execute(tbaAction: integer);
begin
inherited;
FChange := false;
Execute(TBA_Resize);
FChange := true;
case tbaAction of
TBA_Paint : Canvas.StretchDraw(FPickRect, FBufferBmp);
TBA_RedoBMP : CreateGradient;
// Rest handled in descendants
end;
end;
function TmbTrackBarPicker.XToArrowPos(p: integer): integer;
var
pos: integer;
function TmbTrackBarPicker.GetArrowPos: integer;
begin
pos := p - Aw;
if pos < 0 then pos := 0;
if pos > Width - Aw - 1 then pos := Width - Aw - 1;
Result := pos;
Result := 0;
//handled in descendants
end;
function TmbTrackBarPicker.YToArrowPos(p: integer): integer;
var
pos: integer;
function TmbTrackBarPicker.GetHintPos(X, Y: Integer): TPoint;
begin
pos := p - Aw;
if pos < 0 then pos := 0;
if pos > Height - Aw - 1 then pos := Height - Aw - 1;
Result := pos;
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;
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;
procedure TmbTrackBarPicker.KeyDown(var Key: Word; Shift: TShiftState);
@ -685,6 +657,23 @@ begin
inherited;
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;
begin
inherited;
@ -716,28 +705,6 @@ begin
end;
inherited;
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);
begin
@ -758,209 +725,66 @@ begin
Invalidate;
inherited;
end;
(*
procedure TmbTrackBarPicker.CNKeyDown(
var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
var
Shift: TShiftState;
FInherited: boolean;
procedure TmbTrackBarPicker.Paint;
begin
FInherited := false;
Shift := KeyDataToShiftState(Message.KeyData);
case Message.CharCode of
VK_UP:
CalcPickRect;
PaintParentBack(Canvas);
FArrowPos := GetArrowPos;
Execute(TBA_Paint);
if FBorderStyle <> bsNone then
DrawFrames;
DrawMarker(FArrowPos);
if FDoChange then
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);
FDoChange := false;
end;
end;
function TmbTrackBarPicker.GetHintStr(X, Y: Integer): string;
procedure TmbTrackBarPicker.Resize;
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);
inherited;
FChange := false;
Execute(TBA_Resize);
FChange := true;
end;
(*
procedure TmbTrackBarPicker.CMHintShow(var Message: TCMHintShow);
var
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});
procedure TmbTrackBarPicker.SetBevelInner(Value: TBevelCut);
begin
inherited;
if FBevelInner <> Value then
begin
FBevelInner := Value;
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
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);
end;
end;
(*
procedure TmbTrackBarPicker.WheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure TmbTrackBarPicker.SetBevelOuter(Value: TBevelCut);
begin
Handled := true;
FChange := false;
Execute(TBA_WheelUp);
FManual := true;
FChange := true;
if Assigned(FOnChange) then FOnChange(Self);
if FBevelOuter <> Value then
begin
FBevelOuter := Value;
Invalidate;
end;
end;
procedure TmbTrackBarPicker.WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
procedure TmbTrackBarPicker.SetBorderStyle(Value: TBorderStyle);
begin
Handled := true;
FChange := false;
Execute(TBA_WheelDown);
FManual := true;
FChange := true;
if Assigned(FOnChange) then FOnChange(Self);
end; *)
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
defining the picker width and height because changing the layout will flip the
@ -977,15 +801,6 @@ begin
end;
end;
procedure TmbTrackBarPicker.SetPlacement(Value: TSliderPlacement);
begin
if FPlacement <> Value then
begin
FPlacement := Value;
Invalidate;
end;
end;
procedure TmbTrackBarPicker.SetNewArrowStyle(s: boolean);
begin
if FNewArrowStyle <> s then
@ -995,6 +810,15 @@ begin
end;
end;
procedure TmbTrackBarPicker.SetPlacement(Value: TSliderPlacement);
begin
if FPlacement <> Value then
begin
FPlacement := Value;
Invalidate;
end;
end;
procedure TmbTrackBarPicker.SetSelIndicator(Value: TSelIndicator);
begin
if FSelIndicator <> Value then
@ -1014,70 +838,24 @@ begin
end;
end;
procedure TmbTrackBarPicker.Execute(tbaAction: integer);
function TmbTrackBarPicker.XToArrowPos(p: integer): integer;
var
pos: integer;
begin
case tbaAction of
TBA_Paint : Canvas.StretchDraw(FPickRect, FBufferBmp);
TBA_RedoBMP : CreateGradient;
// Rest handled in descendants
end;
pos := p - Aw;
if pos < 0 then pos := 0;
if pos > Width - Aw - 1 then pos := Width - Aw - 1;
Result := pos;
end;
function TmbTrackBarPicker.GetArrowPos: integer;
function TmbTrackBarPicker.YToArrowPos(p: integer): integer;
var
pos: integer;
begin
Result := 0;
//handled in descendants
pos := p - Aw;
if pos < 0 then pos := 0;
if pos > Height - Aw - 1 then pos := Height - Aw - 1;
Result := pos;
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.

2
components/mbColorLib/mbcolorliblaz.lpk
View File

@ -14,7 +14,7 @@
</CompilerOptions>
<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."/>
<Version Major="2" Release="2"/>
<Version Major="2" Minor="1"/>
<Files Count="46">
<Item1>
<Filename Value="PalUtils.pas"/>