mbColorLib: Improved handling of hints.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5464 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2016-12-12 12:51:46 +00:00
parent cecf6d3ca1
commit 5221fae91e
19 changed files with 242 additions and 55 deletions

View File

@ -65,7 +65,7 @@ begin
FChange := false;
Layout := lyVertical;
SetBlue(255);
HintFormat := 'Blue: %value';
HintFormat := 'Blue: %value (selected)';
FManual := false;
FChange := true;
end;

View File

@ -63,7 +63,7 @@ begin
FChange := false;
Layout := lyVertical;
SetCyan(255);
HintFormat := 'Cyan: %value';
HintFormat := 'Selected cyan value: %value';
FManual := false;
FChange := true;
end;

View File

@ -58,7 +58,7 @@ begin
FChange := false;
Layout := lyVertical;
SetGreen(255);
HintFormat := 'Green: %value';
HintFormat := 'Green: %value (selected)';
FManual := false;
FChange := true;
end;

View File

@ -58,7 +58,7 @@ begin
FArrowPos := ArrowPosFromHue(0);
FChange := false;
SetHue(0);
HintFormat := 'Hue: %value';
HintFormat := 'Hue: %value (selected)';
FManual := false;
FChange := true;
end;

View File

@ -45,6 +45,7 @@ type
procedure CreateWnd; 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 MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
@ -87,6 +88,7 @@ begin
FChange := true;
FRadius := 40;
FDoChange := false;
HintFormat := 'Hue: %h (selected)';
end;
procedure THRingPicker.CreateGradient;
@ -336,6 +338,18 @@ begin
SetFocus;
end;
function THRingPicker.MouseOnPicker(X, Y: Integer): Boolean;
var
diameter, r: Integer;
P, ctr: TPoint;
begin
diameter := Min(Width, Height);
r := diameter div 2; // outer radius
P := Point(x, y);
ctr := Point(r, r);
Result := PtInCircle(P, ctr, r) and not PtInCircle(P, ctr, Radius);
end;
procedure THRingPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;

View File

@ -128,13 +128,14 @@ begin
FLCursor := crDefault;
with FHSPicker do
begin
SetInitialBounds(0, 6, 174, 134);
{
Height := 134;
Width := 174;
Top := 6;
{$IFDEF DELPHI}
Left := 0;
}
Top := 6;
Width := 174;
Height := 134;
{$ELSE}
SetInitialBounds(0, 6, 174, 134);
{$ENDIF}
Anchors := [akLeft, akTop, akRight, akBottom];
Visible := true;
OnChange := HSPickerChange;
@ -145,12 +146,14 @@ begin
with FLPicker do
begin
Layout := lyVertical;
SetInitialBounds(184, 0, 25, 146);
{
Height := 146;
Top := 0;
{$IFDEF DELPHI}
Left := 184;
}
Top := 0;
Width := 25;
Height := 146;
{$ELSE}
SetInitialBounds(184, 0, 25, 146);
{$ENDIF}
Anchors := [akRight, akTop, akBottom];
Visible := true;
OnChange := LPickerChange;

View File

@ -51,6 +51,7 @@ type
procedure CreateWnd; 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 MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
@ -417,6 +418,18 @@ begin
end;
end;
function THSVColorPicker.MouseOnPicker(X, Y: Integer): Boolean;
var
diameter, r: Integer;
P, ctr: TPoint;
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

View File

@ -63,7 +63,7 @@ begin
FChange := false;
Layout := lyVertical;
SetBlack(255);
HintFormat := 'Black: %value';
HintFormat := 'Black: %value (selected)';
FManual := false;
FChange := true;
end;

View File

@ -57,7 +57,7 @@ begin
FArrowPos := ArrowPosFromLum(MaxLum div 2);
FChange := false;
SetLuminance(MaxLum div 2);
HintFormat := 'Luminance: %value';
HintFormat := 'Luminance: %value (selected)';
FManual := false;
FChange := true;
end;

View File

@ -63,7 +63,7 @@ begin
FChange := false;
Layout := lyVertical;
SetMagenta(255);
HintFormat := 'Magenta: %value';
HintFormat := 'Magenta: %value (selected)';
FManual := false;
FChange := true;
end;

View File

@ -65,7 +65,7 @@ begin
FChange := false;
Layout := lyVertical;
SetRed(255);
HintFormat := 'Red: %value';
HintFormat := 'Red: %value (selected)';
FManual := false;
FChange := true;
end;

View File

