You've already forked lazarus-ccr
mbControls: Refactoring of the 2D gradients and code used in several units over again.
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5461 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
@ -9,238 +9,308 @@ 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}
|
||||
RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors, mbBasicPicker;
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType, LMessages,
|
||||
{$ELSE}
|
||||
Windows, Messages,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Controls, Graphics, Forms,
|
||||
{$IFDEF DELPHI_7_UP} Themes,{$ENDIF}
|
||||
RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors, mbBasicPicker;
|
||||
|
||||
type
|
||||
TMarkerStyle = (msCircle, msSquare, msCross, msCrossCirc);
|
||||
TMarkerStyle = (msCircle, msSquare, msCross, msCrossCirc);
|
||||
|
||||
TmbCustomPicker = class(TmbBasicPicker)
|
||||
private
|
||||
FHintFormat: string;
|
||||
FMarkerStyle: TMarkerStyle;
|
||||
FWebSafe: boolean;
|
||||
procedure SetMarkerStyle(s: TMarkerStyle);
|
||||
procedure SetWebSafe(s: boolean);
|
||||
protected
|
||||
mx, my, mdx, mdy: integer;
|
||||
function GetSelectedColor: TColor; virtual;
|
||||
procedure SetSelectedColor(C: TColor); virtual;
|
||||
procedure WebSafeChanged; dynamic;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure CreateWnd; override;
|
||||
procedure 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;
|
||||
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
|
||||
{$ELSE}
|
||||
procedure CMGotFocus(var Message: TLMessage); message CM_ENTER;
|
||||
procedure CMLostFocus(var Message: TLMessage); message CM_EXIT;
|
||||
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
|
||||
{$ENDIF}
|
||||
property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
TmbCustomPicker = class(TmbBasicPicker)
|
||||
private
|
||||
FHintFormat: string;
|
||||
FMarkerStyle: TMarkerStyle;
|
||||
FWebSafe: boolean;
|
||||
procedure SetMarkerStyle(s: TMarkerStyle);
|
||||
procedure SetWebSafe(s: boolean);
|
||||
protected
|
||||
FManual: Boolean;
|
||||
FSelected: TColor;
|
||||
mx, my, mdx, mdy: integer;
|
||||
FOnChange: TNotifyEvent;
|
||||
procedure CreateGradient; override;
|
||||
function GetSelectedColor: TColor; virtual;
|
||||
procedure SetSelectedColor(C: TColor); virtual;
|
||||
procedure InternalDrawMarker(X, Y: Integer; C: TColor);
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure CreateWnd; override;
|
||||
procedure WebSafeChanged; dynamic;
|
||||
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
|
||||
{$IFDEF DELPHI}
|
||||
procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER;
|
||||
procedure CMLostFocus(var Message: TCMLostFocus); message CM_EXIT;
|
||||
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
|
||||
{$ELSE}
|
||||
procedure CMGotFocus(var Message: TLMessage); message CM_ENTER;
|
||||
procedure CMLostFocus(var Message: TLMessage); message CM_EXIT;
|
||||
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
|
||||
{$ENDIF}
|
||||
property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle;
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
function GetColorAtPoint(x, y: integer): TColor; dynamic;
|
||||
function GetHexColorAtPoint(X, Y: integer): string;
|
||||
function GetColorUnderCursor: TColor;
|
||||
function GetHexColorUnderCursor: string;
|
||||
property ColorUnderCursor: TColor read GetColorUnderCursor;
|
||||
property Manual: boolean read FManual;
|
||||
published
|
||||
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor;
|
||||
property HintFormat: string read FHintFormat write FHintFormat;
|
||||
property WebSafe: boolean read FWebSafe write SetWebSafe default false;
|
||||
end;
|
||||
|
||||
function GetColorAtPoint(x, y: integer): TColor; dynamic;
|
||||
function GetHexColorAtPoint(X, Y: integer): string;
|
||||
function GetColorUnderCursor: TColor;
|
||||
function GetHexColorUnderCursor: string;
|
||||
|
||||
property ColorUnderCursor: TColor read GetColorUnderCursor;
|
||||
published
|
||||
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor;
|
||||
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 ShowHint;
|
||||
property ParentShowHint;
|
||||
property Visible;
|
||||
property Enabled;
|
||||
property PopupMenu;
|
||||
property TabOrder;
|
||||
property TabStop default true;
|
||||
property Color;
|
||||
property ParentColor;
|
||||
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
|
||||
property ParentBackground default true;
|
||||
{$ENDIF}{$ENDIF}
|
||||
property DragCursor;
|
||||
property DragMode;
|
||||
property DragKind;
|
||||
property Constraints;
|
||||
|
||||
property OnContextPopup;
|
||||
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;
|
||||
TmbColorPickerControl = class(TmbCustomPicker)
|
||||
published
|
||||
property Anchors;
|
||||
property Align;
|
||||
property ShowHint;
|
||||
property ParentShowHint;
|
||||
property Visible;
|
||||
property Enabled;
|
||||
property PopupMenu;
|
||||
property TabOrder;
|
||||
property TabStop default true;
|
||||
property Color;
|
||||
property ParentColor;
|
||||
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
|
||||
property ParentBackground default true;
|
||||
{$ENDIF}{$ENDIF}
|
||||
property DragCursor;
|
||||
property DragMode;
|
||||
property DragKind;
|
||||
property Constraints;
|
||||
property OnContextPopup;
|
||||
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;
|
||||
|
||||
implementation
|
||||
|
||||
uses PalUtils;
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
IntfGraphics, fpimage,
|
||||
{$ENDIF}
|
||||
ScanLines, PalUtils, SelPropUtils;
|
||||
|
||||
constructor TmbCustomPicker.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls];
|
||||
DoubleBuffered := true;
|
||||
TabStop := true;
|
||||
inherited;
|
||||
ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls];
|
||||
DoubleBuffered := true;
|
||||
TabStop := true;
|
||||
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
|
||||
ParentBackground := true;
|
||||
ParentBackground := true;
|
||||
{$ENDIF}{$ENDIF}
|
||||
mx := 0;
|
||||
my := 0;
|
||||
mdx := 0;
|
||||
mdy := 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;
|
||||
mx := 0;
|
||||
my := 0;
|
||||
mdx := 0;
|
||||
mdy := 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.CreateWnd;
|
||||
begin
|
||||
inherited;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.CMGotFocus(
|
||||
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF} );
|
||||
begin
|
||||
inherited;
|
||||
Invalidate;
|
||||
inherited;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.CMLostFocus(
|
||||
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF} );
|
||||
begin
|
||||
inherited;
|
||||
Invalidate;
|
||||
inherited;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.CMMouseLeave(
|
||||
var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
|
||||
begin
|
||||
mx := 0;
|
||||
my := 0;
|
||||
inherited;
|
||||
mx := 0;
|
||||
my := 0;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.CreateGradient;
|
||||
var
|
||||
// x, y, skip: integer;
|
||||
x, y: Integer;
|
||||
row: pRGBQuadArray;
|
||||
c: TColor;
|
||||
{$IFDEF FPC}
|
||||
intfimg: TLazIntfImage;
|
||||
imgHandle, imgMaskHandle: HBitmap;
|
||||
{$ENDIF}
|
||||
begin
|
||||
if FGradientBmp = nil then
|
||||
begin
|
||||
FGradientBmp := TBitmap.Create;
|
||||
FGradientBmp.PixelFormat := pf32bit;
|
||||
end;
|
||||
FGradientBmp.Width := FGradientWidth;
|
||||
FGradientBmp.Height := FGradientHeight;
|
||||
|
||||
{$IFDEF FPC}
|
||||
intfimg := TLazIntfImage.Create(FGradientBmp.Width, FGradientBmp.Height);
|
||||
try
|
||||
intfImg.LoadFromBitmap(FGradientBmp.Handle, FGradientBmp.MaskHandle);
|
||||
{$ENDIF}
|
||||
|
||||
for y := 0 to FGradientBmp.Height - 1 do
|
||||
begin
|
||||
{$IFDEF FPC}
|
||||
row := intfImg.GetDataLineStart(y); //FGradientBmp.Height - 1 - y);
|
||||
{$ELSE}
|
||||
row := FHSVBmp.Scanline(y); //FGradientBmp.Height - 1 - y);
|
||||
{$ENDIF}
|
||||
|
||||
for x := 0 to FGradientBmp.Width - 1 do
|
||||
begin
|
||||
c := GetGradientColor2D(x, y);
|
||||
if WebSafe then
|
||||
c := GetWebSafe(c);
|
||||
row[x] := RGBToRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
|
||||
end;
|
||||
end;
|
||||
|
||||
{$IFDEF FPC}
|
||||
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
|
||||
FGradientBmp.Handle := imgHandle;
|
||||
FGradientBmp.MaskHandle := imgMaskHandle;
|
||||
finally
|
||||
intfimg.Free;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function TmbCustomPicker.GetSelectedColor: TColor;
|
||||
begin
|
||||
Result := clNone;
|
||||
//handled in descendents
|
||||
Result := FSelected; // valid for most descendents
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.SetSelectedColor(C: TColor);
|
||||
begin
|
||||
//handled in descendents
|
||||
FSelected := C;
|
||||
//handled in descendents
|
||||
end;
|
||||
|
||||
function TmbCustomPicker.GetColorAtPoint(x, y: integer): TColor;
|
||||
begin
|
||||
Result := clNone;
|
||||
//handled in descendents
|
||||
Result := Canvas.Pixels[x, y]; // valid for most descendents
|
||||
end;
|
||||
|
||||
function TmbCustomPicker.GetHexColorAtPoint(X, Y: integer): string;
|
||||
begin
|
||||
Result := ColorToHex(GetColorAtPoint(x, y));
|
||||
Result := ColorToHex(GetColorAtPoint(x, y));
|
||||
end;
|
||||
|
||||
function TmbCustomPicker.GetColorUnderCursor: TColor;
|
||||
begin
|
||||
Result := GetColorAtPoint(mx, my);
|
||||
Result := GetColorAtPoint(mx, my);
|
||||
end;
|
||||
|
||||
function TmbCustomPicker.GetHexColorUnderCursor: string;
|
||||
begin
|
||||
Result := ColorToHex(GetColorAtPoint(mx, my));
|
||||
Result := ColorToHex(GetColorAtPoint(mx, my));
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.InternalDrawMarker(X, Y: Integer; C: TColor);
|
||||
begin
|
||||
case MarkerStyle of
|
||||
msCircle: DrawSelCirc(x, y, Canvas);
|
||||
msSquare: DrawSelSquare(x, y, Canvas);
|
||||
msCross: DrawSelCross(x, y, Canvas, c);
|
||||
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.CMHintShow(var Message: TCMHintShow);
|
||||
begin
|
||||
if GetColorUnderCursor <> clNone then
|
||||
with TCMHintShow(Message) do
|
||||
if not ShowHint then
|
||||
Message.Result := 1
|
||||
else
|
||||
with HintInfo^ do
|
||||
begin
|
||||
Result := 0;
|
||||
ReshowTimeout := 1;
|
||||
HideTimeout := 5000;
|
||||
HintStr := FormatHint(FHintFormat, GetColorUnderCursor);;
|
||||
end;
|
||||
inherited;
|
||||
if GetColorUnderCursor <> clNone then
|
||||
with TCMHintShow(Message) do
|
||||
if not ShowHint then
|
||||
Message.Result := 1
|
||||
else
|
||||
with HintInfo^ do
|
||||
begin
|
||||
Result := 0;
|
||||
ReshowTimeout := 1;
|
||||
HideTimeout := 5000;
|
||||
HintStr := FormatHint(FHintFormat, GetColorUnderCursor);;
|
||||
end;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
inherited;
|
||||
mx := x;
|
||||
my := y;
|
||||
inherited;
|
||||
mx := x;
|
||||
my := y;
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: Integer);
|
||||
X, Y: Integer);
|
||||
begin
|
||||
inherited;
|
||||
mx := x;
|
||||
my := y;
|
||||
inherited;
|
||||
mx := x;
|
||||
my := y;
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
||||
X, Y: Integer);
|
||||
X, Y: Integer);
|
||||
begin
|
||||
inherited;
|
||||
mx := x;
|
||||
my := y;
|
||||
inherited;
|
||||
mx := x;
|
||||
my := y;
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.SetMarkerStyle(s: TMarkerStyle);
|
||||
begin
|
||||
if FMarkerStyle <> s then
|
||||
if FMarkerStyle <> s then
|
||||
begin
|
||||
FMarkerStyle := s;
|
||||
invalidate;
|
||||
FMarkerStyle := s;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.SetWebSafe(s: boolean);
|
||||
begin
|
||||
if FWebSafe <> s then
|
||||
if FWebSafe <> s then
|
||||
begin
|
||||
FWebSafe := s;
|
||||
WebSafeChanged;
|
||||
FWebSafe := s;
|
||||
WebSafeChanged;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbCustomPicker.WebSafeChanged;
|
||||
begin
|
||||
//handled in descendents
|
||||
CreateGradient;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
Reference in New Issue
Block a user