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

mbColorLib: Redo hints

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5519 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2016-12-16 18:42:32 +00:00
parent f2809fba90
commit 90314c0876
13 changed files with 244 additions and 100 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
components/mbColorLib/HRingPicker.pas
View File

@@ -42,7 +42,7 @@ type
procedure SetSelectedColor(c: TColor); override;
procedure Paint; override;
procedure Resize; override;
procedure CreateWnd; override;
// 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;
@@ -52,6 +52,7 @@ type
public
constructor Create(AOwner: TComponent); override;
function GetColorAtPoint(x, y: integer): TColor; override;
property ColorUnderCursor;
published
property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 0;
@@ -135,14 +136,14 @@ begin
CreateGradient;
UpdateCoords;
end;
{
procedure THRingPicker.CreateWnd;
begin
inherited;
CreateGradient;
UpdateCoords;
end;
}
procedure THRingPicker.UpdateCoords;
var
r, angle: real;
@@ -396,7 +397,7 @@ begin
s := 255
else
s := MulDiv(distance, 255, radius);
if PointInCircle(Point(mx, my), Min(Width, Height)) then
if PointInCircle(Point(x, y), Min(Width, Height)) then
begin
if not WebSafe then
Result := HSVtoColor(h, s, FValue)

8
components/mbColorLib/HSLColorPicker.pas
View File

@@ -52,6 +52,7 @@ type
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;
@@ -62,10 +63,9 @@ type
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorUnderCursor: TColor;
function GetHexColorUnderCursor: string;
function GetHexColorUnderCursor: string; override;
function GetSelectedHexColor: string;
property ColorUnderCursor: TColor read GetColorUnderCursor;
property ColorUnderCursor;
property HValue: integer read FHValue write SetH default 0;
property SValue: integer read FSValue write SetS default 240;
property LValue: integer read FLValue write SetL default 120;
@@ -292,7 +292,7 @@ end;
function THSLColorPicker.GetColorUnderCursor: TColor;
begin
Result := FHSPicker.GetColorUnderCursor;
Result := FHSPicker.ColorUnderCursor;
end;
function THSLColorPicker.GetHexColorUnderCursor: string;

8
components/mbColorLib/HSLRingPicker.pas
View File

@@ -49,6 +49,7 @@ type
procedure CreateWnd; override;
procedure Paint; override;
procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
function GetColorUnderCursor: TColor; override;
procedure RingPickerChange(Sender: TObject);
procedure SLPickerChange(Sender: TObject);
procedure DoChange;
@@ -61,10 +62,9 @@ type
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorUnderCursor: TColor;
function GetHexColorUnderCursor: string;
function GetHexColorUnderCursor: string; override;
function GetSelectedHexColor: string;
property ColorUnderCursor: TColor read GetColorUnderCursor;
property ColorUnderCursor;
property HValue: integer read FHValue write SetH default 0;
property SValue: integer read FSValue write SetS default 240;
property LValue: integer read FLValue write SetL default 120;
@@ -324,7 +324,7 @@ end;
function THSLRingPicker.GetColorUnderCursor: TColor;
begin
Result := FSLPicker.GetColorUnderCursor;
Result := FSLPicker.ColorUnderCursor;
end;
function THSLRingPicker.GetHexColorUnderCursor: string;

1
components/mbColorLib/SLColorPicker.pas
View File

@@ -41,6 +41,7 @@ type
public
constructor Create(AOwner: TComponent); override;
function GetColorAtPoint(x, y: integer): TColor; override;
property ColorUnderCursor;
published
property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 0;

8
components/mbColorLib/SLHColorPicker.pas
View File

@@ -51,6 +51,7 @@ type
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;
@@ -59,10 +60,9 @@ type
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorUnderCursor: TColor;
function GetHexColorUnderCursor: string;
function GetHexColorUnderCursor: string; override;
function GetSelectedHexColor: string;
property ColorUnderCursor: TColor read GetColorUnderCursor;
property ColorUnderCursor;
property HValue: integer read FHValue write SetH default 0;
property SValue: integer read FSValue write SetS default 240;
property LValue: integer read FLValue write SetL default 120;
@@ -294,7 +294,7 @@ end;
function TSLHColorPicker.GetColorUnderCursor: TColor;
begin
Result := FSLPicker.GetColorUnderCursor;
Result := FSLPicker.ColorUnderCursor;
end;
function TSLHColorPicker.GetHexColorUnderCursor: string;

4
components/mbColorLib/examples/fulldemo/Demo.lpi
View File

