1
0
Files
aarre
applications
bindings
components
ZVDateTimeCtrls
aboutcomponent
acs
beepfp
callite
chelper
cmdline
cmdlinecfg
colorpalette
cryptini
csvdocument
epiktimer
flashfiler
fpsound
fpspreadsheet
fractions
freetypepascal
geckoport
gradcontrols
industrialstuff
iosdesigner
iphonelazext
jujiboutils
jvcllaz
kcontrols
lazautoupdate
lazbarcodes
lclextensions
longtimer
manualdock
mbColorLib
examples
BAxisColorPicker.pas
BColorPicker.pas
CColorPicker.pas
CIEAColorPicker.pas
CIEBColorPicker.pas
CIELColorPicker.pas
GAxisColorPicker.pas
GColorPicker.pas
HColorPicker.pas
HRingPicker.pas
HSCirclePicker.pas
HSColorPicker.pas
HSLColorPicker.pas
HSLRingPicker.pas
HTMLColors.pas
HexaColorPicker.pas
KColorPicker.pas
LVColorPicker.pas
MColorPicker.pas
OfficeMoreColorsDialog.lfm
OfficeMoreColorsDialog.pas
PalUtils.pas
PickCursor.res
RAxisColorPicker.pas
RColorPicker.pas
RGBCIEUtils.pas
RGBCMYKUtils.pas
RGBHSLUtils.pas
RGBHSVUtils.pas
Readme.rtf
SColorPicker.pas
SLColorPicker.pas
SLHColorPicker.pas
Scanlines.pas
ScreenWin.lfm
ScreenWin.pas
SelPropUtils.pas
XPLibIntegration.txt
YColorPicker.pas
clean.bat
clear history.bat
mbBasicPicker.pas
mbColorLibD10.dpk
mbColorLibD5.dpk
mbColorLibD7.dpk
mbColorLibD9.dpk
mbColorList.pas
mbColorPalette.pas
mbColorPickerControl.pas
mbColorPreview.pas
mbColorTree.pas
mbDeskPickerButton.pas
mbOfficeColorDialog.pas
mbReg.lrs
mbReg.pas
mbTrackBarPicker.pas
mbcolorconv.pas
mbcolorliblaz.lpk
mbutils.pas
mxs.inc
mplayer
multithreadprocs
nvidia-widgets
onguard
orpheus
playsoundpackage
poweredby
powerpdf
rgbgraphics
richmemo
richview
rtfview
rx
scrolltext
smnetgradient
spktoolbar
svn
tdi
thtmlport
tparadoxdataset
tvplanit
virtualtreeview
virtualtreeview-new
xdev_toolkit
zlibar
examples
lclbindings
wst
lazarus-ccr/components/mbColorLib/mbColorPickerControl.pas

544 lines
13 KiB
ObjectPascal
Raw Normal View History