@ -58,7 +58,7 @@ begin
FArrowPos := ArrowPosFromSat(0);
FChange := false;
SetSat(255);
HintFormat := 'Saturation: %value';
HintFormat := 'Saturation: %value (selected)';
FManual := false;
FChange := true;
end;

View File

@ -54,7 +54,7 @@ begin
FArrowPos := ArrowPosFromVal(255);
FChange := false;
SetValue(255);
HintFormat := 'Value: %value';
HintFormat := 'Value: %value (selected)';
FManual := false;
FChange := true;
end;

View File

@ -64,7 +64,7 @@ begin
FChange := false;
Layout := lyVertical;
SetYellow(255);
HintFormat := 'Yellow: %value';
HintFormat := 'Yellow: %value (selected)';
FManual := false;
FChange := true;
end;

View File

@ -42,9 +42,9 @@ object Form1: TForm1
Height = 331
Top = 6
Width = 399
ActivePage = TabSheet1
ActivePage = TabSheet8
Anchors = [akTop, akLeft, akRight, akBottom]
TabIndex = 0
TabIndex = 8
TabOrder = 0
OnMouseMove = PageControl1MouseMove
object TabSheet1: TTabSheet
@ -56,7 +56,7 @@ object Form1: TForm1
Height = 287
Top = 8
Width = 377
SelectedColor = 424966
SelectedColor = 422918
HSPickerHintFormat = 'H: %h S: %s'#13'Hex: %hex'
LPickerHintFormat = 'Luminance: %l'
Anchors = [akTop, akLeft, akRight, akBottom]
@ -218,7 +218,7 @@ object Form1: TForm1
Left = 0
Height = 234
Top = 0
Width = 364
Width = 360
Align = alTop
Colors.Strings = (
'clBlack'
@ -605,7 +605,7 @@ object Form1: TForm1
Height = 302
Top = 2
Width = 22
HintFormat = 'Value: %v'
HintFormat = 'Value: %v (selected)'
Layout = lyVertical
NewArrowStyle = True
Anchors = [akTop, akRight, akBottom]
@ -624,7 +624,7 @@ object Form1: TForm1
Height = 291
Top = 6
Width = 381
HPickerHintFormat = 'Hue: %h'
HPickerHintFormat = 'Hue: %h (selected)'
SLPickerHintFormat = 'S: %s L: %l'#13'Hex: %hex'
Anchors = [akTop, akLeft, akRight, akBottom]
TabOrder = 0
@ -702,7 +702,7 @@ object Form1: TForm1
Height = 25
Top = 192
Width = 343
HintFormat = 'Luminance: %l'
HintFormat = 'Luminance: %l (selected)'
SelectionIndicator = siRect
Anchors = [akLeft, akRight, akBottom]
TabOrder = 2
@ -715,7 +715,7 @@ object Form1: TForm1
Height = 21
Top = 160
Width = 343
HintFormat = 'Value: %v'
HintFormat = 'Value: %v (selected)'
ArrowPlacement = spBefore
NewArrowStyle = True
SelectionIndicator = siRect
@ -731,7 +731,7 @@ object Form1: TForm1
Height = 61
Top = 231
Width = 343
HintFormat = 'Hue: %h'
HintFormat = 'Hue: %h (selected)'
Increment = 5
ArrowPlacement = spBoth
SelectionIndicator = siRect
@ -745,7 +745,7 @@ object Form1: TForm1
Height = 222
Top = 70
Width = 19
HintFormat = 'Saturation: %s'
HintFormat = 'Saturation: %s (selected)'
Layout = lyVertical
ArrowPlacement = spBefore
NewArrowStyle = True
@ -805,8 +805,8 @@ object Form1: TForm1
end
object TabSheet8: TTabSheet
Caption = 'Other'
ClientHeight = 292
ClientWidth = 372
ClientHeight = 303
ClientWidth = 391
ImageIndex = 7
object HSColorPicker1: THSColorPicker
Left = 6
@ -837,7 +837,7 @@ object Form1: TForm1
Height = 130
Top = 164
Width = 133
HintFormat = 'Hue: %h'
HintFormat = 'Hue: %h (selected)'
TabOrder = 2
OnMouseMove = HRingPicker1MouseMove
OnChange = HRingPicker1Change
@ -861,7 +861,7 @@ object Form1: TForm1
Height = 267
Top = 18
Width = 22
HintFormat = 'Cyan: %c'
HintFormat = 'Cyan: %c (selected)'
TabOrder = 0
SelectedColor = clAqua
end
@ -870,7 +870,7 @@ object Form1: TForm1
Height = 267
Top = 18
Width = 22
HintFormat = 'Magenta: %m'
HintFormat = 'Magenta: %m (selected)'
ArrowPlacement = spBefore
TabOrder = 1
SelectedColor = clFuchsia
@ -880,7 +880,7 @@ object Form1: TForm1
Height = 267
Top = 19
Width = 31
HintFormat = 'Yellow: %y'
HintFormat = 'Yellow: %y (selected)'
ArrowPlacement = spBoth
TabOrder = 2
SelectedColor = clYellow
@ -890,7 +890,7 @@ object Form1: TForm1
Height = 267
Top = 18
Width = 22
HintFormat = 'Black: %k'
HintFormat = 'Black: %k (selected)'
NewArrowStyle = True
TabOrder = 3
Cyan = 0
@ -902,7 +902,7 @@ object Form1: TForm1
Height = 268
Top = 18
Width = 22
HintFormat = 'Red: %r'
HintFormat = 'Red: %r (selected)'
ArrowPlacement = spBefore
NewArrowStyle = True
TabOrder = 4
@ -913,7 +913,7 @@ object Form1: TForm1
Height = 268
Top = 18
Width = 34
HintFormat = 'Green: %g'
HintFormat = 'Green: %g (selected)'
ArrowPlacement = spBoth
NewArrowStyle = True
TabOrder = 5
@ -924,7 +924,7 @@ object Form1: TForm1
Height = 268
Top = 18
Width = 22
HintFormat = 'Blue: %b'
HintFormat = 'Blue: %b (selected)'
SelectionIndicator = siRect
TabOrder = 6
SelectedColor = 16743034
@ -937,7 +937,7 @@ object Form1: TForm1
BevelInner = bvRaised
BevelOuter = bvRaised
BorderStyle = bsSingle
HintFormat = 'Black: %k'
HintFormat = 'Black: %k (selected)'
ArrowPlacement = spBoth
NewArrowStyle = True
TabOrder = 7
@ -953,7 +953,7 @@ object Form1: TForm1
BevelInner = bvLowered
BevelOuter = bvRaised
BorderStyle = bsSingle
HintFormat = 'Magenta: %m'
HintFormat = 'Magenta: %m (selected)'
Layout = lyHorizontal
ArrowPlacement = spBoth
NewArrowStyle = True
@ -968,7 +968,7 @@ object Form1: TForm1
BevelInner = bvRaised
BevelOuter = bvLowered
BorderStyle = bsSingle
HintFormat = 'Cyan: %c'
HintFormat = 'Cyan: %c (selected)'
ArrowPlacement = spBoth
NewArrowStyle = True
TabOrder = 9
@ -982,7 +982,7 @@ object Form1: TForm1
BevelInner = bvLowered
BevelOuter = bvLowered
BorderStyle = bsSingle
HintFormat = 'Yellow: %y'
HintFormat = 'Yellow: %y (selected)'
ArrowPlacement = spBoth
NewArrowStyle = True
TabOrder = 10

View File

@ -10,23 +10,36 @@ uses
{$ELSE}
Messages,
{$ENDIF}
Classes, SysUtils, Graphics, Controls;
Classes, SysUtils, Graphics, Controls, ExtCtrls, Forms;
type
THintState = (hsOff, hsWaitingToShow, hsWaitingToHide);
{ TmbBasicPicker }
TmbBasicPicker = class(TCustomControl)
private
FHintWindow: THintWindow;
FHintTimer: TTimer;
FHintState: THintState;
procedure HintTimer(Sender: TObject);
protected
FGradientBmp: TBitmap;
FGradientWidth: Integer;
FGradientHeight: Integer;
FHintShown: Boolean;
procedure CreateGradient; virtual;
function GetGradientColor(AValue: Integer): TColor; virtual;
function GetGradientColor2D(X, Y: Integer): TColor; virtual;
function GetHintText: String; virtual;
procedure HideHintWindow; virtual;
procedure MouseLeave; override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
function MouseOnPicker(X, Y: Integer): Boolean; virtual;
procedure PaintParentBack; virtual; overload;
procedure PaintParentBack(ACanvas: TCanvas); overload;
procedure PaintParentBack(ABitmap: TBitmap); overload;
function ShowHintWindow(APoint: TPoint; AText: String): Boolean; virtual;
{$IFDEF DELPHI}
procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
@ -36,6 +49,7 @@ type
{$ENDIF}
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; override;
published
property ParentColor default true;
@ -43,11 +57,29 @@ type
implementation
uses
LCLIntf;
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;
begin
HideHintWindow;
inherited;
end;
procedure TmbBasicPicker.CMParentColorChanged(var Message: TLMessage);
@ -79,6 +111,58 @@ begin
Result := clNone;
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 //and not FHintShown then
begin
FHintTimer.Enabled := false;
FHintState := hsWaitingToShow;
FHintTimer.Interval := HINT_SHOW_DELAY;
FHintTimer.Enabled := true;
end
else
HideHintWindow;
end;
end;
function TmbBasicPicker.MouseOnPicker(X, Y: Integer): Boolean;
begin
Result := true;
end;
procedure TmbBasicPicker.PaintParentBack;
begin
PaintParentBack(Canvas);
@ -123,6 +207,44 @@ begin
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

View File

@ -21,6 +21,8 @@ uses
type
TMarkerStyle = (msCircle, msSquare, msCross, msCrossCirc);
{ TmbCustomPicker }
TmbCustomPicker = class(TmbBasicPicker)
private
FHintFormat: string;
@ -34,6 +36,7 @@ type
mx, my, mdx, mdy: integer;
FOnChange: TNotifyEvent;
procedure CreateGradient; override;
function GetHintText: String; override;
function GetSelectedColor: TColor; virtual;
procedure SetSelectedColor(C: TColor); virtual;
procedure InternalDrawMarker(X, Y: Integer; C: TColor);
@ -42,7 +45,7 @@ type
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CreateWnd; override;
procedure WebSafeChanged; dynamic;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
// 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;
@ -208,6 +211,11 @@ begin
{$ENDIF}
end;
function TmbCustomPicker.GetHintText: String;
begin
Result := FormatHint(FHintFormat, GetColorUnderCursor)
end;
function TmbCustomPicker.GetSelectedColor: TColor;
begin
Result := FSelected; // valid for most descendents
@ -248,7 +256,7 @@ begin
msCrossCirc: DrawSelCrossCirc(x, y, Canvas, c);
end;
end;
(*
procedure TmbCustomPicker.CMHintShow(var Message: TCMHintShow);
begin
if GetColorUnderCursor <> clNone then
@ -264,7 +272,7 @@ begin
HintStr := FormatHint(FHintFormat, GetColorUnderCursor);;
end;
inherited;
end;
end; *)
procedure TmbCustomPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin

View File

@ -84,12 +84,15 @@ type
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); dynamic;
function GetArrowPos: integer; dynamic;
function GetHintStr: string;
function GetHintText: string; override;
function GetSelectedValue: integer; virtual; abstract;
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; override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
function ShowHintWindow(APoint: TPoint; AText: String): Boolean; override;
// procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
{$IFDEF DELPHI}
@ -597,6 +600,12 @@ begin
Result := pos;
end;
procedure TmbTrackBarPicker.MouseLeave;
begin
inherited;
FHintShown := false;
end;
procedure TmbTrackBarPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
var
R: TRect;
@ -623,6 +632,11 @@ begin
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;
@ -742,7 +756,7 @@ begin
if not FInherited and Assigned(OnKeyDown) then
OnKeyDown(Self, Message.CharCode, Shift);
end;
(*
procedure TmbTrackBarPicker.CMHintShow(var Message: TCMHintShow);
begin
with TCMHintShow(Message) do
@ -761,7 +775,7 @@ begin
HintStr := GetHintStr;
end;
inherited;
end;
end; *)
procedure TmbTrackBarPicker.CMGotFocus(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF});
@ -865,7 +879,7 @@ begin
//handled in descendants
end;
function TmbTrackBarPicker.GetHintStr: string;
function TmbTrackBarPicker.GetHintText: string;
begin
Result := ReplaceFlags(FHintFormat, ['%value', '%h', '%s', '%l', '%v', '%c',
'%m', '%y', '%k', '%r', '%g', '%b'], GetSelectedValue);
@ -907,4 +921,11 @@ begin
end;
end;
function TmbTrackbarPicker.ShowHintWindow(APoint: TPoint; AText: String): Boolean;
begin
Result := inherited;
if Result then
FHintShown := true;
end;
end.

View File

@ -9,6 +9,7 @@ uses
procedure Clamp(var AValue:Integer; AMin, AMax: Integer);
function PointInCircle(p: TPoint; Size: integer): boolean;
function PtInCircle(p, ctr: TPoint; Radius: Integer): Boolean;
implementation
@ -26,6 +27,11 @@ begin
Result := (sqr(p.x - r) + sqr(p.y - r) <= sqr(r));
end;
function PtInCircle(p, ctr: TPoint; Radius: Integer): Boolean;
begin
Result := sqr(p.x - ctr.x) + sqr(p.y - ctr.y) <= sqr(Radius);
end;
end.