@@ -9,10 +9,6 @@
<Title Value="Demo"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<TextName Value="CompanyName.ProductName.AppName"/>
<TextDesc Value="Your application description."/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">

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

@@ -42,9 +42,9 @@ object Form1: TForm1
Height = 384
Top = 6
Width = 403
ActivePage = TabSheet5
ActivePage = TabSheet10
Anchors = [akTop, akLeft, akRight, akBottom]
TabIndex = 4
TabIndex = 10
TabOrder = 0
OnChange = PageControl1Change
OnMouseMove = PageControl1MouseMove
@@ -57,8 +57,8 @@ object Form1: TForm1
Height = 340
Top = 8
Width = 381
SelectedColor = 273922
HSPickerHintFormat = 'H: %h S: %s'#13'Hex: %hex'
SelectedColor = 2048
HSPickerHintFormat = 'H: %h S: %s'#13'Hex: #%hex'
LPickerHintFormat = 'Luminance: %l'
Anchors = [akTop, akLeft, akRight, akBottom]
TabOrder = 0
@@ -87,7 +87,7 @@ object Form1: TForm1
Top = 4
Width = 289
Anchors = [akTop, akLeft, akRight, akBottom]
HintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h'
HintFormat = 'RGB(%r, %g, %b)'#13'Hex: #%hex'
SliderMarker = smRect
IntensityText = 'Intensity'
TabOrder = 0
@@ -480,7 +480,7 @@ object Form1: TForm1
'clBlack'
'clBlack'
)
HintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h'
HintFormat = 'RGB(%r, %g, %b)'#13'Hex: #%hex'
AutoHeight = True
TabOrder = 0
OnSelColorChange = mbColorPalette1SelColorChange
@@ -628,7 +628,6 @@ object Form1: TForm1
Width = 385
HPickerHintFormat = 'Hue: %h (selected)'
SLPickerHintFormat = 'S: %s L: %l'#13'Hex: %hex'
ParentShowHint = False
Anchors = [akTop, akLeft, akRight, akBottom]
TabOrder = 0
OnChange = SLHColorPicker1Change
@@ -738,12 +737,13 @@ object Form1: TForm1
Height = 61
Top = 284
Width = 347
HintFormat = 'Hue: %h (selected)'
HintFormat = 'Hue: %h (under mouse)'
Increment = 5
ArrowPlacement = spBoth
SelectionIndicator = siRect
Anchors = [akLeft, akRight, akBottom]
TabOrder = 4
OnGetHintStr = HColorPicker1GetHintStr
Saturation = 120
SelectedColor = 8882175
end
@@ -829,7 +829,7 @@ object Form1: TForm1
OnChange = HSColorPicker1Change
end
object SLColorPicker1: TSLColorPicker
Left = 222
Left = 224
Height = 147
Top = 144
Width = 161
@@ -1006,7 +1006,7 @@ object Form1: TForm1
Height = 100
Top = 28
Width = 100
HintFormat = 'G: %g B: %b'#13'Hex: %hex'
HintFormat = 'G: %g B: %b'#13'Hex: #%hex'
TabOrder = 0
end
object GAxisColorPicker1: TGAxisColorPicker
@@ -1014,7 +1014,7 @@ object Form1: TForm1
Height = 100
Top = 28
Width = 100
HintFormat = 'R: %r B: %b'#13'Hex: %hex'
HintFormat = 'R: %r B: %b'#13'Hex: #%hex'
TabOrder = 1
MarkerStyle = msCross
end
@@ -1023,7 +1023,7 @@ object Form1: TForm1
Height = 100
Top = 28
Width = 100
HintFormat = 'R: %r G: %g'#13'Hex: %hex'
HintFormat = 'R: %r G: %g'#13'Hex: #%hex'
TabOrder = 2
MarkerStyle = msCrossCirc
end
@@ -1033,7 +1033,7 @@ object Form1: TForm1
Top = 164
Width = 100
SelectedColor = 16119089
HintFormat = 'A: %cieA B: %cieB'#13'Hex: %hex'
HintFormat = 'A: %cieA B: %cieB'#13'Hex: #%hex'
TabOrder = 3
LValue = 88
AValue = -47
@@ -1045,7 +1045,7 @@ object Form1: TForm1
Top = 164
Width = 100
SelectedColor = 16515327
HintFormat = 'L: %cieL B: %cieB'#13'Hex: %hex'
HintFormat = 'L: %cieL B: %cieB'#13'Hex: #%hex'
TabOrder = 4
LValue = 60
AValue = 96
@@ -1058,7 +1058,7 @@ object Form1: TForm1
Top = 164
Width = 100
SelectedColor = 130823
HintFormat = 'L: %cieL A: %cieA'#13'Hex: %hex'
HintFormat = 'L: %cieL A: %cieA'#13'Hex: #%hex'
TabOrder = 5
LValue = 88
AValue = -88
@@ -1192,6 +1192,7 @@ object Form1: TForm1
Height = 19
Top = 371
Width = 62
Anchors = [akLeft, akBottom]
Caption = 'Enabled'
Checked = True
OnChange = CbEnabledChange

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