unit mbColorPickerControl;
{$MODE DELPHI}
interface
uses
LCLIntf, LCLType, LMessages, SysUtils, Classes, Controls, Graphics, Forms, Themes,
HTMLColors, mbColorConv, mbBasicPicker;
type
TMarkerStyle = (msCircle, msSquare, msCross, msCrossCirc);
{ TmbCustomPicker }
TmbCustomPicker = class(TmbBasicPicker)
private
FHintFormat: string;
FMarkerStyle: TMarkerStyle;
FWebSafe: boolean;
procedure SetMarkerStyle(s: TMarkerStyle);
procedure SetWebSafe(s: boolean);
protected
FSelected: TColor;
mx, my: integer;
procedure CreateGradient; override;
function GetHintStr({%H-}X, {%H-}Y: Integer): String; override;
function GetSelectedColor: TColor; override;
procedure InternalDrawMarker(X, Y: Integer; C: TColor);
procedure SetSelectedColor(C: TColor); override;
procedure WebSafeChanged; dynamic;
procedure CMGotFocus(var Message: TLMessage); message CM_ENTER;
procedure CMLostFocus(var Message: TLMessage); message CM_EXIT;
// procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle;
public
constructor Create(AOwner: TComponent); override;
property ColorUnderCursor;
published
property HintFormat: string read FHintFormat write FHintFormat;
property WebSafe: boolean read FWebSafe write SetWebSafe default false;
end;
TmbColorPickerControl = class(TmbCustomPicker)
published
property Anchors;
property Align;
property BorderSpacing;
property ShowHint;
property ParentShowHint;
property Visible;
property Enabled;
property PopupMenu;
property TabOrder;
property TabStop default true;
property Color;
property ParentColor;
property DragCursor;
property DragMode;
property DragKind;
property Constraints;
property OnContextPopup;
property OnGetHintStr;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnResize;
property OnStartDrag;
end;
TmbHSLVColorPickerControl = class(TmbColorPickerControl)
private
FBrightnessMode: TBrightnessMode;
function GetHue: Integer;
function GetLum: Integer;
function GetSat: Integer;
function GetVal: Integer;
function GetRed: Integer;
function GetGreen: Integer;
function GetBlue: Integer;
procedure SetHue(h: integer);
procedure SetLum(L: Integer);
procedure SetSat(s: integer);
procedure SetVal(v: integer);
procedure SetRed(R: Integer);
procedure SetGreen(G: Integer);
procedure SetBlue(B: Integer);
protected
FHue, FSat, FLum, FVal: Double;
FMaxHue, FMaxSat, FMaxLum, FMaxVal: Integer;
procedure ColorToHSLV(c: TColor; var H, S, L, V: Double);
procedure CorrectCoords(var x, y: integer);
function HSLVtoColor(H, S, L, V: Double): TColor;
procedure KeyDown(var Key: Word; Shift: TShiftState); 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 SelectColor({%H-}x, {%H-}y: Integer); virtual;
procedure SetBrightnessMode(AMode: TBrightnessMode); virtual;
procedure SetMaxHue(H: Integer); virtual;
procedure SetMaxLum(L: Integer); virtual;
procedure SetMaxSat(S: Integer); virtual;
procedure SetMaxVal(V: Integer); virtual;
procedure SetRelHue(H: Double); virtual;
procedure SetRelLum(L: Double); virtual;
procedure SetRelSat(S: Double); virtual;
procedure SetRelVal(V: Double); virtual;
public
constructor Create(AOwner: TComponent); override;
property RelHue: Double read FHue write SetRelHue;
property RelSaturation: Double read FSat write SetRelSat;
property RelLuminance: Double read FLum write SetRelLum;
property RelValue: Double read FVal write SetRelVal;
property Red: Integer read GetRed write SetRed;
property Green: Integer read GetGreen write SetGreen;
property Blue: Integer read GetBlue write SetBlue;
published
property BrightnessMode: TBrightnessMode
read FBrightnessMode write SetBrightnessMode default bmLuminance;
property Hue: integer read GetHue write SetHue;
property Luminance: Integer read GetLum write SetLum;
property Saturation: integer read GetSat write SetSat;
property Value: integer read GetVal write SetVal;
property MaxHue: Integer read FMaxHue write SetMaxHue default 360;
property MaxSaturation: Integer read FMaxSat write SetMaxSat default 255;
property MaxLuminance: Integer read FMaxLum write SetMaxLum default 255;
property MaxValue: Integer read FMaxVal write SetMaxVal default 255;
end;
implementation
uses
Math, IntfGraphics, fpimage,
PalUtils, SelPropUtils, mbUtils;
constructor TmbCustomPicker.Create(AOwner: TComponent);
begin
inherited;
//ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls];
TabStop := true;
mx := 0;
my := 0;
FHintFormat := 'Hex #%hex'#10#13'RGB[%r, %g, %b]'#10#13'HSL[%hslH, %hslS, %hslL]'#10#13'HSV[%hsvH, %hsvS, %hsvV]'#10#13'CMYK[%c, %m, %y, %k]'#10#13'L*a*b*[%cieL, %cieA, %cieB]'#10#13'XYZ[%cieX, %cieY, %cieZ]';
FWebSafe := false;
end;
procedure TmbCustomPicker.CMGotFocus(var Message: TLMessage);
begin
inherited;
Invalidate;
end;
procedure TmbCustomPicker.CMLostFocus(var Message: TLMessage);
begin
inherited;
Invalidate;
end;
(*
procedure TmbCustomPicker.CMMouseLeave(var Message: TLMessage);
begin
mx := 0;
my := 0;
inherited;
end;
*)
procedure TmbCustomPicker.CreateGradient;
var
x, y: Integer;
col: TColor;
fpcol: TFPColor;
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
begin
if FBufferBmp = nil then
begin
FBufferBmp := TBitmap.Create;
// FBufferBmp.PixelFormat := pf32bit;
end;
FBufferBmp.Width := FGradientWidth;
FBufferBmp.Height := FGradientHeight;
intfimg := TLazIntfImage.Create(FBufferBmp.Width, FBufferBmp.Height);
try
intfImg.LoadFromBitmap(FBufferBmp.Handle, FBufferBmp.MaskHandle);
for y := 0 to FBufferBmp.Height - 1 do
begin
for x := 0 to FBufferBmp.Width - 1 do
begin
col := GetGradientColor2D(x, y);
if WebSafe then
col := GetWebSafe(col);
fpcol := TColorToFPColor(col);
intfImg.Colors[x, y] := fpcol;
end;
end;
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBufferBmp.Handle := imgHandle;
FBufferBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
end;
function TmbCustomPicker.GetHintStr(X, Y: Integer): String;
begin
Result := FormatHint(FHintFormat, GetColorUnderCursor);
end;
function TmbCustomPicker.GetSelectedColor: TColor;
begin
Result := FSelected; // valid for most descendents
end;
procedure TmbCustomPicker.InternalDrawMarker(X, Y: Integer; C: TColor);
begin
case MarkerStyle of
msCircle : DrawSelCirc(x, y, Canvas);
msSquare : DrawSelSquare(x, y, Canvas);
msCross : DrawSelCross(x, y, Canvas, c);
msCrossCirc : DrawSelCrossCirc(x, y, Canvas, c);
end;
end;
procedure TmbCustomPicker.SetMarkerStyle(s: TMarkerStyle);
begin
if FMarkerStyle <> s then
begin
FMarkerStyle := s;
Invalidate;
end;
end;
procedure TmbCustomPicker.SetSelectedColor(C: TColor);
begin
FSelected := C;
//handled in descendents
end;
procedure TmbCustomPicker.SetWebSafe(s: boolean);
begin
if FWebSafe <> s then
begin
FWebSafe := s;
WebSafeChanged;
end;
end;
procedure TmbCustomPicker.WebSafeChanged;
begin
CreateGradient;
Invalidate;
end;
{ TmbHSLVColorPickerControl }
constructor TmbHSLVColorPickerControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBrightnessMode := bmLuminance;
FMaxHue := 360;
FMaxSat := 255;
FMaxVal := 255;
FMaxLum := 255;
end;
procedure TmbHSLVColorPickerControl.ColorToHSLV(c: TColor;
var H, S, L, V: Double);
begin
case FBrightnessMode of
bmLuminance : ColorToHSL(c, H, S, L);
bmValue : ColorToHSV(c, H, S, V);
end;
end;
procedure TmbHSLVColorPickerControl.CorrectCoords(var x, y: integer);
begin
Clamp(x, 0, Width - 1);
Clamp(y, 0, Height - 1);
end;
function TmbHSLVColorPickerControl.GetBlue: Integer;
begin
Result := GetBValue(GetSelectedColor);
end;
function TmbHSLVColorPickerControl.GetGreen: Integer;
begin
Result := GetGValue(GetSelectedColor);
end;
function TmbHSLVColorPickerControl.GetHue: Integer;
begin
Result := Round(FHue * FMaxHue);
end;
function TmbHSLVColorPickerControl.GetLum: Integer;
begin
Result := Round(FLum * FMaxLum);
end;
function TmbHSLVColorPickerControl.GetRed: Integer;
begin
Result := GetRValue(GetSelectedColor);
end;
function TmbHSLVColorPickerControl.GetSat: Integer;
begin
Result := Round(FSat * FMaxSat);
end;
function TmbHSLVColorPickerControl.GetVal: Integer;
begin
Result := Round(FVal * FMaxVal);
end;
function TmbHSLVColorPickerControl.HSLVtoColor(H, S, L, V: Double): TColor;
begin
case FBrightnessMode of
bmLuminance : Result := HSLToColor(H, S, L);
bmValue : Result := HSVtoColor(H, S, V);
end;
if WebSafe then
Result := GetWebSafe(Result);
end;
procedure TmbHSLVColorPickerControl.KeyDown(var Key: Word; Shift: TShiftState);
var
eraseKey: Boolean;
delta: Integer;
begin
eraseKey := true;
delta := IfThen(ssCtrl in Shift, 10, 1);
case Key of
VK_LEFT : SelectColor(mx - delta, my);
VK_RIGHT : SelectColor(mx + delta, my);
VK_UP : SelectColor(mx, my - delta);
VK_DOWN : SelectColor(mx, my + delta);
else eraseKey := false;
end;
if eraseKey then
Key := 0;
inherited;
end;
procedure TmbHSLVColorPickerControl.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
if csDesigning in ComponentState then
Exit;
if Button = mbLeft then
SelectColor(x, y);
SetFocus;
end;
procedure TmbHSLVColorPickerControl.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
if csDesigning in ComponentState then
Exit;
if ssLeft in Shift then
SelectColor(x, y);
end;
procedure TmbHSLVColorPickerControl.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
begin
inherited;
if csDesigning in ComponentState then
Exit;
if Button = mbLeft then
SelectColor(x, y);
end;
procedure TmbHSLVColorPickerControl.SelectColor(x, y: Integer);
begin
end;
procedure TmbHSLVColorPickerControl.SetBlue(B: Integer);
begin
Clamp(B, 0, 255);
SetSelectedColor(RgbToColor(Red, Green, B));
end;
procedure TmbHSLVColorPickerControl.SetBrightnessMode(AMode: TBrightnessMode);
var
c: TColor;
begin
c := HSLVtoColor(FHue, FSat, FLum, FVal);
FBrightnessMode := AMode;
ColorToHSLV(c, FHue, FSat, FLum, FVal);
CreateGradient;
Invalidate;
DoChange;
end;
procedure TmbHSLVColorPickerControl.SetGreen(G: Integer);
begin
Clamp(G, 0, 255);
SetSelectedColor(RgbToColor(Red, G, Blue));
end;
procedure TmbHSLVColorPickerControl.SetHue(H: Integer);
begin
SetRelHue(H / FMaxHue);
end;
procedure TmbHSLVColorPickerControl.SetLum(L: Integer);
begin
SetRelLum(L / FMaxLum);
end;
procedure TmbHSLVColorPickerControl.SetMaxHue(h: Integer);
begin
if h = FMaxHue then
exit;
FMaxHue := h;
CreateGradient;
Invalidate;
end;
procedure TmbHSLVColorPickerControl.SetMaxLum(L: Integer);
begin
if L = FMaxLum then
exit;
FMaxLum := L;
if BrightnessMode = bmLuminance then begin
CreateGradient;
Invalidate;
end;
end;
procedure TmbHSLVColorPickerControl.SetMaxSat(S: Integer);
begin
if S = FMaxSat then
exit;
FMaxSat := S;
CreateGradient;
Invalidate;
end;
procedure TmbHSLVColorPickerControl.SetMaxVal(V: Integer);
begin
if V = FMaxVal then
exit;
FMaxVal := V;
if BrightnessMode = bmLuminance then
begin
CreateGradient;
Invalidate;
end;
end;
procedure TmbHSLVColorPickerControl.SetRed(R: Integer);
begin
Clamp(R, 0, 255);
SetSelectedColor(RgbToColor(R, Green, Blue));
end;
procedure TmbHSLVColorPickerControl.SetRelHue(H: Double);
begin
Clamp(H, 0, 1.0);
if FHue <> H then
begin
FHue := H;
FSelected := HSLVtoColor(FHue, FSat, FLum, FVal);
CreateGradient;
Invalidate;
DoChange;
end;
end;
procedure TmbHSLVColorPickerControl.SetRelLum(L: Double);
begin
Clamp(L, 0, 1.0);
if FLum <> L then
begin
FLum := L;
FSelected := HSLVtoColor(FHue, FSat, FLum, FVal);
if BrightnessMode = bmLuminance then begin
CreateGradient;
Invalidate;
end;
DoChange;
end;
end;
procedure TmbHSLVColorPickerControl.SetRelSat(S: Double);
begin
Clamp(S, 0, 1.0);
if FSat <> S then
begin
FSat := S;
FSelected := HSLVtoColor(FHue, FSat, FLum, FVal);
CreateGradient;
Invalidate;
DoChange;
end;
end;
procedure TmbHSLVColorPickerControl.SetRelVal(V: Double);
begin
Clamp(v, 0, 1.0);
if FVal <> V then
begin
FVal := V;
if BrightnessMode = bmValue then
begin
FSelected := HSLVtoColor(FHue, FSat, FLum, FVal);
CreateGradient;
Invalidate;
end;
DoChange;
end;
end;
procedure TmbHSLVColorPickerControl.SetSat(S: Integer);
begin
SetRelSat(S / FMaxSat);
end;
procedure TmbHSLVColorPickerControl.SetVal(V: Integer);
begin
SetRelVal(V / FMaxVal);
end;
end.