@@ -13,7 +13,7 @@ uses
BColorPicker, GColorPicker, RColorPicker, KColorPicker, YColorPicker,
MColorPicker, CColorPicker, CIEBColorPicker, CIEAColorPicker, Typinfo,
CIELColorPicker, BAxisColorPicker, GAxisColorPicker, RAxisColorPicker,
mbColorTree, mbColorList {for internet shortcuts};
mbColorTree, mbColorList {for internet shortcuts}, mbBasicPicker;
type
@@ -107,6 +107,8 @@ type
CbSwatchStyle: TCheckBox;
procedure CbEnabledChange(Sender: TObject);
procedure CbShowHintsChange(Sender: TObject);
procedure HColorPicker1GetHintStr(Sender: TObject; X, Y: Integer;
var AText: String);
procedure PageControl1Change(Sender: TObject);
procedure PageControl1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
@@ -339,6 +341,12 @@ begin
end;
end;
procedure TForm1.HColorPicker1GetHintStr(Sender: TObject; X, Y: Integer;
var AText: String);
begin
AText := FormatHint(HColorPicker1.HintFormat, HColorPicker1.GetColorAtPoint(X, Y));
end;
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
HexaColorPicker1.SliderVisible := checkbox1.Checked;

95
components/mbColorLib/mbBasicPicker.pas
View File

@@ -15,24 +15,30 @@ uses
type
THintState = (hsOff, hsWaitingToShow, hsWaitingToHide);
TGetHintStrEvent = procedure (Sender: TObject; X, Y: Integer; var AText: String) of object;
{ TmbBasicPicker }
TmbBasicPicker = class(TCustomControl)
private
FOnGetHintStr: TGetHintStrEvent;
{
FHintWindow: THintWindow;
FHintTimer: TTimer;
FHintState: THintState;
procedure HintTimer(Sender: TObject);
}
protected
FBufferBmp: TBitmap;
FGradientWidth: Integer;
FGradientHeight: Integer;
FHintShown: Boolean;
procedure CreateGradient; virtual;
function GetColorUnderCursor: TColor; virtual;
function GetGradientColor(AValue: Integer): TColor; virtual;
function GetGradientColor2D(X, Y: Integer): TColor; virtual;
function GetHintText: String; virtual;
procedure HideHintWindow; 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;
function MouseOnPicker(X, Y: Integer): Boolean; virtual;
@@ -40,7 +46,7 @@ type
procedure PaintParentBack(ACanvas: TCanvas); overload;
procedure PaintParentBack(ACanvas: TCanvas; ARect: TRect); overload;
procedure PaintParentBack(ABitmap: TBitmap); overload;
function ShowHintWindow(APoint: TPoint; AText: String): Boolean; virtual;
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;
@@ -48,9 +54,14 @@ type
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
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
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;
@@ -59,7 +70,8 @@ type
implementation
uses
LCLIntf, mbUtils;
LCLIntf,
HTMLColors, mbUtils;
const
HINT_SHOW_DELAY = 50;
@@ -70,16 +82,43 @@ 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;
//HideHintWindow;
inherited;
end;
procedure TmbBasicPicker.CMHintShow(var Message: TCMHintShow);
var
cp: TPoint;
begin
if GetColorUnderCursor <> clNone then
with TCMHintShow(Message) do
if not ShowHint then
Message.Result := 1
else
if Hint <> '' then
Message.Result := 0
else
begin
cp := HintInfo^.CursorPos;
HintInfo^.ReshowTimeout := 0; // must be zero!
HintInfo^.HideTimeout := Application.HintHidePause;
HintInfo^.HintStr := GetHintStr(cp.X, cp.Y);
HintInfo^.HintPos := ClientToScreen(GetHintPos(cp.X, cp.Y));
HintInfo^.CursorRect := Rect(cp.X, cp.Y, cp.X+1, cp.Y+1);
Result := 0; // 0 means: show hint
end;
inherited;
end;
@@ -98,6 +137,30 @@ procedure TmbBasicPicker.CreateGradient;
begin
// to be implemented by descendants
end;
function TmbBasicPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y]; // valid for most descendents
end;
function TmbBasicPicker.GetColorUnderCursor: TColor;
var
P: TPoint;
begin
P := ScreenToClient(Mouse.CursorPos);
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
@@ -114,6 +177,19 @@ begin
Result := clNone;
end;
function TmbBasicPicker.GetHintPos(X, Y: Integer): TPoint;
begin
Result := Point(X, Y);
end;
function TmbBasicPicker.GetHintStr(X, Y: Integer): String;
begin
Result := '';
if Assigned(FOnGetHintStr) then
FOnGetHintStr(Self, X, Y, Result);
end;
(*
function TmbBasicPicker.GetHintText: String;
begin
Result := Hint;
@@ -135,18 +211,21 @@ begin
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
@@ -159,6 +238,7 @@ begin
else
HideHintWindow;
end;
}
end;
function TmbBasicPicker.MouseOnPicker(X, Y: Integer): Boolean;
@@ -245,7 +325,7 @@ begin
Offscreen.Free;
end;
end;
(*
// Build and show the hint window
function TmbBasicPicker.ShowHintWindow(APoint: TPoint; AText: String): Boolean;
const
@@ -283,6 +363,7 @@ begin
Result := true;
end;
*)
(* !!!!!!!!!!!!!!!!!
procedure TmbBasicPicker.WMEraseBkgnd(
var Message: {$IFDEF DELPHI}TWMEraseBkgnd{$ELSE}TLMEraseBkgnd{$ENDIF} );

38
components/mbColorLib/mbColorPalette.pas
View File

@@ -74,6 +74,9 @@ type
procedure DrawCell(ACanvas: TCanvas; AColor: string);
procedure DrawCellBack(ACanvas: TCanvas; R: TRect; AIndex: integer);
procedure ColorsChange(Sender: TObject);
function GetColorUnderCursor: TColor; override;
function GetHintStr(X, Y: Integer): String; override;
function GetIndexUnderCursor: integer;
procedure Resize; override;
procedure SelectCell(i: integer);
// procedure CreateWnd; override;
@@ -103,11 +106,8 @@ type
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetColorUnderCursor: TColor;
function GetSelectedCellRect: TRect;
function GetIndexUnderCursor: integer;
property ColorUnderCursor: TColor read GetColorUnderCursor;
property ColorUnderCursor;
property VisibleRowCount: integer read FRowCount;
property RowCount: integer read GetTotalRowCount;
property ColCount: integer read FColCount;
@@ -207,7 +207,7 @@ begin
FColors := TStringList.Create;
(FColors as TStringList).OnChange := ColorsChange;
FTotalCells := 0;
FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: %hex';
FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: #%hex';
FAutoHeight := false;
FMinColors := 0;
FMaxColors := 0;
@@ -838,6 +838,22 @@ begin
Result := mbStringToColor(FColors.Strings[FIndex]);
end;
function TmbColorPalette.GetHintStr(X, Y: Integer): String;
var
idx: Integer;
begin
idx := GetIndexUnderCursor;
if FIndex < FNames.Count then
Result := FNames.Strings[FIndex]
else
if SameText(FColors.Strings[idx], 'clCustom') or
SameText(FColors.Strings[idx], 'clTransparent')
then
Result := StringReplace(FColors.Strings[idx], 'cl', '', [rfReplaceAll])
else
Result := FormatHint(FHintFormat, ColorUnderCursor);
end;
function TmbColorPalette.GetIndexUnderCursor: integer;
begin
Result := -1;
@@ -1009,21 +1025,15 @@ begin
// show that we want a hint
Result := 0;
ReshowTimeout := 1;
HideTimeout := 5000;
HideTimeout := Application.HintHidePause; // was: 5000
clr := GetColorUnderCursor;
//fire event
Handled := false;
if Assigned(FOnGetHintText) then
FOnGetHintText(clr, GetIndexUnderCursor, HintStr, Handled);
if Handled then Exit;
//do default
if FIndex < FNames.Count then
HintStr := FNames.Strings[FIndex]
else
if SameText(FColors.Strings[GetIndexUnderCursor], 'clCustom') or SameText(FColors.Strings[GetIndexUnderCursor], 'clTransparent') then
HintStr := StringReplace(FColors.Strings[GetIndexUnderCursor], 'cl', '', [rfReplaceAll])
else
HintStr := FormatHint(FHintFormat, GetColorUnderCursor);
if not Handled then
HintStr := GetHintStr(CursorPos.X, CursorPos.Y);
end;
end;
end;

60
components/mbColorLib/mbColorPickerControl.pas
View File

@@ -36,7 +36,9 @@ type
mx, my, mdx, mdy: integer;
FOnChange: TNotifyEvent;
procedure CreateGradient; override;
function GetHintText: String; 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);
@@ -59,11 +61,7 @@ type
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 ColorUnderCursor;
property Manual: boolean read FManual;
published
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor;
@@ -92,6 +90,7 @@ type
property DragKind;
property Constraints;
property OnContextPopup;
property OnGetHintStr;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
@@ -210,11 +209,11 @@ begin
end;
{$ENDIF}
end;
(*
function TmbCustomPicker.GetHintText: String;
begin
Result := FormatHint(FHintFormat, GetColorUnderCursor)
end;
end; *)
function TmbCustomPicker.GetSelectedColor: TColor;
begin
@@ -227,26 +226,6 @@ begin
//handled in descendents
end;
function TmbCustomPicker.GetColorAtPoint(x, y: integer): TColor;
begin
Result := Canvas.Pixels[x, y]; // valid for most descendents
end;
function TmbCustomPicker.GetHexColorAtPoint(X, Y: integer): string;
begin
Result := ColorToHex(GetColorAtPoint(x, y));
end;
function TmbCustomPicker.GetColorUnderCursor: TColor;
begin
Result := GetColorAtPoint(mx, my);
end;
function TmbCustomPicker.GetHexColorUnderCursor: string;
begin
Result := ColorToHex(GetColorAtPoint(mx, my));
end;
procedure TmbCustomPicker.InternalDrawMarker(X, Y: Integer; C: TColor);
begin
case MarkerStyle of
@@ -256,24 +235,41 @@ begin
msCrossCirc : DrawSelCrossCirc(x, y, Canvas, c);
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;
end; }
inherited;
end; *)
end;
*)
procedure TmbCustomPicker.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;

2
components/mbColorLib/mbColorTree.pas
View File

@@ -10,7 +10,7 @@ interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
LCLIntf, LCLType,
{$ELSE}
Windows, Messages,
{$ENDIF}

70
components/mbColorLib/mbTrackBarPicker.pas
View File

@@ -40,6 +40,8 @@ type
TSliderPlacement = (spBefore, spAfter, spBoth);
TSelIndicator = (siArrows, siRect);
{ TmbTrackBarPicker }
TmbTrackBarPicker = class(TmbBasicPicker)
private
mx, my: integer;
@@ -85,15 +87,15 @@ type
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); dynamic;
function GetArrowPos: integer; dynamic;
function GetHintText: string; override;
// function GetColorUnderCursor: TColor; override;
function GetHintPos(X, Y: Integer): TPoint; override;
function GetHintStr(X, Y: Integer): 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;
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}
@@ -143,6 +145,7 @@ type
property Constraints;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnContextPopup;
property OnGetHintStr;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
@@ -762,18 +765,63 @@ begin
if not FInherited and Assigned(OnKeyDown) then
OnKeyDown(Self, Message.CharCode, Shift);
end;
(*
function TmbTrackBarPicker.GetHintPos(X, Y: Integer): TPoint;
begin
case FLayout of
lyHorizontal:
Result := Point(X - 8, Height + 2);
lyVertical:
Result := Point(Width + 2, Y - 8);
end;
end;
function TmbTrackBarPicker.GetHintStr(X, Y: Integer): string;
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.CMHintShow(var Message: TCMHintShow);
var
cp: TPoint;
begin
with TCMHintShow(Message) do
if not ShowHint then
Message.Result := 1
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 := 5000;
HideTimeout := 0; //5000;
if FLayout = lyHorizontal then
HintPos := ClientToScreen(Point(CursorPos.X - 8, Height + 2))
else
@@ -781,8 +829,8 @@ begin
HintStr := GetHintStr;
end;
inherited;
end; *)
end;
}
procedure TmbTrackBarPicker.CMGotFocus(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF});
begin
@@ -885,11 +933,12 @@ begin
//handled in descendants
end;
(*
function TmbTrackBarPicker.GetHintText: string;
begin
Result := ReplaceFlags(FHintFormat, ['%value', '%h', '%s', '%l', '%v', '%c',
'%m', '%y', '%k', '%r', '%g', '%b'], GetSelectedValue);
end;
end; *)
procedure TmbTrackBarPicker.SetBevelInner(Value: TBevelCut);
begin
@@ -927,11 +976,12 @@ begin
end;
end;
(*
function TmbTrackbarPicker.ShowHintWindow(APoint: TPoint; AText: String): Boolean;
begin
Result := inherited;
if Result then
FHintShown := true;
end;
*)
end.