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

mbColorLib: several bug fixes. Refactoring of gradient painting.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5456 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2016-12-09 23:47:46 +00:00
parent 49d960779c
commit b8a19cf29b
29 changed files with 3053 additions and 2819 deletions
Download Patch File Download Diff File Expand all files Collapse all files

284
components/mbColorLib/BColorPicker.pas
View File

@@ -7,43 +7,42 @@ unit BColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
mbTrackBarPicker, HTMLColors, Scanlines; mbTrackBarPicker, HTMLColors;
type type
TBColorPicker = class(TmbTrackBarPicker)
private
FRed, FGreen, FBlue: integer;
FBmp: TBitmap;
function ArrowPosFromBlue(b: integer): integer; { TBColorPicker }
function BlueFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor; TBColorPicker = class(TmbTrackBarPicker)
procedure SetSelectedColor(c: TColor); private
procedure CreateBGradient; FRed, FGreen, FBlue: integer;
procedure SetRed(r: integer); function ArrowPosFromBlue(b: integer): integer;
procedure SetGreen(g: integer); function BlueFromArrowPos(p: integer): integer;
procedure SetBlue(b: integer); function GetSelectedColor: TColor;
protected procedure SetSelectedColor(c: TColor);
procedure CreateWnd; override; procedure SetRed(r: integer);
procedure Execute(tbaAction: integer); override; procedure SetGreen(g: integer);
function GetArrowPos: integer; override; procedure SetBlue(b: integer);
function GetSelectedValue: integer; override; protected
public procedure Execute(tbaAction: integer); override;
constructor Create(AOwner: TComponent); override; function GetArrowPos: integer; override;
destructor Destroy; override; function GetGradientColor(AValue: Integer): TColor; override;
published function GetSelectedValue: integer; override;
property Red: integer read FRed write SetRed default 122; public
property Green: integer read FGreen write SetGreen default 122; constructor Create(AOwner: TComponent); override;
property Blue: integer read FBlue write SetBlue default 255; published
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; property Red: integer read FRed write SetRed default 122;
property Layout default lyVertical; property Green: integer read FGreen write SetGreen default 122;
end; property Blue: integer read FBlue write SetBlue default 255;
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Layout default lyVertical;
end;
procedure Register; procedure Register;
@@ -55,43 +54,34 @@ implementation
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TBColorPicker]); RegisterComponents('mbColor Lib', [TBColorPicker]);
end; end;
{TBColorPicker} {TBColorPicker}
constructor TBColorPicker.Create(AOwner: TComponent); constructor TBColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FBmp := TBitmap.Create; FGradientWidth := 256;
FBmp.PixelFormat := pf32bit; FGradientHeight := 12;
FBmp.SetSize(12, 256); SetInitialBounds(0, 0, 22, 268);
Width := 22; {
Height := 268; Width := 22;
Layout := lyVertical; Height := 268;
FRed := 122; }
FGreen := 122; Layout := lyVertical;
FBlue := 255; FRed := 122;
FArrowPos := ArrowPosFromBlue(255); FGreen := 122;
FChange := false; FBlue := 255;
SetBlue(255); FArrowPos := ArrowPosFromBlue(255);
HintFormat := 'Blue: %value'; FChange := false;
FManual := false; SetBlue(255);
FChange := true; HintFormat := 'Blue: %value';
end; FManual := false;
FChange := true;
destructor TBColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
end;
procedure TBColorPicker.CreateWnd;
begin
inherited;
CreateBGradient;
end; end;
(*
procedure TBColorPicker.CreateBGradient; procedure TBColorPicker.CreateBGradient;
var var
i,j: integer; i,j: integer;
@@ -130,91 +120,93 @@ begin
row[j] := RGBtoRGBQuad(GetWebSafe(RGB(FRed, FGreen, 255-i))); row[j] := RGBtoRGBQuad(GetWebSafe(RGB(FRed, FGreen, 255-i)));
end; end;
end; end;
end; *)
function TBColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := RGB(FRed, FGreen, AValue);
end; end;
procedure TBColorPicker.SetRed(r: integer); procedure TBColorPicker.SetRed(r: integer);
begin begin
if r < 0 then r := 0; if r < 0 then r := 0;
if r > 255 then r := 255; if r > 255 then r := 255;
if FRed <> r then if FRed <> r then
begin begin
FRed := r; FRed := r;
FManual := false; FManual := false;
CreateBGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TBColorPicker.SetGreen(g: integer); procedure TBColorPicker.SetGreen(g: integer);
begin begin
if g > 255 then g := 255; if g > 255 then g := 255;
if g < 0 then g := 0; if g < 0 then g := 0;
if FGreen <> g then if FGreen <> g then
begin begin
FGreen := g; FGreen := g;
FManual := false; FManual := false;
CreateBGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TBColorPicker.SetBlue(b: integer); procedure TBColorPicker.SetBlue(b: integer);
begin begin
if b > 255 then b := 255; if b > 255 then b := 255;
if b < 0 then b := 0; if b < 0 then b := 0;
if FBlue <> b then if FBlue <> b then
begin begin
FBlue := b; FBlue := b;
FArrowPos := ArrowPosFromBlue(b); FArrowPos := ArrowPosFromBlue(b);
FManual := false; FManual := false;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function TBColorPicker.ArrowPosFromBlue(b: integer): integer; function TBColorPicker.ArrowPosFromBlue(b: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/255)*b); a := Round(((Width - 12)/255)*b);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
b := 255 - b; b := 255 - b;
a := Round(((Height - 12)/255)*b); a := Round(((Height - 12)/255)*b);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function TBColorPicker.BlueFromArrowPos(p: integer): integer; function TBColorPicker.BlueFromArrowPos(p: integer): integer;
var var
b: integer; b: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
b := Round(p/((Width - 12)/255)) b := Round(p/((Width - 12)/255))
else else
b := Round(255 - p/((Height - 12)/255)); b := Round(255 - p/((Height - 12)/255));
if b < 0 then b := 0; if b < 0 then b := 0;
if b > 255 then b := 255; if b > 255 then b := 255;
Result := b; Result := b;
end; end;
function TBColorPicker.GetSelectedColor: TColor; function TBColorPicker.GetSelectedColor: TColor;
begin begin
if not WebSafe then if not WebSafe then
Result := RGB(FRed, FGreen, FBlue) Result := RGB(FRed, FGreen, FBlue)
else else
Result := GetWebSafe(RGB(FRed, FGreen, FBlue)); Result := GetWebSafe(RGB(FRed, FGreen, FBlue));
end; end;
function TBColorPicker.GetSelectedValue: integer; function TBColorPicker.GetSelectedValue: integer;
@@ -224,41 +216,55 @@ end;
procedure TBColorPicker.SetSelectedColor(c: TColor); procedure TBColorPicker.SetSelectedColor(c: TColor);
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
FChange := false; FChange := false;
SetRed(GetRValue(c)); SetRed(GetRValue(c));
SetGreen(GetGValue(c)); SetGreen(GetGValue(c));
SetBlue(GetBValue(c)); SetBlue(GetBValue(c));
FManual := false; FManual := false;
FChange := true; FChange := true;
if Assigned(OnChange) then OnChange(Self); if Assigned(OnChange) then OnChange(Self);
end; end;
function TBColorPicker.GetArrowPos: integer; function TBColorPicker.GetArrowPos: integer;
begin begin
Result := ArrowPosFromBlue(FBlue); Result := ArrowPosFromBlue(FBlue);
end; end;
procedure TBColorPicker.Execute(tbaAction: integer); procedure TBColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
TBA_Resize: SetBlue(FBlue); TBA_Resize:
TBA_Paint: Canvas.StretchDraw(FPickRect, FBmp); SetBlue(FBlue);
TBA_MouseMove: FBlue := BlueFromArrowPos(FArrowPos); TBA_MouseMove:
TBA_MouseDown: FBlue := BlueFromArrowPos(FArrowPos); FBlue := BlueFromArrowPos(FArrowPos);
TBA_MouseUp: FBlue := BlueFromArrowPos(FArrowPos); TBA_MouseDown:
TBA_WheelUp: SetBlue(FBlue + Increment); FBlue := BlueFromArrowPos(FArrowPos);
TBA_WheelDown: SetBlue(FBlue - Increment); TBA_MouseUp:
TBA_VKRight: SetBlue(FBlue + Increment); FBlue := BlueFromArrowPos(FArrowPos);
TBA_VKCtrlRight: SetBlue(255); TBA_WheelUp:
TBA_VKLeft: SetBlue(FBlue - Increment); SetBlue(FBlue + Increment);
TBA_VKCtrlLeft: SetBlue(0); TBA_WheelDown:
TBA_VKUp: SetBlue(FBlue + Increment); SetBlue(FBlue - Increment);
TBA_VKCtrlUp: SetBlue(255); TBA_VKRight:
TBA_VKDown: SetBlue(FBlue - Increment); SetBlue(FBlue + Increment);
TBA_VKCtrlDown: SetBlue(0); TBA_VKCtrlRight:
TBA_RedoBMP: CreateBGradient; SetBlue(255);
end; TBA_VKLeft:
SetBlue(FBlue - Increment);
TBA_VKCtrlLeft:
SetBlue(0);
TBA_VKUp:
SetBlue(FBlue + Increment);
TBA_VKCtrlUp:
SetBlue(255);
TBA_VKDown:
SetBlue(FBlue - Increment);
TBA_VKCtrlDown:
SetBlue(0);
else
inherited;
end;
end; end;
end. end.

311
components/mbColorLib/CColorPicker.pas
View File

@@ -7,45 +7,41 @@ unit CColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines; RGBCMYKUtils, mbTrackBarPicker, HTMLColors;
type type
TCColorPicker = class(TmbTrackBarPicker) TCColorPicker = class(TmbTrackBarPicker)
private private
FCyan, FMagenta, FYellow, FBlack: integer; FCyan, FMagenta, FYellow, FBlack: integer;
FCBmp: TBitmap; function ArrowPosFromCyan(c: integer): integer;
function CyanFromArrowPos(p: integer): integer;
function ArrowPosFromCyan(c: integer): integer; function GetSelectedColor: TColor;
function CyanFromArrowPos(p: integer): integer; procedure SetSelectedColor(c: TColor);
function GetSelectedColor: TColor; procedure SetCyan(c: integer);
procedure SetSelectedColor(c: TColor); procedure SetMagenta(m: integer);
procedure CreateCGradient; procedure SetYellow(y: integer);
procedure SetCyan(c: integer); procedure SetBlack(k: integer);
procedure SetMagenta(m: integer); protected
procedure SetYellow(y: integer); procedure Execute(tbaAction: integer); override;
procedure SetBlack(k: integer); function GetArrowPos: integer; override;
protected function GetGradientColor(AValue: Integer): TColor; override;
procedure CreateWnd; override; function GetSelectedValue: integer; override;
procedure Execute(tbaAction: integer); override; public
function GetArrowPos: integer; override; constructor Create(AOwner: TComponent); override;
function GetSelectedValue: integer; override; published
public property Cyan: integer read FCyan write SetCyan default 255;
constructor Create(AOwner: TComponent); override; property Magenta: integer read FMagenta write SetMagenta default 0;
destructor Destroy; override; property Yellow: integer read FYellow write SetYellow default 0;
published property Black: integer read FBlack write SetBlack default 0;
property Cyan: integer read FCyan write SetCyan default 255; property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Magenta: integer read FMagenta write SetMagenta default 0; property Layout default lyVertical;
property Yellow: integer read FYellow write SetYellow default 0; end;
property Black: integer read FBlack write SetBlack default 0;
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Layout default lyVertical;
end;
procedure Register; procedure Register;
@@ -57,44 +53,33 @@ implementation
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TCColorPicker]); RegisterComponents('mbColor Lib', [TCColorPicker]);
end; end;
{TCColorPicker} {TCColorPicker}
constructor TCColorPicker.Create(AOwner: TComponent); constructor TCColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FCBmp := TBitmap.Create; FGradientWidth := 256;
FCBmp.PixelFormat := pf32bit; FGradientHeight := 12;
FCBmp.SetSize(12, 255); SetInitialBounds(0, 0, 22, 267);
Width := 22; //Width := 22;
Height := 267; //Height := 267;
Layout := lyVertical; Layout := lyVertical;
FCyan := 255; FCyan := 255;
FMagenta := 0; FMagenta := 0;
FYellow := 0; FYellow := 0;
FBlack := 0; FBlack := 0;
FArrowPos := ArrowPosFromCyan(255); FArrowPos := ArrowPosFromCyan(255);
FChange := false; FChange := false;
SetCyan(255); SetCyan(255);
HintFormat := 'Cyan: %value'; HintFormat := 'Cyan: %value';
FManual := false; FManual := false;
FChange := true; FChange := true;
end;
destructor TCColorPicker.Destroy;
begin
FCBmp.Free;
inherited Destroy;
end;
procedure TCColorPicker.CreateWnd;
begin
inherited;
CreateCGradient;
end; end;
(*
procedure TCColorPicker.CreateCGradient; procedure TCColorPicker.CreateCGradient;
var var
i,j: integer; i,j: integer;
@@ -134,105 +119,107 @@ begin
end; end;
end; end;
end; end;
*)
function TCColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := CMYKtoTColor(AValue, FMagenta, FYellow, FBlack);
end;
procedure TCColorPicker.SetCyan(C: integer); procedure TCColorPicker.SetCyan(C: integer);
begin begin
if C < 0 then C := 0; if C < 0 then C := 0;
if C > 255 then C := 255; if C > 255 then C := 255;
if FCyan <> c then if FCyan <> c then
begin begin
FCyan := c; FCyan := c;
FArrowPos := ArrowPosFromCyan(c); FArrowPos := ArrowPosFromCyan(c);
FManual := false; FManual := false;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TCColorPicker.SetMagenta(m: integer); procedure TCColorPicker.SetMagenta(m: integer);
begin begin
if m > 255 then m := 255; if m > 255 then m := 255;
if m < 0 then m := 0; if m < 0 then m := 0;
if FMagenta <> m then if FMagenta <> m then
begin begin
FMagenta := m; FMagenta := m;
FManual := false; FManual := false;
CreateCGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TCColorPicker.SetYellow(y: integer); procedure TCColorPicker.SetYellow(y: integer);
begin begin
if y > 255 then y := 255; if y > 255 then y := 255;
if y < 0 then y := 0; if y < 0 then y := 0;
if FYellow <> y then if FYellow <> y then
begin begin
FYellow := y; FYellow := y;
FManual := false; FManual := false;
CreateCGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TCColorPicker.SetBlack(k: integer); procedure TCColorPicker.SetBlack(k: integer);
begin begin
if k > 255 then k := 255; if k > 255 then k := 255;
if k < 0 then k := 0; if k < 0 then k := 0;
if FBlack <> k then if FBlack <> k then
begin begin
FBlack := k; FBlack := k;
FManual := false; FManual := false;
CreateCGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function TCColorPicker.ArrowPosFromCyan(c: integer): integer; function TCColorPicker.ArrowPosFromCyan(c: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/255)*c); a := Round(((Width - 12)/255)*c);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
c := 255 - c; c := 255 - c;
a := Round(((Height - 12)/255)*c); a := Round(((Height - 12)/255)*c);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function TCColorPicker.CyanFromArrowPos(p: integer): integer; function TCColorPicker.CyanFromArrowPos(p: integer): integer;
var var
r: integer; r: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
r := Round(p/((Width - 12)/255)) r := Round(p/((Width - 12)/255))
else else
r := Round(255 - p/((Height - 12)/255)); r := Round(255 - p/((Height - 12)/255));
if r < 0 then r := 0; if r < 0 then r := 0;
if r > 255 then r := 255; if r > 255 then r := 255;
Result := r; Result := r;
end; end;
function TCColorPicker.GetSelectedColor: TColor; function TCColorPicker.GetSelectedColor: TColor;
begin begin
if not WebSafe then if not WebSafe then
Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)
else else
Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack));
end; end;
function TCColorPicker.GetSelectedValue: integer; function TCColorPicker.GetSelectedValue: integer;
@@ -242,45 +229,59 @@ end;
procedure TCColorPicker.SetSelectedColor(c: TColor); procedure TCColorPicker.SetSelectedColor(c: TColor);
var var
cy, m, y, k: integer; cy, m, y, k: integer;
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
ColorToCMYK(c, cy, m, y, k); ColorToCMYK(c, cy, m, y, k);
FChange := false; FChange := false;
SetMagenta(m); SetMagenta(m);
SetYellow(y); SetYellow(y);
SetBlack(k); SetBlack(k);
SetCyan(cy); SetCyan(cy);
FManual := false; FManual := false;
FChange := true; FChange := true;
if Assigned(OnChange) then OnChange(Self); if Assigned(OnChange) then OnChange(Self);
end; end;
function TCColorPicker.GetArrowPos: integer; function TCColorPicker.GetArrowPos: integer;
begin begin
Result := ArrowPosFromCyan(FCyan); Result := ArrowPosFromCyan(FCyan);
end; end;
procedure TCColorPicker.Execute(tbaAction: integer); procedure TCColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
TBA_Resize: SetCyan(FCyan); TBA_Resize:
TBA_Paint: Canvas.StretchDraw(FPickRect, FCBmp); SetCyan(FCyan);
TBA_MouseMove: FCyan := CyanFromArrowPos(FArrowPos); TBA_MouseMove:
TBA_MouseDown: FCyan := CyanFromArrowPos(FArrowPos); FCyan := CyanFromArrowPos(FArrowPos);
TBA_MouseUp: FCyan := CyanFromArrowPos(FArrowPos); TBA_MouseDown:
TBA_WheelUp: SetCyan(FCyan + Increment); FCyan := CyanFromArrowPos(FArrowPos);
TBA_WheelDown: SetCyan(FCyan - Increment); TBA_MouseUp:
TBA_VKRight: SetCyan(FCyan + Increment); FCyan := CyanFromArrowPos(FArrowPos);
TBA_VKCtrlRight: SetCyan(255); TBA_WheelUp:
TBA_VKLeft: SetCyan(FCyan - Increment); SetCyan(FCyan + Increment);
TBA_VKCtrlLeft: SetCyan(0); TBA_WheelDown:
TBA_VKUp: SetCyan(FCyan + Increment); SetCyan(FCyan - Increment);
TBA_VKCtrlUp: SetCyan(255); TBA_VKRight:
TBA_VKDown: SetCyan(FCyan - Increment); SetCyan(FCyan + Increment);
TBA_VKCtrlDown: SetCyan(0); TBA_VKCtrlRight:
TBA_RedoBMP: CreateCGradient; SetCyan(255);
end; TBA_VKLeft:
SetCyan(FCyan - Increment);
TBA_VKCtrlLeft:
SetCyan(0);
TBA_VKUp:
SetCyan(FCyan + Increment);
TBA_VKCtrlUp:
SetCyan(255);
TBA_VKDown:
SetCyan(FCyan - Increment);
TBA_VKCtrlDown:
SetCyan(0);
else
inherited;
end;
end; end;
end. end.

7
components/mbColorLib/Demo/Demo.lpi
View File

@@ -58,13 +58,6 @@
<IncludeFiles Value="$(ProjOutDir)"/> <IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths> </SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions> </CompilerOptions>
<Debugging> <Debugging>
<Exceptions Count="3"> <Exceptions Count="3">

278
components/mbColorLib/Demo/main.lfm
View File

@@ -1,64 +1,61 @@
object Form1: TForm1 object Form1: TForm1
Left = 222 Left = 255
Height = 338 Height = 344
Top = 89 Top = 107
Width = 541 Width = 543
Caption = 'mbColor Lib v2.0.1 Demo' Caption = 'mbColor Lib v2.0.1 Demo'
ClientHeight = 338 ClientHeight = 344
ClientWidth = 541 ClientWidth = 543
Color = clBtnFace
Font.Color = clWindowText Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Shell Dlg 2'
OnCreate = FormCreate OnCreate = FormCreate
ShowHint = True ShowHint = True
LCLVersion = '1.7' LCLVersion = '1.7'
object Label1: TLabel object Label1: TLabel
Left = 412 Left = 412
Height = 13 Height = 15
Top = 8 Top = 8
Width = 66 Width = 73
Anchors = [akTop, akRight] Anchors = [akTop, akRight]
Caption = 'SelectedColor' Caption = 'SelectedColor'
ParentColor = False ParentColor = False
end end
object Label2: TLabel object Label2: TLabel
Left = 410 Left = 412
Height = 13 Height = 15
Top = 112 Top = 112
Width = 86 Width = 96
Anchors = [akTop, akRight] Anchors = [akTop, akRight]
Caption = 'ColorUnderCursor' Caption = 'ColorUnderCursor'
ParentColor = False ParentColor = False
end end
object Label5: TLabel object Label5: TLabel
Left = 410 Left = 412
Height = 65 Height = 75
Top = 238 Top = 238
Width = 92 Width = 99
Anchors = [akTop, akRight] Anchors = [akTop, akRight]
Caption = 'Aditional controls:'#13#13'- Arrow keys'#13'- Ctrl + Arrow keys'#13'- Mouse wheel' Caption = 'Aditional controls:'#13#13'- Arrow keys'#13'- Ctrl + Arrow keys'#13'- Mouse wheel'
ParentColor = False ParentColor = False
end end
object PageControl1: TPageControl object PageControl1: TPageControl
Left = 6 Left = 6
Height = 325 Height = 331
Top = 6 Top = 6
Width = 397 Width = 399
ActivePage = TabSheet8 ActivePage = TabSheet11
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
TabIndex = 8 TabIndex = 6
TabOrder = 0 TabOrder = 0
object TabSheet1: TTabSheet object TabSheet1: TTabSheet
Caption = 'HSLColorPicker' Caption = 'HSLColorPicker'
ClientHeight = 0 ClientHeight = 303
ClientWidth = 0 ClientWidth = 391
object HSLColorPicker1: THSLColorPicker object HSLColorPicker1: THSLColorPicker
Left = 8 Left = 8
Height = 283 Height = 287
Top = 8 Top = 8
Width = 375 Width = 377
SelectedColor = 639239 SelectedColor = 562183
HSPickerHintFormat = 'H: %h S: %s'#13'Hex: %hex' HSPickerHintFormat = 'H: %h S: %s'#13'Hex: %hex'
LPickerHintFormat = 'Luminance: %l' LPickerHintFormat = 'Luminance: %l'
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
@@ -69,23 +66,24 @@ object Form1: TForm1
end end
object TabSheet2: TTabSheet object TabSheet2: TTabSheet
Caption = 'HexaColorPicker' Caption = 'HexaColorPicker'
ClientHeight = 0 ClientHeight = 303
ClientWidth = 0 ClientWidth = 391
ImageIndex = 1 ImageIndex = 1
object Label4: TLabel object Label4: TLabel
Left = 82 AnchorSideTop.Control = ComboBox1
Height = 13 AnchorSideTop.Side = asrCenter
Top = 278 Left = 112
Width = 37 Height = 15
Anchors = [akLeft, akBottom] Top = 282
Width = 40
Caption = 'Marker:' Caption = 'Marker:'
ParentColor = False ParentColor = False
end end
object HexaColorPicker1: THexaColorPicker object HexaColorPicker1: THexaColorPicker
Left = 48 Left = 48
Height = 267 Height = 271
Top = 4 Top = 4
Width = 283 Width = 285
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
HintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h' HintFormat = 'RGB(%r, %g, %b)'#13'Hex: %h'
IntensityText = 'Intensity' IntensityText = 'Intensity'
@@ -96,11 +94,12 @@ object Form1: TForm1
OnMouseMove = HexaColorPicker1MouseMove OnMouseMove = HexaColorPicker1MouseMove
end end
object CheckBox1: TCheckBox object CheckBox1: TCheckBox
AnchorSideTop.Control = ComboBox1
AnchorSideTop.Side = asrCenter
Left = 4 Left = 4
Height = 17 Height = 19
Top = 274 Top = 280
Width = 75 Width = 83
Anchors = [akLeft, akBottom]
Caption = 'SliderVisible' Caption = 'SliderVisible'
Checked = True Checked = True
OnClick = CheckBox1Click OnClick = CheckBox1Click
@@ -108,12 +107,12 @@ object Form1: TForm1
TabOrder = 1 TabOrder = 1
end end
object ComboBox1: TComboBox object ComboBox1: TComboBox
Left = 124 Left = 160
Height = 21 Height = 23
Top = 274 Top = 278
Width = 71 Width = 71
Anchors = [akLeft, akBottom] Anchors = [akLeft, akBottom]
ItemHeight = 13 ItemHeight = 15
ItemIndex = 0 ItemIndex = 0
Items.Strings = ( Items.Strings = (
'smArrow' 'smArrow'
@@ -125,11 +124,13 @@ object Form1: TForm1
Text = 'smArrow' Text = 'smArrow'
end end
object CheckBox2: TCheckBox object CheckBox2: TCheckBox
Left = 200 AnchorSideTop.Control = ComboBox1
Height = 17 AnchorSideTop.Side = asrCenter
Top = 276 Left = 256
Width = 97 Height = 20
Anchors = [akLeft, akBottom] Top = 279
Width = 101
Anchors = [akTop, akLeft, akBottom]
Caption = 'NewArrowStyle' Caption = 'NewArrowStyle'
OnClick = CheckBox2Click OnClick = CheckBox2Click
TabOrder = 3 TabOrder = 3
@@ -137,40 +138,43 @@ object Form1: TForm1
end end
object TabSheet3: TTabSheet object TabSheet3: TTabSheet
Caption = 'mbColorPalette' Caption = 'mbColorPalette'
ClientHeight = 0 ClientHeight = 303
ClientWidth = 0 ClientWidth = 391
ImageIndex = 2 ImageIndex = 2
object Label3: TLabel object Label3: TLabel
AnchorSideTop.Control = ComboBox2
AnchorSideTop.Side = asrCenter
Left = 6 Left = 6
Height = 13 Height = 15
Top = 272 Top = 272
Width = 24 Width = 24
Anchors = [akLeft, akBottom]
Caption = 'Sort:' Caption = 'Sort:'
ParentColor = False ParentColor = False
end end
object Label6: TLabel object Label6: TLabel
Left = 214 AnchorSideTop.Control = ComboBox4
Height = 13 AnchorSideTop.Side = asrCenter
Left = 224
Height = 15
Top = 272 Top = 272
Width = 28 Width = 28
Anchors = [akLeft, akBottom]
Caption = 'Style:' Caption = 'Style:'
ParentColor = False ParentColor = False
end end
object Label7: TLabel object Label7: TLabel
Left = 320 AnchorSideTop.Control = UpDown1
Height = 13 AnchorSideTop.Side = asrCenter
Left = 336
Height = 15
Top = 272 Top = 272
Width = 23 Width = 23
Anchors = [akLeft, akBottom]
Caption = 'Size:' Caption = 'Size:'
ParentColor = False ParentColor = False
end end
object Button1: TButton object Button1: TButton
Left = 6 Left = 6
Height = 25 Height = 25
Top = 232 Top = 236
Width = 107 Width = 107
Anchors = [akLeft, akBottom] Anchors = [akLeft, akBottom]
Caption = 'Generate blue pal' Caption = 'Generate blue pal'
@@ -180,7 +184,7 @@ object Form1: TForm1
object Button2: TButton object Button2: TButton
Left = 120 Left = 120
Height = 25 Height = 25
Top = 232 Top = 236
Width = 135 Width = 135
Anchors = [akLeft, akBottom] Anchors = [akLeft, akBottom]
Caption = 'Generate gradient pal' Caption = 'Generate gradient pal'
@@ -190,7 +194,7 @@ object Form1: TForm1
object Button4: TButton object Button4: TButton
Left = 262 Left = 262
Height = 25 Height = 25
Top = 232 Top = 236
Width = 121 Width = 121
Anchors = [akLeft, akBottom] Anchors = [akLeft, akBottom]
Caption = 'Load palette from file' Caption = 'Load palette from file'
@@ -199,15 +203,15 @@ object Form1: TForm1
end end
object ScrollBox1: TScrollBox object ScrollBox1: TScrollBox
Left = 6 Left = 6
Height = 217 Height = 221
Top = 8 Top = 8
Width = 379 Width = 381
HorzScrollBar.Page = 75 HorzScrollBar.Page = 75
VertScrollBar.Page = 217 VertScrollBar.Page = 221
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
BorderStyle = bsNone BorderStyle = bsNone
ClientHeight = 217 ClientHeight = 221
ClientWidth = 362 ClientWidth = 364
TabOrder = 3 TabOrder = 3
object mbColorPalette1: TmbColorPalette object mbColorPalette1: TmbColorPalette
Left = 0 Left = 0
@@ -482,11 +486,11 @@ object Form1: TForm1
end end
object ComboBox2: TComboBox object ComboBox2: TComboBox
Left = 34 Left = 34
Height = 21 Height = 23
Top = 266 Top = 268
Width = 87 Width = 87
Anchors = [akLeft, akBottom] Anchors = [akLeft, akBottom]
ItemHeight = 13 ItemHeight = 15
ItemIndex = 0 ItemIndex = 0
Items.Strings = ( Items.Strings = (
'soAscending' 'soAscending'
@@ -499,11 +503,11 @@ object Form1: TForm1
end end
object ComboBox3: TComboBox object ComboBox3: TComboBox
Left = 124 Left = 124
Height = 21 Height = 23
Top = 266 Top = 268
Width = 87 Width = 87
Anchors = [akLeft, akBottom] Anchors = [akLeft, akBottom]
ItemHeight = 13 ItemHeight = 15
ItemIndex = 7 ItemIndex = 7
Items.Strings = ( Items.Strings = (
'smRed' 'smRed'
@@ -531,12 +535,12 @@ object Form1: TForm1
Text = 'smNone' Text = 'smNone'
end end
object ComboBox4: TComboBox object ComboBox4: TComboBox
Left = 244 Left = 256
Height = 21 Height = 23
Top = 266 Top = 268
Width = 71 Width = 71
Anchors = [akLeft, akBottom] Anchors = [akLeft, akBottom]
ItemHeight = 13 ItemHeight = 15
ItemIndex = 0 ItemIndex = 0
Items.Strings = ( Items.Strings = (
'csDefault' 'csDefault'
@@ -548,10 +552,10 @@ object Form1: TForm1
Text = 'csDefault' Text = 'csDefault'
end end
object UpDown1: TUpDown object UpDown1: TUpDown
Left = 348 Left = 364
Height = 21 Height = 23
Top = 266 Top = 268
Width = 31 Width = 15
Anchors = [akLeft, akBottom] Anchors = [akLeft, akBottom]
Min = 0 Min = 0
OnChanging = UpDown1Changing OnChanging = UpDown1Changing
@@ -563,14 +567,14 @@ object Form1: TForm1
end end
object TabSheet4: TTabSheet object TabSheet4: TTabSheet
Caption = 'HSLRingPicker' Caption = 'HSLRingPicker'
ClientHeight = 0 ClientHeight = 303
ClientWidth = 0 ClientWidth = 391
ImageIndex = 3 ImageIndex = 3
object HSLRingPicker1: THSLRingPicker object HSLRingPicker1: THSLRingPicker
Left = 50 Left = 50
Height = 285 Height = 289
Top = 6 Top = 6
Width = 291 Width = 293
RingPickerHintFormat = 'Hue: %h' RingPickerHintFormat = 'Hue: %h'
SLPickerHintFormat = 'S: %s L: %l'#13'Hex: %hex' SLPickerHintFormat = 'S: %s L: %l'#13'Hex: %hex'
Anchors = [akTop, akLeft, akRight, akBottom] Anchors = [akTop, akLeft, akRight, akBottom]
@@ -581,8 +585,8 @@ object Form1: TForm1
end end
object TabSheet5: TTabSheet object TabSheet5: TTabSheet
Caption = 'HSVColorPicker' Caption = 'HSVColorPicker'
ClientHeight = 0 ClientHeight = 299
ClientWidth = 0 ClientWidth = 389
ImageIndex = 4 ImageIndex = 4
object HSVColorPicker1: THSVColorPicker object HSVColorPicker1: THSVColorPicker
Left = 24 Left = 24
@@ -610,11 +614,11 @@ object Form1: TForm1
end end
object TabSheet6: TTabSheet object TabSheet6: TTabSheet
Caption = 'SLHColorPicker' Caption = 'SLHColorPicker'
ClientHeight = 0 ClientHeight = 299
ClientWidth = 0 ClientWidth = 389
ImageIndex = 5 ImageIndex = 5
object SLHColorPicker1: TSLHColorPicker object SLHColorPicker1: TSLHColorPicker
Left = 6 Left = 5
Height = 287 Height = 287
Top = 6 Top = 6
Width = 379 Width = 379
@@ -628,8 +632,8 @@ object Form1: TForm1
end end
object TabSheet11: TTabSheet object TabSheet11: TTabSheet
Caption = 'Lists && Trees' Caption = 'Lists && Trees'
ClientHeight = 0 ClientHeight = 303
ClientWidth = 0 ClientWidth = 391
ImageIndex = 10 ImageIndex = 10
object mbColorList1: TmbColorList object mbColorList1: TmbColorList
Left = 192 Left = 192
@@ -661,14 +665,14 @@ object Form1: TForm1
end end
object TabSheet7: TTabSheet object TabSheet7: TTabSheet
Caption = 'More' Caption = 'More'
ClientHeight = 0 ClientHeight = 303
ClientWidth = 0 ClientWidth = 391
ImageIndex = 6 ImageIndex = 6
object Label9: TLabel object Label9: TLabel
Left = 118 Left = 128
Height = 13 Height = 15
Top = 8 Top = 8
Width = 103 Width = 113
Caption = 'HintFormat variables:' Caption = 'HintFormat variables:'
ParentColor = False ParentColor = False
end end
@@ -676,7 +680,7 @@ object Form1: TForm1
Left = 8 Left = 8
Height = 25 Height = 25
Top = 8 Top = 8
Width = 93 Width = 104
Caption = 'Pick from screen' Caption = 'Pick from screen'
TabOrder = 0 TabOrder = 0
OnSelColorChange = mbDeskPickerButton1SelColorChange OnSelColorChange = mbDeskPickerButton1SelColorChange
@@ -686,19 +690,20 @@ object Form1: TForm1
Left = 8 Left = 8
Height = 25 Height = 25
Top = 40 Top = 40
Width = 93 Width = 104
Caption = 'OfficeColorDialog' Caption = 'OfficeColorDialog'
OnClick = Button3Click OnClick = Button3Click
TabOrder = 1 TabOrder = 1
end end
object LColorPicker1: TLColorPicker object LColorPicker1: TLColorPicker
Left = 36 Left = 34
Height = 25 Height = 25
Top = 148 Top = 192
Width = 329 Width = 343
HintFormat = 'Luminance: %l' HintFormat = 'Luminance: %l'
Layout = lyHorizontal Layout = lyHorizontal
SelectionIndicator = siRect SelectionIndicator = siRect
Anchors = [akLeft, akRight, akBottom]
TabOrder = 2 TabOrder = 2
Saturation = 238 Saturation = 238
Luminance = 60 Luminance = 60
@@ -707,13 +712,14 @@ object Form1: TForm1
object VColorPicker1: TVColorPicker object VColorPicker1: TVColorPicker
Left = 34 Left = 34
Height = 21 Height = 21
Top = 116 Top = 160
Width = 335 Width = 343
HintFormat = 'Value: %v' HintFormat = 'Value: %v'
Layout = lyHorizontal Layout = lyHorizontal
ArrowPlacement = spBefore ArrowPlacement = spBefore
NewArrowStyle = True NewArrowStyle = True
SelectionIndicator = siRect SelectionIndicator = siRect
Anchors = [akLeft, akRight, akBottom]
TabOrder = 3 TabOrder = 3
Hue = 240 Hue = 240
Saturation = 255 Saturation = 255
@@ -721,21 +727,22 @@ object Form1: TForm1
SelectedColor = 2621440 SelectedColor = 2621440
end end
object HColorPicker1: THColorPicker object HColorPicker1: THColorPicker
Left = 36 Left = 34
Height = 61 Height = 61
Top = 178 Top = 231
Width = 335 Width = 343
HintFormat = 'Hue: %h' HintFormat = 'Hue: %h'
Increment = 5 Increment = 5
ArrowPlacement = spBoth ArrowPlacement = spBoth
SelectionIndicator = siRect SelectionIndicator = siRect
Anchors = [akLeft, akRight, akBottom]
TabOrder = 4 TabOrder = 4
Saturation = 120 Saturation = 120
SelectedColor = 8882175 SelectedColor = 8882175
end end
object SColorPicker1: TSColorPicker object SColorPicker1: TSColorPicker
Left = 8 Left = 8
Height = 214 Height = 222
Top = 70 Top = 70
Width = 19 Width = 19
HintFormat = 'Saturation: %s' HintFormat = 'Saturation: %s'
@@ -743,19 +750,20 @@ object Form1: TForm1
ArrowPlacement = spBefore ArrowPlacement = spBefore
NewArrowStyle = True NewArrowStyle = True
SelectionIndicator = siRect SelectionIndicator = siRect
Anchors = [akTop, akLeft, akBottom]
TabOrder = 5 TabOrder = 5
Hue = 60 Hue = 60
Saturation = 80 Saturation = 80
SelectedColor = 11534335 SelectedColor = 11534335
end end
object Memo1: TMemo object Memo1: TMemo
Left = 118 Left = 128
Height = 75 Height = 118
Top = 24 Top = 26
Width = 247 Width = 249
Anchors = [akTop, akLeft, akRight, akBottom]
Lines.Strings = ( Lines.Strings = (
'The following variables will be replaced in the ' 'The following variables will be replaced in the hint at runtime:'
'hint at runtime:'
'' ''
'%hex = HTML HEX color value' '%hex = HTML HEX color value'
'' ''
@@ -797,8 +805,8 @@ object Form1: TForm1
end end
object TabSheet8: TTabSheet object TabSheet8: TTabSheet
Caption = 'Other' Caption = 'Other'
ClientHeight = 299 ClientHeight = 292
ClientWidth = 389 ClientWidth = 372
ImageIndex = 7 ImageIndex = 7
object HSColorPicker1: THSColorPicker object HSColorPicker1: THSColorPicker
Left = 6 Left = 6
@@ -837,14 +845,14 @@ object Form1: TForm1
end end
object TabSheet9: TTabSheet object TabSheet9: TTabSheet
Caption = 'Even more' Caption = 'Even more'
ClientHeight = 0 ClientHeight = 292
ClientWidth = 0 ClientWidth = 372
ImageIndex = 8 ImageIndex = 8
object Label8: TLabel object Label8: TLabel
Left = 6 Left = 6
Height = 13 Height = 15
Top = 4 Top = 4
Width = 128 Width = 136
Caption = 'New: border styles added.' Caption = 'New: border styles added.'
ParentColor = False ParentColor = False
end end
@@ -870,7 +878,7 @@ object Form1: TForm1
object YColorPicker1: TYColorPicker object YColorPicker1: TYColorPicker
Left = 68 Left = 68
Height = 267 Height = 267
Top = 18 Top = 19
Width = 31 Width = 31
HintFormat = 'Yellow: %y' HintFormat = 'Yellow: %y'
ArrowPlacement = spBoth ArrowPlacement = spBoth
@@ -983,8 +991,8 @@ object Form1: TForm1
end end
object TabSheet10: TTabSheet object TabSheet10: TTabSheet
Caption = 'Yet even more' Caption = 'Yet even more'
ClientHeight = 0 ClientHeight = 299
ClientWidth = 0 ClientWidth = 389
ImageIndex = 9 ImageIndex = 9
object RAxisColorPicker1: TRAxisColorPicker object RAxisColorPicker1: TRAxisColorPicker
Left = 10 Left = 10
@@ -1052,15 +1060,15 @@ object Form1: TForm1
end end
end end
object sc: TmbColorPreview object sc: TmbColorPreview
Left = 410 Left = 412
Height = 62 Height = 62
Top = 24 Top = 25
Width = 108 Width = 108
Color = clNone Color = clNone
Anchors = [akTop, akRight] Anchors = [akTop, akRight]
end end
object uc: TmbColorPreview object uc: TmbColorPreview
Left = 410 Left = 412
Height = 62 Height = 62
Top = 130 Top = 130
Width = 108 Width = 108
@@ -1068,7 +1076,7 @@ object Form1: TForm1
Anchors = [akTop, akRight] Anchors = [akTop, akRight]
end end
object tb1: TTrackBar object tb1: TTrackBar
Left = 410 Left = 412
Height = 20 Height = 20
Hint = 'Opacity' Hint = 'Opacity'
Top = 90 Top = 90
@@ -1081,7 +1089,7 @@ object Form1: TForm1
TabOrder = 3 TabOrder = 3
end end
object tb2: TTrackBar object tb2: TTrackBar
Left = 410 Left = 412
Height = 20 Height = 20
Top = 196 Top = 196
Width = 108 Width = 108
@@ -1093,20 +1101,20 @@ object Form1: TForm1
TabOrder = 4 TabOrder = 4
end end
object CheckBox3: TCheckBox object CheckBox3: TCheckBox
Left = 443 Left = 412
Height = 19 Height = 19
Top = 308 Top = 320
Width = 64 Width = 66
Anchors = [akTop, akRight] Anchors = [akTop, akRight]
Caption = 'WebSafe' Caption = 'WebSafe'
OnClick = CheckBox3Click OnClick = CheckBox3Click
TabOrder = 5 TabOrder = 5
end end
object CheckBox4: TCheckBox object CheckBox4: TCheckBox
Left = 428 Left = 412
Height = 19 Height = 19
Top = 218 Top = 218
Width = 79 Width = 83
Anchors = [akTop, akRight] Anchors = [akTop, akRight]
Caption = 'SwatchStyle' Caption = 'SwatchStyle'
OnClick = CheckBox4Click OnClick = CheckBox4Click
@@ -1114,12 +1122,12 @@ object Form1: TForm1
end end
object mbOfficeColorDialog1: TmbOfficeColorDialog object mbOfficeColorDialog1: TmbOfficeColorDialog
UseHints = True UseHints = True
left = 472 left = 448
top = 302 top = 136
end end
object OpenDialog1: TOpenDialog object OpenDialog1: TOpenDialog
Filter = 'JASC PAL (*.pal)|*.pal|Photoshop (*.act; *.aco)|*.act;*.aco' Filter = 'JASC PAL (*.pal)|*.pal|Photoshop (*.act; *.aco)|*.act;*.aco'
left = 440 left = 440
top = 304 top = 40
end end
end end

284
components/mbColorLib/GColorPicker.pas
View File

@@ -5,91 +5,76 @@ unit GColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
mbTrackBarPicker, HTMLColors, Scanlines; mbTrackBarPicker, HTMLColors;
type type
TGColorPicker = class(TmbTrackBarPicker) TGColorPicker = class(TmbTrackBarPicker)
private private
FRed, FGreen, FBlue: integer; FRed, FGreen, FBlue: integer;
FBmp: TBitmap; function ArrowPosFromGreen(g: integer): integer;
function GreenFromArrowPos(p: integer): integer;
function ArrowPosFromGreen(g: integer): integer; function GetSelectedColor: TColor;
function GreenFromArrowPos(p: integer): integer; procedure SetSelectedColor(c: TColor);
function GetSelectedColor: TColor; procedure SetRed(r: integer);
procedure SetSelectedColor(c: TColor); procedure SetGreen(g: integer);
procedure CreateGGradient; procedure SetBlue(b: integer);
procedure SetRed(r: integer); protected
procedure SetGreen(g: integer); procedure Execute(tbaAction: integer); override;
procedure SetBlue(b: integer); function GetArrowPos: integer; override;
protected function GetGradientColor(AValue: Integer): TColor; override;
procedure CreateWnd; override; function GetSelectedValue: integer; override;
procedure Execute(tbaAction: integer); override; public
function GetArrowPos: integer; override; constructor Create(AOwner: TComponent); override;
function GetSelectedValue: integer; override; published
public property Red: integer read FRed write SetRed default 122;
constructor Create(AOwner: TComponent); override; property Green: integer read FGreen write SetGreen default 255;
destructor Destroy; override; property Blue: integer read FBlue write SetBlue default 122;
published property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Red: integer read FRed write SetRed default 122; property Layout default lyVertical;
property Green: integer read FGreen write SetGreen default 255; end;
property Blue: integer read FBlue write SetBlue default 122;
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Layout default lyVertical;
end;
procedure Register; procedure Register;
implementation implementation
{$IFDEF FPC} {$IFDEF FPC}
{$R GColorPicker.dcr} {$R GColorPicker.dcr}
{$ENDIF} {$ENDIF}
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TGColorPicker]); RegisterComponents('mbColor Lib', [TGColorPicker]);
end; end;
{TGColorPicker} {TGColorPicker}
constructor TGColorPicker.Create(AOwner: TComponent); constructor TGColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FBmp := TBitmap.Create; FGradientWidth := 256;
FBmp.PixelFormat := pf32bit; FGradientHeight := 12;
FBmp.SetSize(12, 256); SetInitialBounds(0, 0, 22, 268);
Width := 22; //Width := 22;
Height := 268; //Height := 268;
Layout := lyVertical; Layout := lyVertical;
FRed := 122; FRed := 122;
FGreen := 255; FGreen := 255;
FBlue := 122; FBlue := 122;
FArrowPos := ArrowPosFromGreen(255); FArrowPos := ArrowPosFromGreen(255);
FChange := false; FChange := false;
SetGreen(255); SetGreen(255);
HintFormat := 'Green: %value'; HintFormat := 'Green: %value';
FManual := false; FManual := false;
FChange := true; FChange := true;
end;
destructor TGColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
end;
procedure TGColorPicker.CreateWnd;
begin
inherited;
CreateGGradient;
end; end;
(*
procedure TGColorPicker.CreateGGradient; procedure TGColorPicker.CreateGGradient;
var var
i,j: integer; i,j: integer;
@@ -131,90 +116,93 @@ begin
end; end;
end; end;
end; end;
*)
function TGColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := RGB(FRed, AValue, FBlue);
end;
procedure TGColorPicker.SetRed(r: integer); procedure TGColorPicker.SetRed(r: integer);
begin begin
if r < 0 then r := 0; if r < 0 then r := 0;
if r > 255 then r := 255; if r > 255 then r := 255;
if FRed <> r then if FRed <> r then
begin begin
FRed := r; FRed := r;
FManual := false; FManual := false;
CreateGGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TGColorPicker.SetGreen(g: integer); procedure TGColorPicker.SetGreen(g: integer);
begin begin
if g > 255 then g := 255; if g > 255 then g := 255;
if g < 0 then g := 0; if g < 0 then g := 0;
if FGreen <> g then if FGreen <> g then
begin begin
FGreen := g; FGreen := g;
FArrowPos := ArrowPosFromGreen(g); FArrowPos := ArrowPosFromGreen(g);
FManual := false; FManual := false;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TGColorPicker.SetBlue(b: integer); procedure TGColorPicker.SetBlue(b: integer);
begin begin
if b > 255 then b := 255; if b > 255 then b := 255;
if b < 0 then b := 0; if b < 0 then b := 0;
if FBlue <> b then if FBlue <> b then
begin begin
FBlue := b; FBlue := b;
FManual := false; FManual := false;
CreateGGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function TGColorPicker.ArrowPosFromGreen(g: integer): integer; function TGColorPicker.ArrowPosFromGreen(g: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/255)*g); a := Round(((Width - 12)/255)*g);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
g := 255 - g; g := 255 - g;
a := Round(((Height - 12)/255)*g); a := Round(((Height - 12)/255)*g);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function TGColorPicker.GreenFromArrowPos(p: integer): integer; function TGColorPicker.GreenFromArrowPos(p: integer): integer;
var var
g: integer; g: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
g := Round(p/((Width - 12)/255)) g := Round(p/((Width - 12)/255))
else else
g := Round(255 - p/((Height - 12)/255)); g := Round(255 - p/((Height - 12)/255));
if g < 0 then g := 0; if g < 0 then g := 0;
if g > 255 then g := 255; if g > 255 then g := 255;
Result := g; Result := g;
end; end;
function TGColorPicker.GetSelectedColor: TColor; function TGColorPicker.GetSelectedColor: TColor;
begin begin
if not WebSafe then if not WebSafe then
Result := RGB(FRed, FGreen, FBlue) Result := RGB(FRed, FGreen, FBlue)
else else
Result := GetWebSafe(RGB(FRed, FGreen, FBlue)); Result := GetWebSafe(RGB(FRed, FGreen, FBlue));
end; end;
function TGColorPicker.GetSelectedValue: integer; function TGColorPicker.GetSelectedValue: integer;
@@ -224,41 +212,55 @@ end;
procedure TGColorPicker.SetSelectedColor(c: TColor); procedure TGColorPicker.SetSelectedColor(c: TColor);
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
FChange := false; FChange := false;
SetRed(GetRValue(c)); SetRed(GetRValue(c));
SetBlue(GetBValue(c)); SetBlue(GetBValue(c));
SetGreen(GetGValue(c)); SetGreen(GetGValue(c));
FManual := false; FManual := false;
FChange := true; FChange := true;
if Assigned(OnChange) then OnChange(Self); if Assigned(OnChange) then OnChange(Self);
end; end;
function TGColorPicker.GetArrowPos: integer; function TGColorPicker.GetArrowPos: integer;
begin begin
Result := ArrowPosFromGreen(FGreen); Result := ArrowPosFromGreen(FGreen);
end; end;
procedure TGColorPicker.Execute(tbaAction: integer); procedure TGColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
TBA_Resize: SetGreen(FGreen); TBA_Resize:
TBA_Paint: Canvas.StretchDraw(FPickRect, FBmp); SetGreen(FGreen);
TBA_MouseMove: FGreen := GreenFromArrowPos(FArrowPos); TBA_MouseMove:
TBA_MouseDown: FGreen := GreenFromArrowPos(FArrowPos); FGreen := GreenFromArrowPos(FArrowPos);
TBA_MouseUp: FGreen := GreenFromArrowPos(FArrowPos); TBA_MouseDown:
TBA_WheelUp: SetGreen(FGreen + Increment); FGreen := GreenFromArrowPos(FArrowPos);
TBA_WheelDown: SetGreen(FGreen - Increment); TBA_MouseUp:
TBA_VKRight: SetGreen(FGreen + Increment); FGreen := GreenFromArrowPos(FArrowPos);
TBA_VKCtrlRight: SetGreen(255); TBA_WheelUp:
TBA_VKLeft: SetGreen(FGreen - Increment); SetGreen(FGreen + Increment);
TBA_VKCtrlLeft: SetGreen(0); TBA_WheelDown:
TBA_VKUp: SetGreen(FGreen + Increment); SetGreen(FGreen - Increment);
TBA_VKCtrlUp: SetGreen(255); TBA_VKRight:
TBA_VKDown: SetGreen(FGreen - Increment); SetGreen(FGreen + Increment);
TBA_VKCtrlDown: SetGreen(0); TBA_VKCtrlRight:
TBA_RedoBMP: CreateGGradient; SetGreen(255);
end; TBA_VKLeft:
SetGreen(FGreen - Increment);
TBA_VKCtrlLeft:
SetGreen(0);
TBA_VKUp:
SetGreen(FGreen + Increment);
TBA_VKCtrlUp:
SetGreen(255);
TBA_VKDown:
SetGreen(FGreen - Increment);
TBA_VKCtrlDown:
SetGreen(0);
else
inherited;
end;
end; end;
end. end.

275
components/mbColorLib/HColorPicker.pas
View File

@@ -7,42 +7,38 @@ unit HColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines; RGBHSVUtils, mbTrackBarPicker, HTMLColors;
type type
THColorPicker = class(TmbTrackBarPicker) THColorPicker = class(TmbTrackBarPicker)
private private
FVal, FSat, FHue: integer; FVal, FSat, FHue: integer;
FHBmp: TBitmap; function ArrowPosFromHue(h: integer): integer;
function HueFromArrowPos(p: integer): integer;
function ArrowPosFromHue(h: integer): integer; function GetSelectedColor: TColor;
function HueFromArrowPos(p: integer): integer; procedure SetSelectedColor(c: TColor);
function GetSelectedColor: TColor; procedure SetHue(h: integer);
procedure SetSelectedColor(c: TColor); procedure SetSat(s: integer);
procedure CreateHGradient; procedure SetValue(v: integer);
procedure SetHue(h: integer); protected
procedure SetSat(s: integer); procedure Execute(tbaAction: integer); override;
procedure SetValue(v: integer); function GetArrowPos: integer; override;
protected function GetGradientColor(AValue: Integer): TColor; override;
procedure CreateWnd; override; function GetSelectedValue: integer; override;
procedure Execute(tbaAction: integer); override; public
function GetArrowPos: integer; override; constructor Create(AOwner: TComponent); override;
function GetSelectedValue: integer; override; published
public property Hue: integer read FHue write SetHue default 0;
constructor Create(AOwner: TComponent); override; property Saturation: integer read FSat write SetSat default 255;
destructor Destroy; override; property Value: integer read FVal write SetValue default 255;
published property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Hue: integer read FHue write SetHue default 0; end;
property Saturation: integer read FSat write SetSat default 255;
property Value: integer read FVal write SetValue default 255;
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
end;
procedure Register; procedure Register;
@@ -54,40 +50,30 @@ implementation
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [THColorPicker]); RegisterComponents('mbColor Lib', [THColorPicker]);
end; end;
{THColorPicker} {THColorPicker}
constructor THColorPicker.Create(AOwner: TComponent); constructor THColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FHBmp := TBitmap.Create; FGradientWidth := 256;
FHBmp.PixelFormat := pf32bit; FGradientHeight := 12;
Width := 267; SetInitialBounds(0, 0, 267, 22);
Height := 22; //Width := 267;
FSat := 255; //Height := 22;
FVal := 255; FSat := 255;
FArrowPos := ArrowPosFromHue(0); FVal := 255;
FChange := false; FArrowPos := ArrowPosFromHue(0);
SetHue(0); FChange := false;
HintFormat := 'Hue: %value'; SetHue(0);
FManual := false; HintFormat := 'Hue: %value';
FChange := true; FManual := false;
end; FChange := true;
destructor THColorPicker.Destroy;
begin
FHBmp.Free;
inherited Destroy;
end;
procedure THColorPicker.CreateWnd;
begin
inherited;
CreateHGradient;
end; end;
(*
procedure THColorPicker.CreateHGradient; procedure THColorPicker.CreateHGradient;
var var
i,j: integer; i,j: integer;
@@ -129,89 +115,92 @@ begin
end; end;
end; end;
end; end;
*)
function THColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := HSVtoColor(AValue, FSat, FVal);
end;
procedure THColorPicker.SetValue(v: integer); procedure THColorPicker.SetValue(v: integer);
begin begin
if v < 0 then v := 0; if v < 0 then v := 0;
if v > 255 then v := 255; if v > 255 then v := 255;
if FVal <> v then if FVal <> v then
begin begin
FVal := v; FVal := v;
FManual := false; FManual := false;
CreateHGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure THColorPicker.SetHue(h: integer); procedure THColorPicker.SetHue(h: integer);
begin begin
if h > 360 then h := 360; if h > 360 then h := 360;
if h < 0 then h := 0; if h < 0 then h := 0;
if FHue <> h then if FHue <> h then
begin begin
FHue := h; FHue := h;
FArrowPos := ArrowPosFromHue(h); FArrowPos := ArrowPosFromHue(h);
FManual := false; FManual := false;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure THColorPicker.SetSat(s: integer); procedure THColorPicker.SetSat(s: integer);
begin begin
if s > 255 then s := 255; if s > 255 then s := 255;
if s < 0 then s := 0; if s < 0 then s := 0;
if FSat <> s then if FSat <> s then
begin begin
FSat := s; FSat := s;
FManual := false; FManual := false;
CreateHGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function THColorPicker.ArrowPosFromHue(h: integer): integer; function THColorPicker.ArrowPosFromHue(h: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/360)*h); a := Round(((Width - 12)/360)*h);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
a := Round(((Height - 12)/360)*h); a := Round(((Height - 12)/360)*h);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function THColorPicker.HueFromArrowPos(p: integer): integer; function THColorPicker.HueFromArrowPos(p: integer): integer;
var var
r: integer; r: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
r := Round(p/((Width - 12)/360)) r := Round(p/((Width - 12)/360))
else else
r := Round(p/((Height - 12)/360)); r := Round(p/((Height - 12)/360));
if r < 0 then r := 0; if r < 0 then r := 0;
if r > 360 then r := 360; if r > 360 then r := 360;
Result := r; Result := r;
end; end;
function THColorPicker.GetSelectedColor: TColor; function THColorPicker.GetSelectedColor: TColor;
begin begin
if not WebSafe then if not WebSafe then
Result := HSVtoColor(FHue, FSat, FVal) Result := HSVtoColor(FHue, FSat, FVal)
else else
Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal)); Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal));
end; end;
function THColorPicker.GetSelectedValue: integer; function THColorPicker.GetSelectedValue: integer;
@@ -221,43 +210,57 @@ end;
procedure THColorPicker.SetSelectedColor(c: TColor); procedure THColorPicker.SetSelectedColor(c: TColor);
var var
h, s, v: integer; h, s, v: integer;
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
RGBToHSV(GetRValue(c), GetGValue(c), GetBValue(c), h, s, v); RGBToHSV(GetRValue(c), GetGValue(c), GetBValue(c), h, s, v);
FChange := false; FChange := false;
SetHue(h); SetHue(h);
SetSat(s); SetSat(s);
SetValue(v); SetValue(v);
FManual := false; FManual := false;
FChange := true; FChange := true;
if Assigned(OnChange) then OnChange(Self); if Assigned(OnChange) then OnChange(Self);
end; end;
function THColorPicker.GetArrowPos: integer; function THColorPicker.GetArrowPos: integer;
begin begin
Result := ArrowPosFromHue(FHue); Result := ArrowPosFromHue(FHue);
end; end;
procedure THColorPicker.Execute(tbaAction: integer); procedure THColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
TBA_Resize: SetHue(FHue); TBA_Resize:
TBA_Paint: Canvas.StretchDraw(FPickRect, FHBmp); SetHue(FHue);
TBA_MouseMove: FHue := HueFromArrowPos(FArrowPos); TBA_MouseMove:
TBA_MouseDown: FHue := HueFromArrowPos(FArrowPos); FHue := HueFromArrowPos(FArrowPos);
TBA_MouseUp: FHue := HueFromArrowPos(FArrowPos); TBA_MouseDown:
TBA_WheelUp: SetHue(FHue + Increment); FHue := HueFromArrowPos(FArrowPos);
TBA_WheelDown: SetHue(FHue - Increment); TBA_MouseUp:
TBA_VKLeft: SetHue(FHue - Increment); FHue := HueFromArrowPos(FArrowPos);
TBA_VKCtrlLeft: SetHue(0); TBA_WheelUp:
TBA_VKRight: SetHue(FHue + Increment); SetHue(FHue + Increment);
TBA_VKCtrlRight: SetHue(360); TBA_WheelDown:
TBA_VKUp: SetHue(FHue - Increment); SetHue(FHue - Increment);
TBA_VKCtrlUp: SetHue(0); TBA_VKLeft:
TBA_VKDown: SetHue(FHue + Increment); SetHue(FHue - Increment);
TBA_VKCtrlDown: SetHue(360); TBA_VKCtrlLeft:
TBA_RedoBMP: CreateHGradient; SetHue(0);
TBA_VKRight:
SetHue(FHue + Increment);
TBA_VKCtrlRight:
SetHue(360);
TBA_VKUp:
SetHue(FHue - Increment);
TBA_VKCtrlUp:
SetHue(0);
TBA_VKDown:
SetHue(FHue + Increment);
TBA_VKCtrlDown:
SetHue(360);
else
inherited;
end; end;
end; end;

153
components/mbColorLib/HRingPicker.pas
View File

@@ -75,6 +75,9 @@ implementation
{$IFDEF FPC} {$IFDEF FPC}
{$R HRingPicker.dcr} {$R HRingPicker.dcr}
uses
IntfGraphics, fpimage;
{$ENDIF} {$ENDIF}
procedure Register; procedure Register;
@@ -116,49 +119,76 @@ end;
procedure THRingPicker.CreateHSVCircle; procedure THRingPicker.CreateHSVCircle;
var var
dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer; dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer;
row: pRGBQuadArray; row: pRGBQuadArray;
tc: TColor; c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin begin
if FBMP = nil then if FBmp = nil then
begin
FBMP := TBitmap.Create;
FBMP.PixelFormat := pf32bit;
end;
size := Min(Width, Height);
FBMP.Width := size;
FBMP.Height := size;
Radius := size div 2;
RadiusSquared := Radius*Radius;
PaintParentBack(FBMP.Canvas);
V := FValue;
for j := 0 to size - 1 do
begin begin
Y := Size - 1 - j - Radius; FBmp := TBitmap.Create;
row := FBMP.Scanline[Size - 1 - j]; FBmp.PixelFormat := pf32bit;
for i := 0 to size - 1 do
begin
X := i - Radius;
dSquared := X*X + Y*Y;
if dSquared <= RadiusSquared then
begin
if Radius <> 0 then
S := ROUND((255*SQRT(dSquared))/Radius)
else
S := 0;
H := ROUND( 180 * (1 + ArcTan2(X, Y) / PI));
H := H + 90;
if H > 360 then H := H - 360;
if not WebSafe then
row[i] := HSVtoRGBQuad(H,S,V)
else
begin
tc := GetWebSafe(HSVtoColor(H, S, V));
row[i] := RGBtoRGBQuad(GetRValue(tc), GetGValue(tc), GetBValue(tc));
end;
end
end;
end; end;
size := Min(Width, Height);
FBmp.Width := size;
FBmp.Height := size;
PaintParentBack(FBmp);
radius := size div 2;
radiusSquared := radius * radius;
V := FValue;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(FBmp.Width, FBmp.Height);
try
intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle);
{$ENDIF}
for j := 0 to size - 1 do
begin
Y := Size - 1 - j - radius;
{$IFDEF FPC}
row := intfImg.GetDataLineStart(size - 1 - j);
{$ELSE}
row := FBmp.Scanline(size - 1 - j);
{$ENDIF}
for i := 0 to size - 1 do
begin
X := i - radius;
dSquared := X*X + Y*Y;
if dSquared <= radiusSquared then
begin
if Radius <> 0 then
S := round((255 * sqrt(dSquared)) / radius)
else
S := 0;
H := round( 180 * (1 + arctan2(X, Y) / PI)); // wp: order (x,y) is correct!
H := H + 90;
if H > 360 then H := H - 360;
if not WebSafe then
row[i] := HSVtoRGBQuad(H,S,V)
else
begin
c := GetWebSafe(HSVtoColor(H, S, V));
row[i] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
end;
end
end;
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBmp.Handle := imgHandle;
FBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
{$ENDIF}
end; end;
procedure THRingPicker.Resize; procedure THRingPicker.Resize;
@@ -267,26 +297,33 @@ end;
procedure THRingPicker.Paint; procedure THRingPicker.Paint;
var var
rgn, r1, r2: HRGN; rgn, r1, r2: HRGN;
r: TRect; r: TRect;
size: Integer;
ringwidth: Integer;
begin begin
PaintParentBack(Canvas); PaintParentBack(Canvas);
r := ClientRect; size := Min(Width, Height); // diameter of circle
r.Right := R.Left + Min(Width, Height); ringwidth := size div 2 - FRadius; // FRadius is inner radius
R.Bottom := R.Top + Min(Width, Height); r := ClientRect;
r1 := CreateEllipticRgnIndirect(R); r.Right := R.Left + size;
rgn := r1; R.Bottom := R.Top + size;
InflateRect(R, - Min(Width, Height) + FRadius, - Min(Width, Height) + FRadius); r1 := CreateEllipticRgnIndirect(R);
r2 := CreateEllipticRgnIndirect(R); if ringwidth > 0 then
CombineRgn(rgn, r1, r2, RGN_DIFF);
SelectClipRgn(Canvas.Handle, rgn);
Canvas.Draw(0, 0, FBMP);
DeleteObject(rgn);
DrawHueLine;
if FDoChange then
begin begin
if Assigned(FOnChange) then FOnChange(Self); rgn := r1;
FDoChange := false; InflateRect(R, -ringwidth, - ringwidth);
r2 := CreateEllipticRgnIndirect(R);
CombineRgn(rgn, r1, r2, RGN_DIFF);
end;
SelectClipRgn(Canvas.Handle, rgn);
Canvas.Draw(0, 0, FBmp);
DeleteObject(rgn);
DrawHueLine;
if FDoChange then
begin
if Assigned(FOnChange) then FOnChange(Self);
FDoChange := false;
end; end;
end; end;

43
components/mbColorLib/HSColorPicker.pas
View File

@@ -10,10 +10,10 @@ uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages, Scanlines,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms, SysUtils, Classes, Controls, Graphics, Math, Forms,
RGBHSLUtils, HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines; RGBHSLUtils, HTMLColors, SelPropUtils, mbColorPickerControl;
type type
THSColorPicker = class(TmbColorPickerControl) THSColorPicker = class(TmbColorPickerControl)
@@ -66,6 +66,9 @@ implementation
{$IFDEF FPC} {$IFDEF FPC}
{$R HSColorPicker.dcr} {$R HSColorPicker.dcr}
uses
IntfGraphics, fpimage;
{$ENDIF} {$ENDIF}
procedure Register; procedure Register;
@@ -109,6 +112,7 @@ begin
CreateHSLGradient; CreateHSLGradient;
end; end;
{$IFDEF DELPHI}
procedure THSColorPicker.CreateHSLGradient; procedure THSColorPicker.CreateHSLGradient;
var var
Hue, Sat : integer; Hue, Sat : integer;
@@ -133,6 +137,41 @@ begin
// FHSLBmp.Canvas.Pixels[Hue, 240 - Sat] := GetWebSafe(HSLRangeToRGB(Hue, Sat, 120)); // FHSLBmp.Canvas.Pixels[Hue, 240 - Sat] := GetWebSafe(HSLRangeToRGB(Hue, Sat, 120));
end; end;
end; end;
{$ELSE}
procedure THSColorPicker.CreateHSLGradient;
var
Hue, Sat: Integer;
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
c: TColor;
begin
if FHSLBmp = nil then
begin
FHSLBmp := TBitmap.Create;
FHSLBmp.PixelFormat := pf32Bit;
FHSLBmp.Width := 240;
FHSLBmp.Height := 241;
end;
intfimg := TLazIntfImage.Create(FHSLBmp.Width, FHSLBmp.Height);
try
intfImg.LoadFromBitmap(FHSLBmp.Handle, FHSLBmp.MaskHandle);
for Hue := 0 to 239 do
for Sat := 0 to 240 do
begin
if not WebSafe then
c := HSLRangeToRGB(Hue, Sat, 120)
else
c := GetWebSafe(HSLRangeToRGB(Hue, Sat, 120));
intfimg.Colors[Hue, 240-Sat] := TColorToFPColor(c);
end;
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FHSLBmp.Handle := imgHandle;
FHSLBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
end;
{$ENDIF}
procedure THSColorPicker.CorrectCoords(var x, y: integer); procedure THSColorPicker.CorrectCoords(var x, y: integer);
begin begin

148
components/mbColorLib/HSLColorPicker.pas
View File

@@ -16,10 +16,10 @@ uses
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, Menus, SysUtils, Classes, Controls, Graphics, Forms, Menus,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} {$IFDEF DELPHI_7_UP} Themes, {$ENDIF}
RGBHSLUtils, HSColorPicker, LColorPicker, HTMLColors; RGBHSLUtils, HSColorPicker, LColorPicker, HTMLColors, mbBasicPicker;
type type
THSLColorPicker = class(TCustomControl) THSLColorPicker = class(TmbBasicPicker)
private private
FOnChange: TNotifyEvent; FOnChange: TNotifyEvent;
FHSPicker: THSColorPicker; FHSPicker: THSColorPicker;
@@ -48,14 +48,12 @@ type
procedure SetHSMenu(m: TPopupMenu); procedure SetHSMenu(m: TPopupMenu);
procedure SetHSCursor(c: TCursor); procedure SetHSCursor(c: TCursor);
procedure SetLCursor(c: TCursor); procedure SetLCursor(c: TCursor);
procedure PaintParentBack;
procedure SetSelectedColor(Value: TColor); procedure SetSelectedColor(Value: TColor);
protected protected
procedure CreateWnd; override; procedure CreateWnd; override;
procedure Resize; override; procedure Resize; override;
procedure Paint; override; procedure Paint; override;
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); procedure PaintParentBack; override;
message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF}); procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF});
message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF}; message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
@@ -121,55 +119,61 @@ end;
constructor THSLColorPicker.Create(AOwner: TComponent); constructor THSLColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];
DoubleBuffered := true; DoubleBuffered := true;
ParentColor := true; PBack := TBitmap.Create;
PBack := TBitmap.Create; PBack.PixelFormat := pf32bit;
PBack.PixelFormat := pf32bit; {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} ParentBackground := true;
ParentBackground := true; {$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF} SetInitialBounds(0, 0, 206, 146);
Width := 206; //Width := 206;
Height := 146; //Height := 146;
TabStop := true; TabStop := true;
FSelectedColor := clRed; FSelectedColor := clRed;
FHSPicker := THSColorPicker.Create(Self); FHSPicker := THSColorPicker.Create(Self);
InsertControl(FHSPicker); InsertControl(FHSPicker);
FLumIncrement := 1; FLumIncrement := 1;
FHSCursor := crDefault; FHSCursor := crDefault;
FLCursor := crDefault; FLCursor := crDefault;
with FHSPicker do with FHSPicker do
begin begin
Height := 134; SetInitialBounds(0, 6, 174, 134);
Width := 174; {
Top := 6; Height := 134;
Left := 0; Width := 174;
Anchors := [akLeft, akTop, akRight, akBottom]; Top := 6;
Visible := true; Left := 0;
OnChange := HSPickerChange; }
OnMouseMove := DoMouseMove; Anchors := [akLeft, akTop, akRight, akBottom];
Visible := true;
OnChange := HSPickerChange;
OnMouseMove := DoMouseMove;
end; end;
FLPicker := TLColorPicker.Create(Self); FLPicker := TLColorPicker.Create(Self);
InsertControl(FLPicker); InsertControl(FLPicker);
with FLPicker do with FLPicker do
begin begin
Height := 146; SetInitialBounds(184, 0, 25, 146);
Top := 0; {
Left := 184; Height := 146;
Anchors := [akRight, akTop, akBottom]; Top := 0;
Visible := true; Left := 184;
OnChange := LPickerChange; }
OnMouseMove := DoMouseMove; Anchors := [akRight, akTop, akBottom];
Visible := true;
OnChange := LPickerChange;
OnMouseMove := DoMouseMove;
end; end;
FHValue := 0; FHValue := 0;
FSValue := 240; FSValue := 240;
FLValue := 120; FLValue := 120;
FRValue := 255; FRValue := 255;
FGValue := 0; FGValue := 0;
FBValue := 0; FBValue := 0;
FHSHint := 'H: %h S: %hslS'#13'Hex: %hex'; FHSHint := 'H: %h S: %hslS'#13'Hex: %hex';
FLHint := 'Luminance: %l'; FLHint := 'Luminance: %l';
end; end;
destructor THSLColorPicker.Destroy; destructor THSLColorPicker.Destroy;
@@ -328,11 +332,6 @@ begin
end; end;
procedure THSLColorPicker.PaintParentBack; procedure THSLColorPicker.PaintParentBack;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
var
MemDC: HDC;
OldBMP: HBITMAP;
{$ENDIF} {$ENDIF}
begin begin
if PBack = nil then if PBack = nil then
begin begin
@@ -341,31 +340,22 @@ begin
end; end;
PBack.Width := Width; PBack.Width := Width;
PBack.Height := Height; PBack.Height := Height;
{$IFDEF FPC} PaintParentBack(PBack);
if Color = clDefault then
PBack.Canvas.Brush.Color := clForm
else
{$ENDIF}
PBack.Canvas.Brush.Color := Color;
PBack.Canvas.FillRect(PBack.Canvas.ClipRect);
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
if ParentBackground then
with ThemeServices do
if ThemesEnabled then
begin
MemDC := CreateCompatibleDC(0);
OldBMP := SelectObject(MemDC, PBack.Handle);
DrawParentBackground(Handle, MemDC, nil, False);
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF} {$ENDIF}
end; end;
procedure THSLColorPicker.Resize; procedure THSLColorPicker.Resize;
begin begin
inherited; inherited;
PaintParentBack; PaintParentBack;
if (FHSPicker = nil) or (FLPicker = nil) then
exit;
FHSPicker.Width := Width - FLPicker.Width - 15;
FHSPicker.Height := Height - 12;
FLPicker.Left := Width - FLPicker.Width - 2;
FLPicker.Height := Height; // - 12;
end; end;
procedure THSLColorPicker.CreateWnd; procedure THSLColorPicker.CreateWnd;
@@ -380,12 +370,6 @@ begin
Canvas.Draw(0, 0, PBack); Canvas.Draw(0, 0, PBack);
end; end;
procedure THSLColorPicker.WMEraseBkgnd(
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF} );
begin
Message.Result := 1;
end;
procedure THSLColorPicker.SetSelectedColor(Value: TColor); procedure THSLColorPicker.SetSelectedColor(Value: TColor);
begin begin
if FSelectedColor <> Value then if FSelectedColor <> Value then

71
components/mbColorLib/HSLRingPicker.pas
View File

@@ -16,10 +16,10 @@ uses
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, Menus, Math, SysUtils, Classes, Controls, Graphics, Forms, Menus, Math,
{$IFDEF DELPHI_7_UP}Themes,{$ENDIF} {$IFDEF DELPHI_7_UP}Themes,{$ENDIF}
RGBHSLUtils, HRingPicker, SLColorPicker, HTMLColors; RGBHSLUtils, HRingPicker, SLColorPicker, HTMLColors, mbBasicPicker;
type type
THSLRingPicker = class(TCustomControl) THSLRingPicker = class(TmbBasicPicker)
private private
FOnChange: TNotifyEvent; FOnChange: TNotifyEvent;
FRingPicker: THRingPicker; FRingPicker: THRingPicker;
@@ -46,7 +46,6 @@ type
procedure SetRingMenu(m: TPopupMenu); procedure SetRingMenu(m: TPopupMenu);
procedure SetRingCursor(c: TCursor); procedure SetRingCursor(c: TCursor);
procedure SetSLCursor(c: TCursor); procedure SetSLCursor(c: TCursor);
procedure PaintParentBack;
protected protected
procedure CreateWnd; override; procedure CreateWnd; override;
procedure Paint; override; procedure Paint; override;
@@ -56,10 +55,8 @@ type
procedure DoChange; procedure DoChange;
procedure Resize; override; procedure Resize; override;
{$IFDEF DELPHI} {$IFDEF DELPHI}
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS; procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
{$ELSE} {$ELSE}
procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS; procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS;
{$ENDIF} {$ENDIF}
public public
@@ -123,7 +120,6 @@ begin
inherited; inherited;
ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}]; ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}];
DoubleBuffered := true; DoubleBuffered := true;
ParentColor := true;
PBack := TBitmap.Create; PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit; PBack.PixelFormat := pf32bit;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
@@ -143,6 +139,7 @@ begin
Width := 246; Width := 246;
Top := 0; Top := 0;
Left := 0; Left := 0;
Radius := 100;
Align := alClient; Align := alClient;
Visible := true; Visible := true;
Saturation := 255; Saturation := 255;
@@ -182,16 +179,33 @@ begin
end; end;
procedure THSLRingPicker.Resize; procedure THSLRingPicker.Resize;
var
circ: TPoint;
ctr: double;
begin begin
inherited; inherited;
if (FRingPicker = nil) or (FSLPicker = nil) then if (FRingPicker = nil) or (FSLPicker = nil) then
exit; exit;
ctr := Min(Width, Height)/100;
circ.x := Min(Width, Height) div 2;
circ.y := circ.x;
FRingPicker.Radius := circ.x - round(12*ctr);
FSLPicker.Left := circ.x - FSLPicker.Width div 2;
FSLPicker.Top := circ.y - FSLPicker.Height div 2;
FSLPicker.Width := round(50*ctr);
FSLPicker.Height := FSLPicker.Width;
(*
FRingPicker.Radius := (Min(Width, Height)*30) div 245; FRingPicker.Radius := (Min(Width, Height)*30) div 245;
FSLPicker.Left := (21*FRingPicker.Radius) div 10; FSLPicker.Left := (21*FRingPicker.Radius) div 10;
FSLPicker.Top := (21*FRingPicker.Radius) div 10; FSLPicker.Top := (21*FRingPicker.Radius) div 10;
FSLPicker.Width := 4*FRingPicker.Radius; FSLPicker.Width := 4*FRingPicker.Radius;
FSLPicker.Height := 4*FRingPicker.Radius; FSLPicker.Height := 4*FRingPicker.Radius;
PaintParentBack; *)
PaintParentBack(PBack);
end; end;
procedure THSLRingPicker.RingPickerChange(Sender: TObject); procedure THSLRingPicker.RingPickerChange(Sender: TObject);
@@ -351,55 +365,16 @@ begin
Result := FRingPicker.Manual or FSLPicker.Manual; Result := FRingPicker.Manual or FSLPicker.Manual;
end; end;
procedure THSLRingPicker.PaintParentBack;
var
MemDC: HDC;
OldBMP: HBITMAP;
begin
if PBack = nil then
begin
PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit;
end;
PBack.Width := Width;
PBack.Height := Height;
{$IFDEF FPC}
if Color = clDefault then
PBack.Canvas.Brush.Color := clForm
else
{$ENDIF}
PBack.Canvas.Brush.Color := Color;
PBack.Canvas.FillRect(PBack.Canvas.ClipRect);
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
if ParentBackground then
with ThemeServices do
if ThemesEnabled then
begin
MemDC := CreateCompatibleDC(0);
OldBMP := SelectObject(MemDC, PBack.Handle);
DrawParentBackground(Handle, MemDC, nil, False);
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF} {$ENDIF}
end;
procedure THSLRingPicker.Paint; procedure THSLRingPicker.Paint;
begin begin
PaintParentBack; PaintParentBack(PBack);
Canvas.Draw(0, 0, PBack); Canvas.Draw(0, 0, PBack);
end; end;
procedure THSLRingPicker.CreateWnd; procedure THSLRingPicker.CreateWnd;
begin begin
inherited; inherited;
PaintParentBack; PaintParentBack(PBack);
end;
procedure THSLRingPicker.WMEraseBkgnd(
var Message: {$IFDEF DELPHI}TWMEraseBkgnd{$ELSE}TLMEraseBkgnd{$ENDIF} );
begin
Message.Result := 1;
end; end;
end. end.

103
components/mbColorLib/HSVColorPicker.pas
View File

@@ -85,6 +85,9 @@ implementation
{$IFDEF FPC} {$IFDEF FPC}
{$R HSVColorPicker.dcr} {$R HSVColorPicker.dcr}
uses
IntfGraphics, fpimage;
{$ENDIF} {$ENDIF}
procedure Register; procedure Register;
@@ -153,51 +156,83 @@ end;
procedure THSVColorPicker.CreateHSVCircle; procedure THSVColorPicker.CreateHSVCircle;
var var
dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer; dSquared, H, S, V, i, j, radius, radiusSquared, x, y, size: integer;
row: pRGBQuadArray; row: pRGBQuadArray;
tc: TColor; c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin begin
if FHSVBmp = nil then if FHSVBmp = nil then
begin begin
FHSVBmp := TBitmap.Create; FHSVBmp := TBitmap.Create;
FHSVBmp.PixelFormat := pf32bit; FHSVBmp.PixelFormat := pf32bit;
end; end;
size := Min(Width, Height);
FHSVBmp.Width := size;
FHSVBmp.Height := size;
Radius := size div 2; size := Min(Width, Height);
RadiusSquared := Radius*Radius; FHSVBmp.Width := size;
PaintParentBack(FHSVBmp.Canvas); FHSVBmp.Height := size;
PaintParentBack(FHSVBmp.Canvas);
V := FValue; radius := size div 2;
for j := 0 to size-1 do radiusSquared := radius * radius;
begin V := FValue;
Y := Size - 1 - j - Radius;
row := FHSVBmp.Scanline[Size - 1 - j]; {$IFDEF FPC}
for i := 0 to size-1 do intfimg := TLazIntfImage.Create(FHSVBmp.Width, FHSVBmp.Height);
try
intfImg.LoadFromBitmap(FHSVBmp.Handle, FHSVBmp.MaskHandle);
{$ENDIF}
for j := 0 to size - 1 do
begin begin
X := i - Radius; Y := size - 1 - j - Radius;
dSquared := X*X + Y*Y; {$IFDEF FPC}
if dSquared <= RadiusSquared then row := intfImg.GetDataLineStart(size - 1 - j);
{$ELSE}
row := FHSVBmp.Scanline(size - 1 - j);
{$ENDIF}
for i := 0 to size - 1 do
begin begin
if Radius <> 0 then X := i - Radius;
S := ROUND((255*SQRT(dSquared))/Radius) dSquared := X*X + Y*Y;
else if dSquared <= RadiusSquared then
S := 0;
H := ROUND(180*(1 + ArcTan2(X, Y)/PI));
H := H + 90;
if H > 360 then H := H - 360;
if not WebSafe then
row[i] := HSVtoRGBQuad(H,S,V)
else
begin begin
tc := GetWebSafe(HSVtoColor(H, S, V)); if Radius <> 0 then
row[i] := RGBtoRGBQuad(GetRValue(tc), GetGValue(tc), GetBValue(tc)); S := round(255.0 * sqrt(dSquared) / radius)
else
S := 0;
H := round(180 * (1 + arctan2(X, Y) / pi)); // wp: order (x,y) is correct!
H := H + 90;
if H > 360 then H := H - 360;
{$IFDEF FPC}
c := HSVtoColor(H, S, V);
if WebSafe then
c := GetWebSafe(c);
row^[i].rgbRed := GetRValue(c);
row^[i].rgbGreen := GetGValue(c);
row^[i].rgbBlue := GetBValue(c);
{$ELSE}
if not WebSafe then
row[i] := HSVtoRGBQuad(H,S,V)
else
begin
c := GetWebSafe(HSVtoColor(H, S, V));
row[i] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
end;
{$ENDIF}
end; end;
end end;
end; end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FHSVBmp.Handle := imgHandle;
FHSVBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end; end;
{$ENDIF}
end; end;
procedure THSVColorPicker.Resize; procedure THSVColorPicker.Resize;

83
components/mbColorLib/HexaColorPicker.pas
View File

@@ -16,7 +16,7 @@ uses
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, StdCtrls, Forms, SysUtils, Classes, Controls, Graphics, StdCtrls, Forms,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, RGBHSLUtils, Math, {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, RGBHSLUtils, Math,
RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils; RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, mbBasicPicker;
const const
CustomCell = -2; CustomCell = -2;
@@ -43,7 +43,7 @@ type
TSelectionMode = (smNone, smColor, smBW, smRamp); TSelectionMode = (smNone, smColor, smBW, smRamp);
THexaColorPicker = class(TCustomControl) THexaColorPicker = class(TmbBasicPicker)
private private
FIncrement: integer; FIncrement: integer;
FSelectedCombIndex: integer; FSelectedCombIndex: integer;
@@ -60,7 +60,7 @@ type
FCenterColor: TRGBrec; FCenterColor: TRGBrec;
FCenterIntensity: Single; FCenterIntensity: Single;
FSliderWidth: integer; FSliderWidth: integer;
FCustomIndex, // If FSelectedIndex contains CustomCell then this index shows FCustomIndex: Integer; // If FSelectedIndex contains CustomCell then this index shows
// which index in the custom area has been selected. // which index in the custom area has been selected.
// Positive values indicate the color comb and negative values // Positive values indicate the color comb and negative values
// indicate the B&W combs (complement). This value is offset with // indicate the B&W combs (complement). This value is offset with
@@ -84,7 +84,6 @@ type
procedure DrawAll; procedure DrawAll;
procedure SetSelectedColor(const Value: TColor); procedure SetSelectedColor(const Value: TColor);
procedure DrawCombControls; procedure DrawCombControls;
procedure PaintParentBack;
procedure DrawComb(Canvas: TCanvas; X, Y, Size: Integer); procedure DrawComb(Canvas: TCanvas; X, Y, Size: Integer);
procedure HandleCustomColors(var Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}); procedure HandleCustomColors(var Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF});
procedure CalculateCombLayout; procedure CalculateCombLayout;
@@ -101,23 +100,25 @@ type
function GetNextCombIndex(i: integer): integer; function GetNextCombIndex(i: integer): integer;
function GetPreviousCombIndex(i: integer): integer; function GetPreviousCombIndex(i: integer): integer;
protected protected
procedure CreateWnd; override;
procedure Paint; override;
procedure Resize; override;
procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); {$IFDEF DELPHI}
message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF}; procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF}); procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
message CN_KEYDOWN; procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure CMHintShow(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF}); procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
message CM_HINTSHOW; procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
procedure WMLButtonDown(var Message: {$IFDEF FPC}TLMLButtonDown{$ELSE}TWMLButtonDown{$ENDIF}); {$ELSE}
message {$IFDEF FPC}LM_LBUTTONDOWN{$ELSE}WM_LBUTTONDOWN{$ENDIF}; procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN;
procedure WMLButtonUp(var Message: {$IFDEF FPC}TLMLButtonUp{$ELSE}TWMLButtonUp{$ENDIF}); procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW;
message {$IFDEF FPC}LM_LBUTTONUP{$ELSE}WM_LBUTTONUP{$ENDIF}; procedure WMLButtonDown(var Message: TLMLButtonDown); message LM_LBUTTONDOWN;
procedure WMMouseMove(var Message: {$IFDEF FPC}TLMMouseMove{$ELSE}TWMMouseMove{$ENDIF}); procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP;
message {$IFDEF FPC}LM_MOUSEMOVE{$ELSE}WM_MOUSEMOVE{$ENDIF}; procedure WMMouseMove(var Message: TLMMouseMove); message LM_MOUSEMOVE;
procedure Paint; override; {$ENDIF}
procedure CreateWnd; override;
procedure Resize; override;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; destructor Destroy; override;
@@ -145,12 +146,12 @@ type
property Visible; property Visible;
property Enabled; property Enabled;
property PopupMenu; property PopupMenu;
property ParentColor default true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
property ParentBackground default true; property ParentBackground default true;
{$ENDIF}{$ENDIF} {$ENDIF}{$ENDIF}
property TabOrder; property TabOrder;
property Color; property Color;
property ParentColor;
property SliderWidth: integer read FSliderWidth write SetSliderWidth default 12; property SliderWidth: integer read FSliderWidth write SetSliderWidth default 12;
property DragCursor; property DragCursor;
property DragMode; property DragMode;
@@ -214,7 +215,6 @@ begin
FRadius := 90; FRadius := 90;
FSliderWidth := 12; FSliderWidth := 12;
DoubleBuffered := true; DoubleBuffered := true;
ParentColor := true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true; ParentBackground := true;
{$ENDIF}{$ENDIF} {$ENDIF}{$ENDIF}
@@ -453,47 +453,6 @@ begin
EnumerateCombs; EnumerateCombs;
end; end;
procedure THexaColorPicker.WMEraseBkgnd(
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
begin
Message.Result := 1;
end;
procedure THexaColorPicker.PaintParentBack;
var
OffScreen: TBitmap;
{$IFDEF DELPHI_7_UP}
MemDC: HDC;
OldBMP: HBITMAP;
{$ENDIF}
begin
Offscreen := TBitmap.Create;
Offscreen.PixelFormat := pf32bit;
Offscreen.Width := Width;
Offscreen.Height := Height;
{$IFDEF FPC}
if Color = clDefault then
Offscreen.Canvas.Brush.Color := clForm
else
{$ENDIF}
Offscreen.Canvas.Brush.Color := Color;
Offscreen.Canvas.FillRect(Offscreen.Canvas.ClipRect);
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
if ParentBackground then
with ThemeServices do
if ThemesEnabled then
begin
MemDC := CreateCompatibleDC(0);
OldBMP := SelectObject(MemDC, OffScreen.Handle);
DrawParentBackground(Handle, MemDC, nil, False);
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF}{$ENDIF}
Canvas.Draw(0, 0, Offscreen);
Offscreen.Free;
end;
procedure THexaColorPicker.Paint; procedure THexaColorPicker.Paint;
begin begin
PaintParentBack; PaintParentBack;

313
components/mbColorLib/KColorPicker.pas
View File

@@ -7,45 +7,41 @@ unit KColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines; RGBCMYKUtils, mbTrackBarPicker, HTMLColors;
type type
TKColorPicker = class(TmbTrackBarPicker) TKColorPicker = class(TmbTrackBarPicker)
private private
FCyan, FMagenta, FYellow, FBlack: integer; FCyan, FMagenta, FYellow, FBlack: integer;
FKBmp: TBitmap; function ArrowPosFromBlack(k: integer): integer;
function BlackFromArrowPos(p: integer): integer;
function ArrowPosFromBlack(k: integer): integer; function GetSelectedColor: TColor;
function BlackFromArrowPos(p: integer): integer; procedure SetSelectedColor(c: TColor);
function GetSelectedColor: TColor; procedure SetCyan(c: integer);
procedure SetSelectedColor(c: TColor); procedure SetMagenta(m: integer);
procedure CreateKGradient; procedure SetYellow(y: integer);
procedure SetCyan(c: integer); procedure SetBlack(k: integer);
procedure SetMagenta(m: integer); protected
procedure SetYellow(y: integer); procedure Execute(tbaAction: integer); override;
procedure SetBlack(k: integer); function GetArrowPos: integer; override;
protected function GetGradientColor(AValue: Integer): TColor; override;
procedure CreateWnd; override; function GetSelectedValue: integer; override;
procedure Execute(tbaAction: integer); override; public
function GetArrowPos: integer; override; constructor Create(AOwner: TComponent); override;
function GetSelectedValue: integer; override; published
public property Cyan: integer read FCyan write SetCyan default 255;
constructor Create(AOwner: TComponent); override; property Magenta: integer read FMagenta write SetMagenta default 0;
destructor Destroy; override; property Yellow: integer read FYellow write SetYellow default 0;
published property Black: integer read FBlack write SetBlack default 0;
property Cyan: integer read FCyan write SetCyan default 255; property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Magenta: integer read FMagenta write SetMagenta default 0; property Layout default lyVertical;
property Yellow: integer read FYellow write SetYellow default 0; end;
property Black: integer read FBlack write SetBlack default 0;
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Layout default lyVertical;
end;
procedure Register; procedure Register;
@@ -57,47 +53,36 @@ implementation
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TKColorPicker]); RegisterComponents('mbColor Lib', [TKColorPicker]);
end; end;
{TKColorPicker} {TKColorPicker}
constructor TKColorPicker.Create(AOwner: TComponent); constructor TKColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FKBmp := TBitmap.Create; FGradientWidth := 256;
FKBmp.PixelFormat := pf32bit; FGradientHeight := 12;
FKBmp.SetSize(12, 255); SetInitialBounds(0, 0, 22, 267);
Width := 22; //Width := 22;
Height := 267; //Height := 267;
Layout := lyVertical; Layout := lyVertical;
FCyan := 0; FCyan := 0;
FMagenta := 0; FMagenta := 0;
FYellow := 0; FYellow := 0;
FBlack := 255; FBlack := 255;
FArrowPos := ArrowPosFromBlack(255); FArrowPos := ArrowPosFromBlack(255);
FChange := false; FChange := false;
SetBlack(255); SetBlack(255);
HintFormat := 'Black: %value'; HintFormat := 'Black: %value';
FManual := false; FManual := false;
FChange := true; FChange := true;
end;
destructor TKColorPicker.Destroy;
begin
FKBmp.Free;
inherited Destroy;
end;
procedure TKColorPicker.CreateWnd;
begin
inherited;
CreateKGradient;
end; end;
(*
procedure TKColorPicker.CreateKGradient; procedure TKColorPicker.CreateKGradient;
var var
i,j: integer; i,j: integer;
row: pRGBQuadArray; row: pRGBQuadArray;
begin begin
if FKBmp = nil then if FKBmp = nil then
@@ -138,105 +123,107 @@ begin
end; end;
end; end;
end; end;
*)
function TKColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := CMYKtoTColor(FCyan, FMagenta, FYellow, AValue);
end;
procedure TKColorPicker.SetBlack(k: integer); procedure TKColorPicker.SetBlack(k: integer);
begin begin
if k < 0 then k := 0; if k < 0 then k := 0;
if k > 255 then k := 255; if k > 255 then k := 255;
if FBlack <> k then if FBlack <> k then
begin begin
FBlack := k; FBlack := k;
FArrowPos := ArrowPosFromBlack(k); FArrowPos := ArrowPosFromBlack(k);
FManual := false; FManual := false;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TKColorPicker.SetMagenta(m: integer); procedure TKColorPicker.SetMagenta(m: integer);
begin begin
if m > 255 then m := 255; if m > 255 then m := 255;
if m < 0 then m := 0; if m < 0 then m := 0;
if FMagenta <> m then if FMagenta <> m then
begin begin
FMagenta := m; FMagenta := m;
FManual := false; FManual := false;
CreateKGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TKColorPicker.SetYellow(y: integer); procedure TKColorPicker.SetYellow(y: integer);
begin begin
if y > 255 then y := 255; if y > 255 then y := 255;
if y < 0 then y := 0; if y < 0 then y := 0;
if FYellow <> y then if FYellow <> y then
begin begin
FYellow := y; FYellow := y;
FManual := false; FManual := false;
CreateKGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TKColorPicker.SetCyan(c: integer); procedure TKColorPicker.SetCyan(c: integer);
begin begin
if c > 255 then c := 255; if c > 255 then c := 255;
if c < 0 then c := 0; if c < 0 then c := 0;
if FCyan <> c then if FCyan <> c then
begin begin
FCyan := c; FCyan := c;
FManual := false; FManual := false;
CreateKGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function TKColorPicker.ArrowPosFromBlack(k: integer): integer; function TKColorPicker.ArrowPosFromBlack(k: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/255)*k); a := Round(((Width - 12)/255)*k);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
k := 255 - k; k := 255 - k;
a := Round(((Height - 12)/255)*k); a := Round(((Height - 12)/255)*k);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function TKColorPicker.BlackFromArrowPos(p: integer): integer; function TKColorPicker.BlackFromArrowPos(p: integer): integer;
var var
r: integer; r: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
r := Round(p/((Width - 12)/255)) r := Round(p/((Width - 12)/255))
else else
r := Round(255 - p/((Height - 12)/255)); r := Round(255 - p/((Height - 12)/255));
if r < 0 then r := 0; if r < 0 then r := 0;
if r > 255 then r := 255; if r > 255 then r := 255;
Result := r; Result := r;
end; end;
function TKColorPicker.GetSelectedColor: TColor; function TKColorPicker.GetSelectedColor: TColor;
begin begin
if not WebSafe then if not WebSafe then
Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)
else else
Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack));
end; end;
function TKColorPicker.GetSelectedValue: integer; function TKColorPicker.GetSelectedValue: integer;
@@ -246,45 +233,59 @@ end;
procedure TKColorPicker.SetSelectedColor(c: TColor); procedure TKColorPicker.SetSelectedColor(c: TColor);
var var
cy, m, y, k: integer; cy, m, y, k: integer;
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
ColorToCMYK(c, cy, m, y, k); ColorToCMYK(c, cy, m, y, k);
FChange := false; FChange := false;
SetMagenta(m); SetMagenta(m);
SetYellow(y); SetYellow(y);
SetCyan(cy); SetCyan(cy);
SetBlack(k); SetBlack(k);
FManual := false; FManual := false;
FChange := true; FChange := true;
if Assigned(OnChange) then OnChange(Self); if Assigned(OnChange) then OnChange(Self);
end; end;
function TKColorPicker.GetArrowPos: integer; function TKColorPicker.GetArrowPos: integer;
begin begin
Result := ArrowPosFromBlack(FBlack); Result := ArrowPosFromBlack(FBlack);
end; end;
procedure TKColorPicker.Execute(tbaAction: integer); procedure TKColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
TBA_Resize: SetBlack(FBlack); TBA_Resize:
TBA_Paint: Canvas.StretchDraw(FPickRect, FKBmp); SetBlack(FBlack);
TBA_MouseMove: FBlack := BlackFromArrowPos(FArrowPos); TBA_MouseMove:
TBA_MouseDown: FBlack := BlackFromArrowPos(FArrowPos); FBlack := BlackFromArrowPos(FArrowPos);
TBA_MouseUp: FBlack := BlackFromArrowPos(FArrowPos); TBA_MouseDown:
TBA_WheelUp: SetBlack(FBlack + Increment); FBlack := BlackFromArrowPos(FArrowPos);
TBA_WheelDown: SetBlack(FBlack - Increment); TBA_MouseUp:
TBA_VKRight: SetBlack(FBlack + Increment); FBlack := BlackFromArrowPos(FArrowPos);
TBA_VKCtrlRight: SetBlack(255); TBA_WheelUp:
TBA_VKLeft: SetBlack(FBlack - Increment); SetBlack(FBlack + Increment);
TBA_VKCtrlLeft: SetBlack(0); TBA_WheelDown:
TBA_VKUp: SetBlack(FBlack + Increment); SetBlack(FBlack - Increment);
TBA_VKCtrlUp: SetBlack(255); TBA_VKRight:
TBA_VKDown: SetBlack(FBlack - Increment); SetBlack(FBlack + Increment);
TBA_VKCtrlDown: SetBlack(0); TBA_VKCtrlRight:
TBA_RedoBMP: CreateKGradient; SetBlack(255);
end; TBA_VKLeft:
SetBlack(FBlack - Increment);
TBA_VKCtrlLeft:
SetBlack(0);
TBA_VKUp:
SetBlack(FBlack + Increment);
TBA_VKCtrlUp:
SetBlack(255);
TBA_VKDown:
SetBlack(FBlack - Increment);
TBA_VKCtrlDown:
SetBlack(0);
else
inherited;
end;
end; end;
end. end.

281
components/mbColorLib/LColorPicker.pas
View File

@@ -7,43 +7,39 @@ interface
{$ENDIF} {$ENDIF}
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
RGBHSLUtils, mbTrackBarPicker, HTMLColors, Scanlines; RGBHSLUtils, mbTrackBarPicker, HTMLColors;
type type
TLColorPicker = class(TmbTrackBarPicker) TLColorPicker = class(TmbTrackBarPicker)
private private
FHue, FSat, FLuminance: integer; FHue, FSat, FLuminance: integer;
FLBmp: TBitmap; function ArrowPosFromLum(l: integer): integer;
function LumFromArrowPos(p: integer): integer;
function ArrowPosFromLum(l: integer): integer; procedure SetHue(h: integer);
function LumFromArrowPos(p: integer): integer; procedure SetSat(s: integer);
procedure CreateLGradient; procedure SetLuminance(l: integer);
procedure SetHue(h: integer); function GetSelectedColor: TColor;
procedure SetSat(s: integer); procedure SetSelectedColor(c: TColor);
procedure SetLuminance(l: integer); protected
function GetSelectedColor: TColor; procedure Execute(tbaAction: integer); override;
procedure SetSelectedColor(c: TColor); function GetArrowPos: integer; override;
protected function GetGradientColor(AValue: Integer): TColor; override;
procedure CreateWnd; override; function GetSelectedValue: integer; override;
procedure Execute(tbaAction: integer); override; public
function GetArrowPos: integer; override; constructor Create(AOwner: TComponent); override;
function GetSelectedValue: integer; override; published
public property Hue: integer read FHue write SetHue default 0;
constructor Create(AOwner: TComponent); override; property Saturation: integer read FSat write SetSat default 240;
destructor Destroy; override; property Luminance: integer read FLuminance write SetLuminance default 120;
published property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Hue: integer read FHue write SetHue default 0; property Layout default lyVertical;
property Saturation: integer read FSat write SetSat default 240; end;
property Luminance: integer read FLuminance write SetLuminance default 120;
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Layout default lyVertical;
end;
procedure Register; procedure Register;
@@ -55,41 +51,28 @@ implementation
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TLColorPicker]); RegisterComponents('mbColor Lib', [TLColorPicker]);
end; end;
{TLColorPicker} {TLColorPicker}
constructor TLColorPicker.Create(AOwner: TComponent); constructor TLColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FLBmp := TBitmap.Create; FGradientWidth := 256;
FLBmp.PixelFormat := pf32bit; FGradientHeight := 12;
Width := 22; Layout := lyVertical;
Height := 252; FHue := 0;
Layout := lyVertical; FSat := MaxSat;
FHue := 0; FArrowPos := ArrowPosFromLum(MaxLum div 2);
FSat := MaxSat; FChange := false;
FArrowPos := ArrowPosFromLum(MaxLum div 2); SetLuminance(MaxLum div 2);
Fchange := false; HintFormat := 'Luminance: %value';
SetLuminance(MaxLum div 2); FManual := false;
HintFormat := 'Luminance: %value'; FChange := true;
FManual := false;
FChange := true;
end;
destructor TLColorPicker.Destroy;
begin
FLBmp.Free;
inherited Destroy;
end;
procedure TLColorPicker.CreateWnd;
begin
inherited;
CreateLGradient;
end; end;
(*
procedure TLColorPicker.CreateLGradient; procedure TLColorPicker.CreateLGradient;
var var
i,j: integer; i,j: integer;
@@ -133,90 +116,93 @@ begin
end; end;
end; end;
end; end;
*)
function TLColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := HSLRangeToRGB(FHue, FSat, AValue);
end;
procedure TLColorPicker.SetHue(h: integer); procedure TLColorPicker.SetHue(h: integer);
begin begin
if h > MaxHue then h := MaxHue; if h > MaxHue then h := MaxHue;
if h < 0 then h := 0; if h < 0 then h := 0;
if FHue <> h then if FHue <> h then
begin begin
FHue := h; FHue := h;
FManual := false; FManual := false;
CreateLGradient; CreateGradient;
Invalidate; Invalidate;
if Fchange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TLColorPicker.SetSat(s: integer); procedure TLColorPicker.SetSat(s: integer);
begin begin
if s > MaxSat then s := MaxSat; if s > MaxSat then s := MaxSat;
if s < 0 then s := 0; if s < 0 then s := 0;
if FSat <> s then if FSat <> s then
begin begin
FSat := s; FSat := s;
FManual := false; FManual := false;
CreateLGradient; CreateGradient;
Invalidate; Invalidate;
if Fchange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function TLColorPicker.ArrowPosFromLum(l: integer): integer; function TLColorPicker.ArrowPosFromLum(l: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/MaxLum)*l); a := Round(((Width - 12)/MaxLum)*l);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
l := MaxLum - l; l := MaxLum - l;
a := Round(((Height - 12)/MaxLum)*l); a := Round(((Height - 12)/MaxLum)*l);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function TLColorPicker.LumFromArrowPos(p: integer): integer; function TLColorPicker.LumFromArrowPos(p: integer): integer;
var var
r: integer; r: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
r := Round(p/((Width - 12)/MaxLum)) r := Round(p/((Width - 12)/MaxLum))
else else
r := Round(MaxLum - p/((Height - 12)/MaxLum)); r := Round(MaxLum - p/((Height - 12)/MaxLum));
if r < 0 then r := 0; if r < 0 then r := 0;
if r > MaxLum then r := MaxLum; if r > MaxLum then r := MaxLum;
Result := r; Result := r;
end; end;
procedure TLColorPicker.SetLuminance(l: integer); procedure TLColorPicker.SetLuminance(l: integer);
begin begin
if l < 0 then l := 0; if l < 0 then l := 0;
if l > MaxLum then l := MaxLum; if l > MaxLum then l := MaxLum;
if FLuminance <> l then if FLuminance <> l then
begin begin
FLuminance := l; FLuminance := l;
FArrowPos := ArrowPosFromLum(l); FArrowPos := ArrowPosFromLum(l);
FManual := false; FManual := false;
Invalidate; Invalidate;
if Fchange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function TLColorPicker.GetSelectedColor: TColor; function TLColorPicker.GetSelectedColor: TColor;
begin begin
if not WebSafe then if not WebSafe then
Result := HSLRangeToRGB(FHue, FSat, FLuminance) Result := HSLRangeToRGB(FHue, FSat, FLuminance)
else else
Result := GetWebSafe(HSLRangeToRGB(FHue, FSat, FLuminance)); Result := GetWebSafe(HSLRangeToRGB(FHue, FSat, FLuminance));
end; end;
function TLColorPicker.GetSelectedValue: integer; function TLColorPicker.GetSelectedValue: integer;
@@ -226,45 +212,58 @@ end;
procedure TLColorPicker.SetSelectedColor(c: TColor); procedure TLColorPicker.SetSelectedColor(c: TColor);
var var
h1, s1, l1: integer; h1, s1, l1: integer;
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
RGBtoHSLRange(c, h1, s1, l1); RGBtoHSLRange(c, h1, s1, l1);
Fchange := false; Fchange := false;
SetHue(h1); SetHue(h1);
SetSat(s1); SetSat(s1);
SetLuminance(l1); SetLuminance(l1);
Fchange := true; FChange := true;
FManual := false; FManual := false;
if Fchange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
function TLColorPicker.GetArrowPos: integer; function TLColorPicker.GetArrowPos: integer;
begin begin
Result := ArrowPosFromLum(FLuminance); Result := ArrowPosFromLum(FLuminance);
end; end;
procedure TLColorPicker.Execute(tbaAction: integer); procedure TLColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
TBA_Resize: SetLuminance(FLuminance); TBA_Resize:
TBA_Paint: Canvas.StretchDraw(FPickRect, FLBmp); SetLuminance(FLuminance);
TBA_MouseMove: FLuminance := LumFromArrowPos(FArrowPos); TBA_MouseMove:
TBA_MouseDown: Fluminance := LumFromArrowPos(FArrowPos); FLuminance := LumFromArrowPos(FArrowPos);
TBA_MouseUp: Fluminance := LumFromArrowPos(FArrowPos); TBA_MouseDown:
TBA_WheelUp: SetLuminance(FLuminance + Increment); Fluminance := LumFromArrowPos(FArrowPos);
TBA_WheelDown: SetLuminance(FLuminance - Increment); TBA_MouseUp:
TBA_VKRight: SetLuminance(FLuminance + Increment); Fluminance := LumFromArrowPos(FArrowPos);
TBA_VKCtrlRight: SetLuminance(MaxLum); TBA_WheelUp:
TBA_VKLeft: SetLuminance(FLuminance - Increment); SetLuminance(FLuminance + Increment);
TBA_VKCtrlLeft: SetLuminance(0); TBA_WheelDown:
TBA_VKUp: SetLuminance(FLuminance + Increment); SetLuminance(FLuminance - Increment);
TBA_VKCtrlUp: SetLuminance(MaxLum); TBA_VKRight:
TBA_VKDown: SetLuminance(FLuminance - Increment); SetLuminance(FLuminance + Increment);
TBA_VKCtrlDown: SetLuminance(0); TBA_VKCtrlRight:
TBA_RedoBMP: CreateLGradient; SetLuminance(MaxLum);
end; TBA_VKLeft:
SetLuminance(FLuminance - Increment);
TBA_VKCtrlLeft:
SetLuminance(0);
TBA_VKUp:
SetLuminance(FLuminance + Increment);
TBA_VKCtrlUp:
SetLuminance(MaxLum);
TBA_VKDown:
SetLuminance(FLuminance - Increment);
TBA_VKCtrlDown:
SetLuminance(0);
else
inherited;
end;
end; end;
end. end.

307
components/mbColorLib/MColorPicker.pas
View File

@@ -7,45 +7,41 @@ interface
{$ENDIF} {$ENDIF}
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines; RGBCMYKUtils, mbTrackBarPicker, HTMLColors; //, Scanlines;
type type
TMColorPicker = class(TmbTrackBarPicker) TMColorPicker = class(TmbTrackBarPicker)
private private
FCyan, FMagenta, FYellow, FBlack: integer; FCyan, FMagenta, FYellow, FBlack: integer;
FMBmp: TBitmap; function ArrowPosFromMagenta(m: integer): integer;
function MagentaFromArrowPos(p: integer): integer;
function ArrowPosFromMagenta(m: integer): integer; function GetSelectedColor: TColor;
function MagentaFromArrowPos(p: integer): integer; procedure SetSelectedColor(c: TColor);
function GetSelectedColor: TColor; procedure SetCyan(c: integer);
procedure SetSelectedColor(c: TColor); procedure SetMagenta(m: integer);
procedure CreateMGradient; procedure SetYellow(y: integer);
procedure SetCyan(c: integer); procedure SetBlack(k: integer);
procedure SetMagenta(m: integer); protected
procedure SetYellow(y: integer); procedure Execute(tbaAction: integer); override;
procedure SetBlack(k: integer); function GetArrowPos: integer; override;
protected function GetGradientColor(AValue: Integer): TColor; override;
procedure CreateWnd; override; function GetSelectedValue: integer; override;
procedure Execute(tbaAction: integer); override; public
function GetArrowPos: integer; override; constructor Create(AOwner: TComponent); override;
function GetSelectedValue: integer; override; published
public property Cyan: integer read FCyan write SetCyan default 0;
constructor Create(AOwner: TComponent); override; property Magenta: integer read FMagenta write SetMagenta default 255;
destructor Destroy; override; property Yellow: integer read FYellow write SetYellow default 0;
published property Black: integer read FBlack write SetBlack default 0;
property Cyan: integer read FCyan write SetCyan default 0; property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Magenta: integer read FMagenta write SetMagenta default 255; property Layout default lyVertical;
property Yellow: integer read FYellow write SetYellow default 0; end;
property Black: integer read FBlack write SetBlack default 0;
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Layout default lyVertical;
end;
procedure Register; procedure Register;
@@ -64,37 +60,25 @@ end;
constructor TMColorPicker.Create(AOwner: TComponent); constructor TMColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FMBmp := TBitmap.Create; FGradientWidth := 256;
FMBmp.PixelFormat := pf32bit; FGradientHeight := 12;
FMBmp.SetSize(12, 255); Width := 22;
Width := 22; Height := 267;
Height := 267; Layout := lyVertical;
Layout := lyVertical; FCyan := 0;
FCyan := 0; FMagenta := 255;
FMagenta := 255; FYellow := 0;
FYellow := 0; FBlack := 0;
FBlack := 0; FArrowPos := ArrowPosFromMagenta(255);
FArrowPos := ArrowPosFromMagenta(255); FChange := false;
FChange := false; SetMagenta(255);
SetMagenta(255); HintFormat := 'Magenta: %value';
HintFormat := 'Magenta: %value'; FManual := false;
FManual := false; FChange := true;
FChange := true;
end;
destructor TMColorPicker.Destroy;
begin
FMBmp.Free;
inherited Destroy;
end;
procedure TMColorPicker.CreateWnd;
begin
inherited;
CreateMGradient;
end; end;
(*
procedure TMColorPicker.CreateMGradient; procedure TMColorPicker.CreateMGradient;
var var
i,j: integer; i,j: integer;
@@ -138,105 +122,106 @@ begin
end; end;
end; end;
end; end;
*)
function TMColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := CMYKtoTColor(FCyan, AValue, FYellow, FBlack);
end;
procedure TMColorPicker.SetMagenta(m: integer); procedure TMColorPicker.SetMagenta(m: integer);
begin begin
if M < 0 then M := 0; if M < 0 then M := 0;
if M > 255 then M := 255; if M > 255 then M := 255;
if FMagenta <> m then if FMagenta <> m then
begin begin
FMagenta := m; FMagenta := m;
FArrowPos := ArrowPosFromMagenta(m); FArrowPos := ArrowPosFromMagenta(m);
FManual := false; FManual := false;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TMColorPicker.SetCyan(c: integer); procedure TMColorPicker.SetCyan(c: integer);
begin begin
if c > 255 then c := 255; if c > 255 then c := 255;
if c < 0 then c := 0; if c < 0 then c := 0;
if FCyan <> c then if FCyan <> c then
begin begin
FCyan := c; FCyan := c;
FManual := false; FManual := false;
CreateMGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TMColorPicker.SetYellow(y: integer); procedure TMColorPicker.SetYellow(y: integer);
begin begin
if y > 255 then y := 255; if y > 255 then y := 255;
if y < 0 then y := 0; if y < 0 then y := 0;
if FYellow <> y then if FYellow <> y then
begin begin
FYellow := y; FYellow := y;
FManual := false; FManual := false;
CreateMGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TMColorPicker.SetBlack(k: integer); procedure TMColorPicker.SetBlack(k: integer);
begin begin
if k > 255 then k := 255; if k > 255 then k := 255;
if k < 0 then k := 0; if k < 0 then k := 0;
if FBlack <> k then if FBlack <> k then
begin begin
FBlack := k; FBlack := k;
FManual := false; FManual := false;
CreateMGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function TMColorPicker.ArrowPosFromMagenta(m: integer): integer; function TMColorPicker.ArrowPosFromMagenta(m: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/255)*m); a := Round(((Width - 12)/255)*m);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
m := 255 - m; m := 255 - m;
a := Round(((Height - 12)/255)*m); a := Round(((Height - 12)/255)*m);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function TMColorPicker.MagentaFromArrowPos(p: integer): integer; function TMColorPicker.MagentaFromArrowPos(p: integer): integer;
var var
r: integer; r: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
r := Round(p/((Width - 12)/255)) r := Round(p/((Width - 12)/255))
else else
r := Round(255 - p/((Height - 12)/255)); r := Round(255 - p/((Height - 12)/255));
if r < 0 then r := 0; if r < 0 then r := 0;
if r > 255 then r := 255; if r > 255 then r := 255;
Result := r; Result := r;
end; end;
function TMColorPicker.GetSelectedColor: TColor; function TMColorPicker.GetSelectedColor: TColor;
begin begin
if not WebSafe then if not WebSafe then
Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)
else else
Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack));
end; end;
function TMColorPicker.GetSelectedValue: integer; function TMColorPicker.GetSelectedValue: integer;
@@ -246,45 +231,59 @@ end;
procedure TMColorPicker.SetSelectedColor(c: TColor); procedure TMColorPicker.SetSelectedColor(c: TColor);
var var
cy, m, y, k: integer; cy, m, y, k: integer;
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
ColorToCMYK(c, cy, m, y, k); ColorToCMYK(c, cy, m, y, k);
FChange := false; FChange := false;
SetCyan(cy); SetCyan(cy);
SetYellow(y); SetYellow(y);
SetBlack(k); SetBlack(k);
SetMagenta(m); SetMagenta(m);
FManual := false; FManual := false;
FChange := true; FChange := true;
if Assigned(OnChange) then OnChange(Self); if Assigned(OnChange) then OnChange(Self);
end; end;
function TMColorPicker.GetArrowPos: integer; function TMColorPicker.GetArrowPos: integer;
begin begin
Result := ArrowPosFromMagenta(FMagenta); Result := ArrowPosFromMagenta(FMagenta);
end; end;
procedure TMColorPicker.Execute(tbaAction: integer); procedure TMColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
TBA_Resize: SetMagenta(FMagenta); TBA_Resize:
TBA_Paint: Canvas.StretchDraw(FPickRect, FMBmp); SetMagenta(FMagenta);
TBA_MouseMove: FMagenta := MagentaFromArrowPos(FArrowPos); TBA_MouseMove:
TBA_MouseDown: FMagenta := MagentaFromArrowPos(FArrowPos); FMagenta := MagentaFromArrowPos(FArrowPos);
TBA_MouseUp: FMagenta := MagentaFromArrowPos(FArrowPos); TBA_MouseDown:
TBA_WheelUp: SetMagenta(FMagenta + Increment); FMagenta := MagentaFromArrowPos(FArrowPos);
TBA_WheelDown: SetMagenta(FMagenta - Increment); TBA_MouseUp:
TBA_VKRight: SetMagenta(FMagenta + Increment); FMagenta := MagentaFromArrowPos(FArrowPos);
TBA_VKCtrlRight: SetMagenta(255); TBA_WheelUp:
TBA_VKLeft: SetMagenta(FMagenta - Increment); SetMagenta(FMagenta + Increment);
TBA_VKCtrlLeft: SetMagenta(0); TBA_WheelDown:
TBA_VKUp: SetMagenta(FMagenta + Increment); SetMagenta(FMagenta - Increment);
TBA_VKCtrlUp: SetMagenta(255); TBA_VKRight:
TBA_VKDown: SetMagenta(FMagenta - Increment); SetMagenta(FMagenta + Increment);
TBA_VKCtrlDown: SetMagenta(0); TBA_VKCtrlRight:
TBA_RedoBMP: CreateMGradient; SetMagenta(255);
end; TBA_VKLeft:
SetMagenta(FMagenta - Increment);
TBA_VKCtrlLeft:
SetMagenta(0);
TBA_VKUp:
SetMagenta(FMagenta + Increment);
TBA_VKCtrlUp:
SetMagenta(255);
TBA_VKDown:
SetMagenta(FMagenta - Increment);
TBA_VKCtrlDown:
SetMagenta(0);
else
inherited;
end;
end; end;
end. end.

221
components/mbColorLib/RColorPicker.pas
View File

@@ -16,27 +16,26 @@ uses
mbTrackBarPicker, HTMLColors, Scanlines; mbTrackBarPicker, HTMLColors, Scanlines;
type type
{ TRColorPicker }
TRColorPicker = class(TmbTrackBarPicker) TRColorPicker = class(TmbTrackBarPicker)
private private
FRed, FGreen, FBlue: integer; FRed, FGreen, FBlue: integer;
FBmp: TBitmap;
function ArrowPosFromRed(r: integer): integer; function ArrowPosFromRed(r: integer): integer;
function RedFromArrowPos(p: integer): integer; function RedFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor; function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor); procedure SetSelectedColor(c: TColor);
procedure CreateRGradient;
procedure SetRed(r: integer); procedure SetRed(r: integer);
procedure SetGreen(g: integer); procedure SetGreen(g: integer);
procedure SetBlue(b: integer); procedure SetBlue(b: integer);
protected protected
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); override; procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override; function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override; function GetSelectedValue: integer; override;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published published
property Red: integer read FRed write SetRed default 255; property Red: integer read FRed write SetRed default 255;
property Green: integer read FGreen write SetGreen default 122; property Green: integer read FGreen write SetGreen default 122;
@@ -62,36 +61,24 @@ end;
constructor TRColorPicker.Create(AOwner: TComponent); constructor TRColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FBmp := TBitmap.Create; FGradientWidth := 256;
FBmp.PixelFormat := pf32bit; FGradientHeight := 12;
FBmp.SetSize(12, 256); Width := 22;
Width := 22; Height := 268;
Height := 268; Layout := lyVertical;
Layout := lyVertical; FRed := 255;
FRed := 255; FGreen := 122;
FGreen := 122; FBlue := 122;
FBlue := 122; FArrowPos := ArrowPosFromRed(255);
FArrowPos := ArrowPosFromRed(255); FChange := false;
FChange := false; SetRed(255);
SetRed(255); HintFormat := 'Red: %value';
HintFormat := 'Red: %value'; FManual := false;
FManual := false; FChange := true;
FChange := true;
end;
destructor TRColorPicker.Destroy;
begin
FBmp.Free;
inherited Destroy;
end;
procedure TRColorPicker.CreateWnd;
begin
inherited;
CreateRGradient;
end; end;
(*
procedure TRColorPicker.CreateRGradient; procedure TRColorPicker.CreateRGradient;
var var
i,j: integer; i,j: integer;
@@ -134,91 +121,93 @@ begin
// FBmp.Canvas.Pixels[j, i] := GetWebSafe(RGB(255-i, FGreen, FBlue)); // FBmp.Canvas.Pixels[j, i] := GetWebSafe(RGB(255-i, FGreen, FBlue));
end; end;
end; end;
end; *)
function TRColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := RGB(AValue, FGreen, FBlue);
end; end;
procedure TRColorPicker.SetRed(r: integer); procedure TRColorPicker.SetRed(r: integer);
begin begin
if r < 0 then r := 0; if r < 0 then r := 0;
if r > 255 then r := 255; if r > 255 then r := 255;
if FRed <> r then if FRed <> r then
begin begin
FRed := r; FRed := r;
FArrowPos := ArrowPosFromRed(r); FArrowPos := ArrowPosFromRed(r);
FManual := false; FManual := false;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TRColorPicker.SetGreen(g: integer); procedure TRColorPicker.SetGreen(g: integer);
begin begin
if g > 255 then g := 255; if g > 255 then g := 255;
if g < 0 then g := 0; if g < 0 then g := 0;
if FGreen <> g then if FGreen <> g then
begin begin
FGreen := g; FGreen := g;
FManual := false; FManual := false;
CreateRGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TRColorPicker.SetBlue(b: integer); procedure TRColorPicker.SetBlue(b: integer);
begin begin
if b > 255 then b := 255; if b > 255 then b := 255;
if b < 0 then b := 0; if b < 0 then b := 0;
if FBlue <> b then if FBlue <> b then
begin begin
FBlue := b; FBlue := b;
FManual := false; FManual := false;
CreateRGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function TRColorPicker.ArrowPosFromRed(r: integer): integer; function TRColorPicker.ArrowPosFromRed(r: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/255)*r); a := Round(((Width - 12)/255)*r);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
r := 255 - r; r := 255 - r;
a := Round(((Height - 12)/255)*r); a := Round(((Height - 12)/255)*r);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function TRColorPicker.RedFromArrowPos(p: integer): integer; function TRColorPicker.RedFromArrowPos(p: integer): integer;
var var
r: integer; r: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
r := Round(p/((Width - 12)/255)) r := Round(p/((Width - 12)/255))
else else
r := Round(255 - p/((Height - 12)/255)); r := Round(255 - p/((Height - 12)/255));
if r < 0 then r := 0; if r < 0 then r := 0;
if r > 255 then r := 255; if r > 255 then r := 255;
Result := r; Result := r;
end; end;
function TRColorPicker.GetSelectedColor: TColor; function TRColorPicker.GetSelectedColor: TColor;
begin begin
if not WebSafe then if not WebSafe then
Result := RGB(FRed, FGreen, FBlue) Result := RGB(FRed, FGreen, FBlue)
else else
Result := GetWebSafe(RGB(FRed, FGreen, FBlue)); Result := GetWebSafe(RGB(FRed, FGreen, FBlue));
end; end;
function TRColorPicker.GetSelectedValue: integer; function TRColorPicker.GetSelectedValue: integer;
@@ -228,41 +217,55 @@ end;
procedure TRColorPicker.SetSelectedColor(c: TColor); procedure TRColorPicker.SetSelectedColor(c: TColor);
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
FChange := false; FChange := false;
SetGreen(GetGValue(c)); SetGreen(GetGValue(c));
SetBlue(GetBValue(c)); SetBlue(GetBValue(c));
SetRed(GetRValue(c)); SetRed(GetRValue(c));
FManual := false; FManual := false;
FChange := true; FChange := true;
if Assigned(OnChange) then OnChange(Self); if Assigned(OnChange) then OnChange(Self);
end; end;
function TRColorPicker.GetArrowPos: integer; function TRColorPicker.GetArrowPos: integer;
begin begin
Result := ArrowPosFromRed(FRed); Result := ArrowPosFromRed(FRed);
end; end;
procedure TRColorPicker.Execute(tbaAction: integer); procedure TRColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
TBA_Resize: SetRed(FRed); TBA_Resize:
TBA_Paint: Canvas.StretchDraw(FPickRect, FBmp); SetRed(FRed);
TBA_MouseMove: FRed := RedFromArrowPos(FArrowPos); TBA_MouseMove:
TBA_MouseDown: FRed := RedFromArrowPos(FArrowPos); FRed := RedFromArrowPos(FArrowPos);
TBA_MouseUp: FRed := RedFromArrowPos(FArrowPos); TBA_MouseDown:
TBA_WheelUp: SetRed(FRed + Increment); FRed := RedFromArrowPos(FArrowPos);
TBA_WheelDown: SetRed(FRed - Increment); TBA_MouseUp:
TBA_VKRight: SetRed(FRed + Increment); FRed := RedFromArrowPos(FArrowPos);
TBA_VKCtrlRight: SetRed(255); TBA_WheelUp:
TBA_VKLeft: SetRed(FRed - Increment); SetRed(FRed + Increment);
TBA_VKCtrlLeft: SetRed(0); TBA_WheelDown:
TBA_VKUp: SetRed(FRed + Increment); SetRed(FRed - Increment);
TBA_VKCtrlUp: SetRed(255); TBA_VKRight:
TBA_VKDown: SetRed(FRed - Increment); SetRed(FRed + Increment);
TBA_VKCtrlDown: SetRed(0); TBA_VKCtrlRight:
TBA_RedoBMP: CreateRGradient; SetRed(255);
end; TBA_VKLeft:
SetRed(FRed - Increment);
TBA_VKCtrlLeft:
SetRed(0);
TBA_VKUp:
SetRed(FRed + Increment);
TBA_VKCtrlUp:
SetRed(255);
TBA_VKDown:
SetRed(FRed - Increment);
TBA_VKCtrlDown:
SetRed(0);
else
inherited;
end;
end; end;
end. end.

50
components/mbColorLib/RGBHSLUtils.pas
View File

@@ -165,34 +165,34 @@ end;
function HSLToRGBTriple(H, S, L: integer): TRGBTriple; function HSLToRGBTriple(H, S, L: integer): TRGBTriple;
const const
Divisor = 255*60; Divisor = 255*60;
var var
hTemp, f, LS, p, q, r: integer; hTemp, f, LS, p, q, r: integer;
begin begin
Clamp(H, 0, MaxHue); Clamp(H, 0, MaxHue);
Clamp(S, 0, MaxSat); Clamp(S, 0, MaxSat);
Clamp(L, 0, MaxLum); Clamp(L, 0, MaxLum);
if (S = 0) then if (S = 0) then
Result := RGBToRGBTriple(L, L, L) Result := RGBToRGBTriple(L, L, L)
else else
begin begin
hTemp := H mod MaxHue; hTemp := H mod MaxHue;
f := hTemp mod 60; f := hTemp mod 60;
hTemp := hTemp div 60; hTemp := hTemp div 60;
LS := L*S; LS := L*S;
p := L - LS div MaxLum; p := L - LS div MaxLum;
q := L - (LS*f) div Divisor; q := L - (LS*f) div Divisor;
r := L - (LS*(60 - f)) div Divisor; r := L - (LS*(60 - f)) div Divisor;
case hTemp of case hTemp of
0: Result := RGBToRGBTriple(L, r, p); 0: Result := RGBToRGBTriple(L, r, p);
1: Result := RGBToRGBTriple(q, L, p); 1: Result := RGBToRGBTriple(q, L, p);
2: Result := RGBToRGBTriple(p, L, r); 2: Result := RGBToRGBTriple(p, L, r);
3: Result := RGBToRGBTriple(p, q, L); 3: Result := RGBToRGBTriple(p, q, L);
4: Result := RGBToRGBTriple(r, p, L); 4: Result := RGBToRGBTriple(r, p, L);
5: Result := RGBToRGBTriple(L, p, q); 5: Result := RGBToRGBTriple(L, p, q);
else else
Result := RGBToRGBTriple(0, 0, 0); Result := RGBToRGBTriple(0, 0, 0);
end; end;
end; end;
end; end;

218
components/mbColorLib/SColorPicker.pas
View File

@@ -19,24 +19,20 @@ type
TSColorPicker = class(TmbTrackBarPicker) TSColorPicker = class(TmbTrackBarPicker)
private private
FVal, FHue, FSat: integer; FVal, FHue, FSat: integer;
FSBmp: TBitmap;
function ArrowPosFromSat(s: integer): integer; function ArrowPosFromSat(s: integer): integer;
function SatFromArrowPos(p: integer): integer; function SatFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor; function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor); procedure SetSelectedColor(c: TColor);
procedure CreateSGradient;
procedure SetHue(h: integer); procedure SetHue(h: integer);
procedure SetSat(s: integer); procedure SetSat(s: integer);
procedure SetValue(v: integer); procedure SetValue(v: integer);
protected protected
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); override; procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override; function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override; function GetSelectedValue: integer; override;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published published
property Hue: integer read FHue write SetHue default 0; property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 255; property Saturation: integer read FSat write SetSat default 255;
@@ -61,33 +57,22 @@ end;
constructor TSColorPicker.Create(AOwner: TComponent); constructor TSColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FSBmp := TBitmap.Create; FGradientWidth := 256;
FSBmp.PixelFormat := pf32bit; FGradientHeight := 12;
Width := 267; Width := 267;
Height := 22; Height := 22;
FHue := 0; FHue := 0;
FVal := 255; FVal := 255;
FArrowPos := ArrowPosFromSat(0); FArrowPos := ArrowPosFromSat(0);
FChange := false; FChange := false;
SetSat(255); SetSat(255);
HintFormat := 'Saturation: %value'; HintFormat := 'Saturation: %value';
FManual := false; FManual := false;
FChange := true; FChange := true;
end;
destructor TSColorPicker.Destroy;
begin
FSBmp.Free;
inherited Destroy;
end;
procedure TSColorPicker.CreateWnd;
begin
inherited;
CreateSGradient;
end; end;
(*
procedure TSColorPicker.CreateSGradient; procedure TSColorPicker.CreateSGradient;
var var
i,j: integer; i,j: integer;
@@ -131,90 +116,93 @@ begin
end; end;
end; end;
end; end;
*)
function TSColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := HSVtoColor(FHue, AValue, FVal);
end;
procedure TSColorPicker.SetValue(v: integer); procedure TSColorPicker.SetValue(v: integer);
begin begin
if v < 0 then v := 0; if v < 0 then v := 0;
if v > 255 then v := 255; if v > 255 then v := 255;
if FVal <> v then if FVal <> v then
begin begin
FVal := v; FVal := v;
FManual := false; FManual := false;
CreateSGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TSColorPicker.SetHue(h: integer); procedure TSColorPicker.SetHue(h: integer);
begin begin
if h > 360 then h := 360; if h > 360 then h := 360;
if h < 0 then h := 0; if h < 0 then h := 0;
if FHue <> h then if FHue <> h then
begin begin
FHue := h; FHue := h;
CreateSGradient; CreateGradient;
FManual := false; FManual := false;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TSColorPicker.SetSat(s: integer); procedure TSColorPicker.SetSat(s: integer);
begin begin
if s > 255 then s := 255; if s > 255 then s := 255;
if s < 0 then s := 0; if s < 0 then s := 0;
if FSat <> s then if FSat <> s then
begin begin
FSat := s; FSat := s;
FManual := false; FManual := false;
FArrowPos := ArrowPosFromSat(s); FArrowPos := ArrowPosFromSat(s);
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function TSColorPicker.ArrowPosFromSat(s: integer): integer; function TSColorPicker.ArrowPosFromSat(s: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/255)*s); a := Round(((Width - 12)/255)*s);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
s := 255 - s; s := 255 - s;
a := Round(((Height - 12)/255)*s); a := Round(((Height - 12)/255)*s);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function TSColorPicker.SatFromArrowPos(p: integer): integer; function TSColorPicker.SatFromArrowPos(p: integer): integer;
var var
r: integer; r: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
r := Round(p/((Width - 12)/255)) r := Round(p/((Width - 12)/255))
else else
r := Round(255 - p/((Height - 12)/255)); r := Round(255 - p/((Height - 12)/255));
if r < 0 then r := 0; if r < 0 then r := 0;
if r > 255 then r := 255; if r > 255 then r := 255;
Result := r; Result := r;
end; end;
function TSColorPicker.GetSelectedColor: TColor; function TSColorPicker.GetSelectedColor: TColor;
begin begin
if not WebSafe then if not WebSafe then
Result := HSVtoColor(FHue, FSat, FVal) Result := HSVtoColor(FHue, FSat, FVal)
else else
Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal)); Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal));
end; end;
function TSColorPicker.GetSelectedValue: integer; function TSColorPicker.GetSelectedValue: integer;
@@ -224,44 +212,58 @@ end;
procedure TSColorPicker.SetSelectedColor(c: TColor); procedure TSColorPicker.SetSelectedColor(c: TColor);
var var
h, s, v: integer; h, s, v: integer;
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
RGBToHSV(GetRValue(c), GetGValue(c), GetBValue(c), h, s, v); RGBToHSV(GetRValue(c), GetGValue(c), GetBValue(c), h, s, v);
FChange := false; FChange := false;
SetHue(h); SetHue(h);
SetSat(s); SetSat(s);
SetValue(v); SetValue(v);
FManual := false; FManual := false;
FChange := true; FChange := true;
if Assigned(OnChange) then OnChange(Self); if Assigned(OnChange) then OnChange(Self);
end; end;
function TSColorPicker.GetArrowPos: integer; function TSColorPicker.GetArrowPos: integer;
begin begin
Result := ArrowPosFromSat(FSat); Result := ArrowPosFromSat(FSat);
end; end;
procedure TSColorPicker.Execute(tbaAction: integer); procedure TSColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
TBA_Resize: SetSat(FSat); TBA_Resize:
TBA_Paint: Canvas.StretchDraw(FPickRect, FSBmp); SetSat(FSat);
TBA_MouseMove: FSat := SatFromArrowPos(FArrowPos); TBA_MouseMove:
TBA_MouseDown: FSat := SatFromArrowPos(FArrowPos); FSat := SatFromArrowPos(FArrowPos);
TBA_MouseUp: FSat := SatFromArrowPos(FArrowPos); TBA_MouseDown:
TBA_WheelUp: SetSat(FSat + Increment); FSat := SatFromArrowPos(FArrowPos);
TBA_WheelDown: SetSat(FSat - Increment); TBA_MouseUp:
TBA_VKLeft: SetSat(FSat - Increment); FSat := SatFromArrowPos(FArrowPos);
TBA_VKCtrlLeft: SetSat(0); TBA_WheelUp:
TBA_VKRight: SetSat(FSat + Increment); SetSat(FSat + Increment);
TBA_VKCtrlRight: SetSat(255); TBA_WheelDown:
TBA_VKUp: SetSat(FSat + Increment); SetSat(FSat - Increment);
TBA_VKCtrlUp: SetSat(255); TBA_VKLeft:
TBA_VKDown: SetSat(FSat - Increment); SetSat(FSat - Increment);
TBA_VKCtrlDown: SetSat(0); TBA_VKCtrlLeft:
TBA_RedoBMP: CreateSGradient; SetSat(0);
end; TBA_VKRight:
SetSat(FSat + Increment);
TBA_VKCtrlRight:
SetSat(255);
TBA_VKUp:
SetSat(FSat + Increment);
TBA_VKCtrlUp:
SetSat(255);
TBA_VKDown:
SetSat(FSat - Increment);
TBA_VKCtrlDown:
SetSat(0);
else
inherited;
end;
end; end;
end. end.

110
components/mbColorLib/SLColorPicker.pas
View File

@@ -65,6 +65,9 @@ implementation
{$IFDEF FPC} {$IFDEF FPC}
{$R SLColorPicker.dcr} {$R SLColorPicker.dcr}
uses
IntfGraphics, fpimage;
{$ENDIF} {$ENDIF}
procedure Register; procedure Register;
@@ -96,35 +99,98 @@ begin
inherited; inherited;
end; end;
//{$IFDEF DELPHI}
procedure TSLColorPicker.CreateSLGradient; procedure TSLColorPicker.CreateSLGradient;
var var
x, y, skip: integer; x, y, skip: integer;
row: pRGBQuadArray; row: pRGBQuadArray;
tc: TColor; c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin begin
if FBMP = nil then if FBmp = nil then
begin begin
FBMP := TBitmap.Create; FBmp := TBitmap.Create;
FBMP.PixelFormat := pf32bit; FBmp.PixelFormat := pf32bit;
FBMP.Width := 256; FBmp.Width := 256;
FBMP.Height := 256; FBmp.Height := 256;
end;
row := FBMP.ScanLine[0];
skip := integer(FBMP.ScanLine[1]) - Integer(row);
for y := 0 to 255 do
begin
for x := 0 to 255 do
if not WebSafe then
row[x] := HSLtoRGBQuad(FHue, x, 255 - y)
else
begin
tc := GetWebSafe(RGBTripleToTColor(HSLToRGBTriple(FHue, x, 255 - y)));
row[x] := RGBtoRGBQuad(GetRValue(tc), GetGValue(tc), GetBValue(tc));
end;
row := pRGBQuadArray(Integer(row) + skip);
end; end;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(FBmp.Width, FBmp.Height);
try
intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle);
{$ENDIF}
{
row := FBMP.ScanLine[0];
skip := integer(FBMP.ScanLine[1]) - Integer(row);
}
for y := 0 to 255 do
begin
{$IFDEF FPC}
row := intfImg.GetDataLineStart(y);
{$ELSE}
row := FHSVBmp.Scanline(y);
{$ENDIF}
for x := 0 to 255 do
if not WebSafe then
row[x] := HSLtoRGBQuad(FHue, x, 255 - y)
else
begin
c := GetWebSafe(RGBTripleToTColor(HSLToRGBTriple(FHue, x, 255 - y)));
row[x] := RGBtoRGBQuad(GetRValue(c), GetGValue(c), GetBValue(c));
end;
// row := pRGBQuadArray(Integer(row) + skip);
end;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBmp.Handle := imgHandle;
FBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
{$ENDIF}
end; end;
(*
{$ELSE}
procedure TSLColorPicker.CreateSLGradient;
var
x, y: Integer;
c: TColor;
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
begin
if FBmp = nil then
begin
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32Bit;
FBmp.Width := 256;
FBmp.Height := 256;
end;
intfimg := TLazIntfImage.Create(FBmp.Width, FBmp.Height);
try
intfImg.LoadFromBitmap(FBmp.Handle, FBmp.MaskHandle);
for y := 0 to 255 do // y = L
for x := 0 to 255 do // x = S
begin
c := HSLRangeToRGB(FHue, x, 255-y);
if WebSafe then
c := GetWebSafe(c);
intfImg.Colors[x, y] := TColorToFPColor(c);
end;
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FBmp.Handle := imgHandle;
FBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
end;
{$ENDIF}
*)
procedure TSLColorPicker.Resize; procedure TSLColorPicker.Resize;
begin begin
inherited; inherited;

176
components/mbColorLib/SLHColorPicker.pas
View File

@@ -16,10 +16,10 @@ uses
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
RGBHSLUtils, mbTrackBarPicker, SLColorPicker, HColorPicker, Menus, RGBHSLUtils, mbTrackBarPicker, SLColorPicker, HColorPicker, Menus,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors; {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, mbBasicPicker;
type type
TSLHColorPicker = class(TCustomControl) TSLHColorPicker = class(TmbBasicPicker)
private private
FOnChange: TNotifyEvent; FOnChange: TNotifyEvent;
FSLPicker: TSLColorPicker; FSLPicker: TSLColorPicker;
@@ -46,13 +46,11 @@ type
procedure SetHMenu(m: TPopupMenu); procedure SetHMenu(m: TPopupMenu);
procedure SetHCursor(c: TCursor); procedure SetHCursor(c: TCursor);
procedure SetSLCursor(c: TCursor); procedure SetSLCursor(c: TCursor);
procedure PaintParentBack;
protected protected
procedure CreateWnd; override; procedure CreateWnd; override;
procedure Resize; override; procedure Resize; override;
procedure Paint; override; procedure Paint; override;
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); procedure PaintParentBack; override;
message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF}); procedure WMSetFocus(var Message: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF});
message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF}; message {$IFDEF FPC}LM_SETFOCUS{$ELSE}WM_SETFOCUS{$ENDIF};
procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); procedure DoMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
@@ -117,59 +115,70 @@ end;
constructor TSLHColorPicker.Create(AOwner: TComponent); constructor TSLHColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];
DoubleBuffered := true; DoubleBuffered := true;
PBack := TBitmap.Create; PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit; PBack.PixelFormat := pf32bit;
ParentColor := true; ParentColor := true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true; ParentBackground := true;
{$ENDIF}{$ENDIF} {$ENDIF}{$ENDIF}
Width := 297; SetInitialBounds(0, 0, 297, 271);
Height := 271; // Width := 297;
TabStop := true; // Height := 271;
FSelectedColor := clRed; TabStop := true;
FHPicker := THColorPicker.Create(Self); FSelectedColor := clRed;
InsertControl(FHPicker); FHPicker := THColorPicker.Create(Self);
FHCursor := crDefault; InsertControl(FHPicker);
FSLCursor := crDefault; FHCursor := crDefault;
with FHPicker do FSLCursor := crDefault;
// Hue picker
with FHPicker do
begin begin
Height := 271; SetInitialBounds(257, 0, 40, 271);
Width := 40; {
Top := 0; Height := 271;
Left := 257; Width := 40;
Anchors := [akTop, akRight, akBottom]; Top := 0;
Visible := true; Left := 257;
Layout := lyVertical; }
ArrowPlacement := spBoth; Anchors := [akTop, akRight, akBottom];
NewArrowStyle := true; Visible := true;
OnChange := HPickerChange; Layout := lyVertical;
OnMouseMove := DoMouseMove; ArrowPlacement := spBoth;
NewArrowStyle := true;
OnChange := HPickerChange;
OnMouseMove := DoMouseMove;
end; end;
FSLPicker := TSLColorPicker.Create(Self);
InsertControl(FSLPicker); // Saturation-Lightness picker
with FSLPicker do FSLPicker := TSLColorPicker.Create(Self);
InsertControl(FSLPicker);
with FSLPicker do
begin begin
Width := 255; SetInitialBounds(0, 0, 255, 271);
Height := 255; {
Top := 8; Width := 255;
Left := 0; Height := 271; //255;
Anchors := [akRight, akTop, akBottom, akLeft]; Top := 0; //8;
Visible := true; Left := 0;
SelectedColor := clRed; }
OnChange := SLPickerChange; Anchors := [akLeft, akRight, akTop, akBottom];
OnMouseMove := DoMouseMove; Visible := true;
SelectedColor := clRed;
OnChange := SLPickerChange;
OnMouseMove := DoMouseMove;
end; end;
FHValue := 0; FHValue := 0;
FSValue := 255; FSValue := 255;
FLValue := 255; FLValue := 255;
FRValue := 255; FRValue := 255;
FGValue := 0; FGValue := 0;
FBValue := 0; FBValue := 0;
FHHint := 'Hue: %h'; FHHint := 'Hue: %h';
FSLHint := 'S: %hslS L: %l'#13'Hex: %hex'; FSLHint := 'S: %hslS L: %l'#13'Hex: %hex';
end; end;
destructor TSLHColorPicker.Destroy; destructor TSLHColorPicker.Destroy;
@@ -182,8 +191,8 @@ end;
procedure TSLHColorPicker.HPickerChange(Sender: TObject); procedure TSLHColorPicker.HPickerChange(Sender: TObject);
begin begin
FSLPicker.Hue := FHPicker.Hue; FSLPicker.Hue := FHPicker.Hue;
DoChange; DoChange;
end; end;
procedure TSLHColorPicker.SLPickerChange(Sender: TObject); procedure TSLHColorPicker.SLPickerChange(Sender: TObject);
@@ -320,48 +329,37 @@ end;
procedure TSLHColorPicker.Resize; procedure TSLHColorPicker.Resize;
begin begin
inherited; inherited;
PaintParentBack; PaintParentBack;
if FSLPicker = nil then
exit;
if FHPicker = nil then
exit;
FSLPicker.Width := Width - FHPicker.Width - 10;
FSLPicker.Height := Height - 2;
FHPicker.Left := Width - FHPicker.Width - 2;
FHPicker.Height := Height - 2;
end; end;
procedure TSLHColorPicker.PaintParentBack; procedure TSLHColorPicker.PaintParentBack;
{$IFDEF DELPHI_7_UP}
var
MemDC: HDC;
OldBMP: HBITMAP;
{$ENDIF}
begin begin
if PBack = nil then if PBack = nil then
begin begin
PBack := TBitmap.Create; PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit; PBack.PixelFormat := pf32bit;
end; end;
PBack.Width := Width; PBack.Width := Width;
PBack.Height := Height; PBack.Height := Height;
{$IFDEF FPC} PaintParentBack(PBack);
if Color = clDefault then
PBack.Canvas.Brush.Color := clForm else
{$ENDIF}
PBack.Canvas.Brush.Color := Color;
PBack.Canvas.FillRect(PBack.Canvas.ClipRect);
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
if ParentBackground then
with ThemeServices do
if ThemesEnabled then
begin
MemDC := CreateCompatibleDC(0);
OldBMP := SelectObject(MemDC, PBack.Handle);
DrawParentBackground(Handle, MemDC, nil, False);
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF}{$ENDIF}
end; end;
procedure TSLHColorPicker.Paint; procedure TSLHColorPicker.Paint;
begin begin
PaintParentBack; PaintParentBack;
Canvas.Draw(0, 0, PBack); Canvas.Draw(0, 0, PBack);
end; end;
procedure TSLHColorPicker.CreateWnd; procedure TSLHColorPicker.CreateWnd;
@@ -370,10 +368,4 @@ begin
PaintParentBack; PaintParentBack;
end; end;
procedure TSLHColorPicker.WMEraseBkgnd(
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF} );
begin
Message.Result := 1;
end;
end. end.

51
components/mbColorLib/Scanlines.pas
View File

@@ -7,16 +7,19 @@ unit Scanlines;
interface interface
uses uses
{$IFDEF FPC}LCLIntf, LCLType, {$IFDEF FPC}
{$ELSE}Windows, LCLIntf, LCLType,
{$ENDIF} {$ELSE}
Graphics; Windows,
{$ENDIF}
Graphics;
type type
TRGBTripleArray = array [0..65535] of TRGBTriple; TRGBTripleArray = array [0..65535] of TRGBTriple;
pRGBTripleArray = ^TRGBTripleArray; pRGBTripleArray = ^TRGBTripleArray;
TRGBQuadArray = array [0..65535] of TRGBQuad;
pRGBQuadArray = ^TRGBQuadArray; TRGBQuadArray = array [0..65535] of TRGBQuad;
pRGBQuadArray = ^TRGBQuadArray;
function RGBtoRGBTriple(R, G, B: byte): TRGBTriple; function RGBtoRGBTriple(R, G, B: byte): TRGBTriple;
function RGBtoRGBQuad(R, G, B: byte): TRGBQuad; overload; function RGBtoRGBQuad(R, G, B: byte): TRGBQuad; overload;
@@ -28,44 +31,44 @@ implementation
function RGBtoRGBTriple(R, G, B: byte): TRGBTriple; function RGBtoRGBTriple(R, G, B: byte): TRGBTriple;
begin begin
with Result do with Result do
begin begin
rgbtRed := R; rgbtRed := R;
rgbtGreen := G; rgbtGreen := G;
rgbtBlue := B; rgbtBlue := B;
end end
end; end;
function RGBtoRGBQuad(R, G, B: byte): TRGBQuad; overload; function RGBtoRGBQuad(R, G, B: byte): TRGBQuad; overload;
begin begin
with Result do with Result do
begin begin
rgbRed := R; rgbRed := R;
rgbGreen := G; rgbGreen := G;
rgbBlue := B; rgbBlue := B;
rgbReserved := 0; rgbReserved := 0;
end end
end; end;
function RGBToRGBQuad(c: TColor): TRGBQuad; overload; function RGBToRGBQuad(c: TColor): TRGBQuad; overload;
begin begin
with Result do with Result do
begin begin
rgbRed := GetRValue(c); rgbRed := GetRValue(c);
rgbGreen := GetGValue(c); rgbGreen := GetGValue(c);
rgbBlue := GetBValue(c); rgbBlue := GetBValue(c);
rgbReserved := 0 rgbReserved := 0
end; end;
end; end;
function RGBQuadToRGB(q: TRGBQuad): TColor; function RGBQuadToRGB(q: TRGBQuad): TColor;
begin begin
Result := RGB(q.rgbRed, q.rgbGreen, q.rgbBlue); Result := RGB(q.rgbRed, q.rgbGreen, q.rgbBlue);
end; end;
function RGBTripleToTColor(RGBTriple: TRGBTriple): TColor; function RGBTripleToTColor(RGBTriple: TRGBTriple): TColor;
begin begin
Result := RGBTriple.rgbtBlue shl 16 + RGBTriple.rgbtGreen shl 8 + RGBTriple.rgbtRed; Result := RGBTriple.rgbtBlue shl 16 + RGBTriple.rgbtGreen shl 8 + RGBTriple.rgbtRed;
end; end;
end. end.

330
components/mbColorLib/VColorPicker.pas
View File

@@ -7,43 +7,43 @@ interface
{$ENDIF} {$ENDIF}
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Forms, Graphics, SysUtils, Classes, Controls, Forms, Graphics,
RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines; RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines;
type type
TVColorPicker = class(TmbTrackBarPicker) TVColorPicker = class(TmbTrackBarPicker)
private private
FHue, FSat, FVal: integer; FHue, FSat, FVal: integer;
FVBmp: TBitmap; // FVBmp: TBitmap;
function ArrowPosFromVal(l: integer): integer; function ArrowPosFromVal(l: integer): integer;
function ValFromArrowPos(p: integer): integer; function ValFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor; function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor); procedure SetSelectedColor(c: TColor);
procedure CreateVGradient; // procedure CreateVGradient;
procedure SetHue(h: integer); procedure SetHue(h: integer);
procedure SetSat(s: integer); procedure SetSat(s: integer);
procedure SetValue(v: integer); procedure SetValue(v: integer);
protected protected
procedure CreateWnd; override; procedure Execute(tbaAction: integer); override;
procedure Execute(tbaAction: integer); override; function GetArrowPos: integer; override;
function GetArrowPos: integer; override; function GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override; function GetSelectedValue: integer; override;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; // destructor Destroy; override;
published published
property Hue: integer read FHue write SetHue default 0; property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 0; property Saturation: integer read FSat write SetSat default 0;
property Value: integer read FVal write SetValue default 255; property Value: integer read FVal write SetValue default 255;
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Layout default lyVertical; property Layout default lyVertical;
end; end;
procedure Register; procedure Register;
@@ -51,173 +51,127 @@ implementation
{$IFDEF FPC} {$IFDEF FPC}
{$R VColorPicker.dcr} {$R VColorPicker.dcr}
{uses
IntfGraphics, fpimage;}
{$ENDIF} {$ENDIF}
procedure Register; procedure Register;
begin begin
RegisterComponents('mbColor Lib', [TVColorPicker]); RegisterComponents('mbColor Lib', [TVColorPicker]);
end; end;
{TVColorPicker} {TVColorPicker}
constructor TVColorPicker.Create(AOwner: TComponent); constructor TVColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FVBmp := TBitmap.Create; FGradientWidth := 256;
FVBmp.PixelFormat := pf32bit; FGradientHeight := 12;
FVBmp.SetSize(12, 255); {
Width := 22; FVBmp := TBitmap.Create;
Height := 267; FVBmp.PixelFormat := pf32bit;
Layout := lyVertical; FVBmp.SetSize(12, 255);
FHue := 0; }
FSat := 0; // Width := 22;
FArrowPos := ArrowPosFromVal(255); // Height := 267;
FChange := false; SetInitialBounds(0, 0, 22, 267);
SetValue(255); Layout := lyVertical;
HintFormat := 'Value: %value'; FHue := 0;
FManual := false; FSat := 0;
FChange := true; FArrowPos := ArrowPosFromVal(255);
FChange := false;
SetValue(255);
HintFormat := 'Value: %value';
FManual := false;
FChange := true;
end; end;
destructor TVColorPicker.Destroy; function TVColorPicker.GetGradientColor(AValue: Integer): TColor;
begin begin
FVBmp.Free; Result := HSVtoColor(FHue, FSat, AValue);
inherited Destroy;
end;
procedure TVColorPicker.CreateWnd;
begin
inherited;
CreateVGradient;
end;
procedure TVColorPicker.CreateVGradient;
var
i,j: integer;
row: pRGBQuadArray;
begin
if FVBmp = nil then
begin
FVBmp := TBitmap.Create;
FVBmp.PixelFormat := pf32bit;
end;
if Layout = lyHorizontal then
begin
FVBmp.width := 255;
FVBmp.height := 12;
for i := 0 to 254 do
for j := 0 to 11 do
begin
row := FVBmp.Scanline[j];
if not WebSafe then
row[i] := RGBToRGBQuad(HSVtoColor(FHue, FSat, i))
// FVBmp.Canvas.Pixels[i, j] := HSVtoColor(FHue, FSat, i)
else
row[i] := RGBToRGBQuad(GetWebSafe(HSVtoColor(FHue, FSat, i)));
// FVBmp.Canvas.Pixels[i, j] := GetWebSafe(HSVtoColor(FHue, FSat, i));
end;
end
else
begin
FVBmp.width := 12;
FVBmp.height := 255;
for i := 0 to 254 do
begin
row := FVBmp.ScanLine[i];
for j := 0 to 11 do
if not WebSafe then
row[j] := RGBToRGBQuad(HSVtoColor(FHue, FSat, 255 - i))
// FVBmp.Canvas.Pixels[j, i] := HSVtoColor(FHue, FSat, 255 - i)
else
row[j] := RGBToRGBQuad(GetWebSafe(HSVtoColor(FHue, FSat, 255 - i)));
// FVBmp.Canvas.Pixels[j, i] := GetWebSafe(HSVtoColor(FHue, FSat, 255 - i));
end;
end;
end; end;
procedure TVColorPicker.SetHue(h: integer); procedure TVColorPicker.SetHue(h: integer);
begin begin
if h > 360 then h := 360; if h > 360 then h := 360;
if h < 0 then h := 0; if h < 0 then h := 0;
if FHue <> h then if FHue <> h then
begin begin
FHue := h; FHue := h;
FManual := false; FManual := false;
CreateVGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TVColorPicker.SetSat(s: integer); procedure TVColorPicker.SetSat(s: integer);
begin begin
if s > 255 then s := 255; if s > 255 then s := 255;
if s < 0 then s := 0; if s < 0 then s := 0;
if FSat <> s then if FSat <> s then
begin begin
FSat := s; FSat := s;
FManual := false; FManual := false;
CreateVGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function TVColorPicker.ArrowPosFromVal(l: integer): integer; function TVColorPicker.ArrowPosFromVal(l: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/255)*l); a := Round(((Width - 12)/255)*l);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
l := 255 - l; l := 255 - l;
a := Round(((Height - 12)/255)*l); a := Round(((Height - 12)/255)*l);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function TVColorPicker.ValFromArrowPos(p: integer): integer; function TVColorPicker.ValFromArrowPos(p: integer): integer;
var var
r: integer; r: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
r := Round(p/((Width - 12)/255)) r := Round(p/((Width - 12)/255))
else else
r := Round(255 - p/((Height - 12)/255)); r := Round(255 - p/((Height - 12)/255));
if r < 0 then r := 0; if r < 0 then r := 0;
if r > 255 then r := 255; if r > 255 then r := 255;
Result := r; Result := r;
end; end;
procedure TVColorPicker.SetValue(V: integer); procedure TVColorPicker.SetValue(V: integer);
begin begin
if v < 0 then v := 0; if v < 0 then v := 0;
if v > 255 then v := 255; if v > 255 then v := 255;
if FVal <> v then if FVal <> v then
begin begin
FVal := v; FVal := v;
FArrowPos := ArrowPosFromVal(v); FArrowPos := ArrowPosFromVal(v);
FManual := false; FManual := false;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function TVColorPicker.GetSelectedColor: TColor; function TVColorPicker.GetSelectedColor: TColor;
begin begin
if not WebSafe then if not WebSafe then
Result := HSVtoColor(FHue, FSat, FVal) Result := HSVtoColor(FHue, FSat, FVal)
else else
Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal)); Result := GetWebSafe(HSVtoColor(FHue, FSat, FVal));
end; end;
function TVColorPicker.GetSelectedValue: integer; function TVColorPicker.GetSelectedValue: integer;
@@ -227,44 +181,58 @@ end;
procedure TVColorPicker.SetSelectedColor(c: TColor); procedure TVColorPicker.SetSelectedColor(c: TColor);
var var
h, s, v: integer; h, s, v: integer;
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
RGBToHSV(GetRValue(c), GetGValue(c), GetBValue(c), h, s, v); RGBToHSV(GetRValue(c), GetGValue(c), GetBValue(c), h, s, v);
FChange := false; FChange := false;
SetHue(h); SetHue(h);
SetSat(s); SetSat(s);
SetValue(v); SetValue(v);
FManual := false; FManual := false;
FChange := true; FChange := true;
if Assigned(OnChange) then OnChange(Self); if Assigned(OnChange) then OnChange(Self);
end; end;
function TVColorPicker.GetArrowPos: integer; function TVColorPicker.GetArrowPos: integer;
begin begin
Result := ArrowPosFromVal(FVal); Result := ArrowPosFromVal(FVal);
end; end;
procedure TVColorPicker.Execute(tbaAction: integer); procedure TVColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
TBA_Resize: SetValue(FVal); TBA_Resize:
TBA_Paint: Canvas.StretchDraw(FPickRect, FVBmp); SetValue(FVal);
TBA_MouseMove: FVal := ValFromArrowPos(FArrowPos); TBA_MouseMove:
TBA_MouseDown: FVal := ValFromArrowPos(FArrowPos); FVal := ValFromArrowPos(FArrowPos);
TBA_MouseUp: FVal := ValFromArrowPos(FArrowPos); TBA_MouseDown:
TBA_WheelUp: SetValue(FVal + Increment); FVal := ValFromArrowPos(FArrowPos);
TBA_WheelDown: SetValue(FVal - Increment); TBA_MouseUp:
TBA_VKRight: SetValue(FVal + Increment); FVal := ValFromArrowPos(FArrowPos);
TBA_VKCtrlRight: SetValue(255); TBA_WheelUp:
TBA_VKLeft: SetValue(FVal - Increment); SetValue(FVal + Increment);
TBA_VKCtrlLeft: SetValue(0); TBA_WheelDown:
TBA_VKUp: SetValue(FVal + Increment); SetValue(FVal - Increment);
TBA_VKCtrlUp: SetValue(255); TBA_VKRight:
TBA_VKDown: SetValue(FVal - Increment); SetValue(FVal + Increment);
TBA_VKCtrlDown: SetValue(0); TBA_VKCtrlRight:
TBA_RedoBMP: CreateVGradient; SetValue(255);
end; TBA_VKLeft:
SetValue(FVal - Increment);
TBA_VKCtrlLeft:
SetValue(0);
TBA_VKUp:
SetValue(FVal + Increment);
TBA_VKCtrlUp:
SetValue(255);
TBA_VKDown:
SetValue(FVal - Increment);
TBA_VKCtrlDown:
SetValue(0);
else
inherited;
end;
end; end;
end. end.

240
components/mbColorLib/YColorPicker.pas
View File

@@ -19,25 +19,22 @@ type
TYColorPicker = class(TmbTrackBarPicker) TYColorPicker = class(TmbTrackBarPicker)
private private
FYellow, FMagenta, FCyan, FBlack: integer; FYellow, FMagenta, FCyan, FBlack: integer;
FYBmp: TBitmap;
function ArrowPosFromYellow(y: integer): integer; function ArrowPosFromYellow(y: integer): integer;
function YellowFromArrowPos(p: integer): integer; function YellowFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor; function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor); procedure SetSelectedColor(c: TColor);
procedure CreateYGradient;
procedure SetYellow(y: integer); procedure SetYellow(y: integer);
procedure SetMagenta(m: integer); procedure SetMagenta(m: integer);
procedure SetCyan(c: integer); procedure SetCyan(c: integer);
procedure SetBlack(k: integer); procedure SetBlack(k: integer);
protected protected
procedure CreateWnd; override;
procedure Execute(tbaAction: integer); override; procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override; function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override; function GetSelectedValue: integer; override;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published published
property Yellow: integer read FYellow write SetYellow default 255; property Yellow: integer read FYellow write SetYellow default 255;
property Magenta: integer read FMagenta write SetMagenta default 0; property Magenta: integer read FMagenta write SetMagenta default 0;
@@ -64,37 +61,26 @@ end;
constructor TYColorPicker.Create(AOwner: TComponent); constructor TYColorPicker.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FYBmp := TBitmap.Create; FGradientWidth := 255;
FYBmp.PixelFormat := pf32bit; FGradientHeight := 12;
FYBmp.SetSize(12, 255); Width := 22;
Width := 22; Height := 267;
Height := 267; Layout := lyVertical;
Layout := lyVertical; FYellow := 255;
FYellow := 255; FMagenta := 0;
FMagenta := 0; FCyan := 0;
FCyan := 0; FBlack := 0;
FBlack := 0; FArrowPos := ArrowPosFromYellow(255);
FArrowPos := ArrowPosFromYellow(255); FChange := false;
FChange := false; SetYellow(255);
SetYellow(255); HintFormat := 'Yellow: %value';
HintFormat := 'Yellow: %value'; FManual := false;
FManual := false; FChange := true;
FChange := true;
end; end;
destructor TYColorPicker.Destroy;
begin
FYBmp.Free;
inherited Destroy;
end;
procedure TYColorPicker.CreateWnd;
begin
inherited;
CreateYGradient;
end;
(*
procedure TYColorPicker.CreateYGradient; procedure TYColorPicker.CreateYGradient;
var var
i,j: integer; i,j: integer;
@@ -138,105 +124,107 @@ begin
end; end;
end; end;
end; end;
*)
function TYColorPicker.GetGradientColor(AValue: Integer): TColor;
begin
Result := CMYKtoTColor(FCyan, FMagenta, AValue, FBlack);
end;
procedure TYColorPicker.SetYellow(y: integer); procedure TYColorPicker.SetYellow(y: integer);
begin begin
if y < 0 then y := 0; if y < 0 then y := 0;
if y > 255 then y := 255; if y > 255 then y := 255;
if FYellow <> y then if FYellow <> y then
begin begin
FYellow := y; FYellow := y;
FArrowPos := ArrowPosFromYellow(y); FArrowPos := ArrowPosFromYellow(y);
FManual := false; FManual := false;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TYColorPicker.SetMagenta(m: integer); procedure TYColorPicker.SetMagenta(m: integer);
begin begin
if m > 255 then m := 255; if m > 255 then m := 255;
if m < 0 then m := 0; if m < 0 then m := 0;
if FMagenta <> m then if FMagenta <> m then
begin begin
FMagenta := m; FMagenta := m;
FManual := false; FManual := false;
CreateYGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TYColorPicker.SetCyan(c: integer); procedure TYColorPicker.SetCyan(c: integer);
begin begin
if c > 255 then c := 255; if c > 255 then c := 255;
if c < 0 then c := 0; if c < 0 then c := 0;
if FCyan <> c then if FCyan <> c then
begin begin
FCyan := c; FCyan := c;
FManual := false; FManual := false;
CreateYGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
procedure TYColorPicker.SetBlack(k: integer); procedure TYColorPicker.SetBlack(k: integer);
begin begin
if k > 255 then k := 255; if k > 255 then k := 255;
if k < 0 then k := 0; if k < 0 then k := 0;
if FBlack <> k then if FBlack <> k then
begin begin
FBlack := k; FBlack := k;
FManual := false; FManual := false;
CreateYGradient; CreateGradient;
Invalidate; Invalidate;
if FChange then if FChange and Assigned(OnChange) then OnChange(Self);
if Assigned(OnChange) then OnChange(Self);
end; end;
end; end;
function TYColorPicker.ArrowPosFromYellow(y: integer): integer; function TYColorPicker.ArrowPosFromYellow(y: integer): integer;
var var
a: integer; a: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
begin begin
a := Round(((Width - 12)/255)*y); a := Round(((Width - 12)/255)*y);
if a > Width - FLimit then a := Width - FLimit; if a > Width - FLimit then a := Width - FLimit;
end end
else else
begin begin
y := 255 - y; y := 255 - y;
a := Round(((Height - 12)/255)*y); a := Round(((Height - 12)/255)*y);
if a > Height - FLimit then a := Height - FLimit; if a > Height - FLimit then a := Height - FLimit;
end; end;
if a < 0 then a := 0; if a < 0 then a := 0;
Result := a; Result := a;
end; end;
function TYColorPicker.YellowFromArrowPos(p: integer): integer; function TYColorPicker.YellowFromArrowPos(p: integer): integer;
var var
r: integer; r: integer;
begin begin
if Layout = lyHorizontal then if Layout = lyHorizontal then
r := Round(p/((Width - 12)/255)) r := Round(p/((Width - 12)/255))
else else
r := Round(255 - p/((Height - 12)/255)); r := Round(255 - p/((Height - 12)/255));
if r < 0 then r := 0; if r < 0 then r := 0;
if r > 255 then r := 255; if r > 255 then r := 255;
Result := r; Result := r;
end; end;
function TYColorPicker.GetSelectedColor: TColor; function TYColorPicker.GetSelectedColor: TColor;
begin begin
if not WebSafe then if not WebSafe then
Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack) Result := CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)
else else
Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack)); Result := GetWebSafe(CMYKtoTColor(FCyan, FMagenta, FYellow, FBlack));
end; end;
function TYColorPicker.GetSelectedValue: integer; function TYColorPicker.GetSelectedValue: integer;
@@ -246,45 +234,59 @@ end;
procedure TYColorPicker.SetSelectedColor(c: TColor); procedure TYColorPicker.SetSelectedColor(c: TColor);
var var
cy, m, y, k: integer; cy, m, y, k: integer;
begin begin
if WebSafe then c := GetWebSafe(c); if WebSafe then c := GetWebSafe(c);
ColorToCMYK(c, cy, m, y, k); ColorToCMYK(c, cy, m, y, k);
FChange := false; FChange := false;
SetMagenta(m); SetMagenta(m);
SetCyan(cy); SetCyan(cy);
SetBlack(k); SetBlack(k);
SetYellow(y); SetYellow(y);
FManual := false; FManual := false;
FChange := true; FChange := true;
if Assigned(OnChange) then OnChange(Self); if Assigned(OnChange) then OnChange(Self);
end; end;
function TYColorPicker.GetArrowPos: integer; function TYColorPicker.GetArrowPos: integer;
begin begin
Result := ArrowPosFromYellow(FYellow); Result := ArrowPosFromYellow(FYellow);
end; end;
procedure TYColorPicker.Execute(tbaAction: integer); procedure TYColorPicker.Execute(tbaAction: integer);
begin begin
case tbaAction of case tbaAction of
TBA_Resize: SetYellow(FYellow); TBA_Resize:
TBA_Paint: Canvas.StretchDraw(FPickRect, FYBmp); SetYellow(FYellow);
TBA_MouseMove: FYellow := YellowFromArrowPos(FArrowPos); TBA_MouseMove:
TBA_MouseDown: FYellow := YellowFromArrowPos(FArrowPos); FYellow := YellowFromArrowPos(FArrowPos);
TBA_MouseUp: FYellow := YellowFromArrowPos(FArrowPos); TBA_MouseDown:
TBA_WheelUp: SetYellow(FYellow + Increment); FYellow := YellowFromArrowPos(FArrowPos);
TBA_WheelDown: SetYellow(FYellow - Increment); TBA_MouseUp:
TBA_VKRight: SetYellow(FYellow + Increment); FYellow := YellowFromArrowPos(FArrowPos);
TBA_VKCtrlRight: SetYellow(255); TBA_WheelUp:
TBA_VKLeft: SetYellow(FYellow - Increment); SetYellow(FYellow + Increment);
TBA_VKCtrlLeft: SetYellow(0); TBA_WheelDown:
TBA_VKUp: SetYellow(FYellow + Increment); SetYellow(FYellow - Increment);
TBA_VKCtrlUp: SetYellow(255); TBA_VKRight:
TBA_VKDown: SetYellow(FYellow - Increment); SetYellow(FYellow + Increment);
TBA_VKCtrlDown: SetYellow(0); TBA_VKCtrlRight:
TBA_RedoBMP: CreateYGradient; SetYellow(255);
end; TBA_VKLeft:
SetYellow(FYellow - Increment);
TBA_VKCtrlLeft:
SetYellow(0);
TBA_VKUp:
SetYellow(FYellow + Increment);
TBA_VKCtrlUp:
SetYellow(255);
TBA_VKDown:
SetYellow(FYellow - Increment);
TBA_VKCtrlDown:
SetYellow(0);
else
inherited;
end;
end; end;
end. end.

111
components/mbColorLib/mbBasicPicker.pas Normal file
View File

@@ -0,0 +1,111 @@
unit mbBasicPicker;
{$mode objfpc}{$H+}
interface
uses
{$IFDEF FPC}
LMessages,
{$ELSE}
Messages,
{$ENDIF}
Classes, SysUtils, Graphics, Controls;
type
TmbBasicPicker = class(TCustomControl)
protected
procedure PaintParentBack; virtual; overload;
procedure PaintParentBack(ACanvas: TCanvas); overload;
procedure PaintParentBack(ABitmap: TBitmap); overload;
{$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}
public
constructor Create(AOwner: TComponent); override;
function GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; override;
published
property ParentColor default true;
end;
implementation
constructor TmbBasicPicker.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle - [csOpaque];
ParentColor := true;
end;
procedure TmbBasicPicker.CMParentColorChanged(var Message: TLMessage);
begin
if ParentColor then
ControlStyle := ControlStyle - [csOpaque]
else
ControlStyle := ControlStyle + [csOpaque];
inherited;
end;
function TmbBasicPicker.GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor;
begin
result := inherited GetDefaultColor(DefaultColorType);
end;
procedure TmbBasicPicker.PaintParentBack;
begin
PaintParentBack(Canvas);
end;
procedure TmbBasicPicker.PaintParentBack(ABitmap: TBitmap);
begin
{$IFNDEF DELPHI}
if Color = clDefault then
ABitmap.Canvas.Brush.Color := GetDefaultColor(dctBrush)
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);
var
OffScreen: TBitmap;
begin
Offscreen := TBitmap.Create;
try
Offscreen.PixelFormat := pf32bit;
Offscreen.Width := Width;
Offscreen.Height := Height;
PaintParentBack(Offscreen);
ACanvas.Draw(0, 0, Offscreen);
finally
Offscreen.Free;
end;
end;
procedure TmbBasicPicker.WMEraseBkgnd(
var Message: {$IFDEF DELPHI}TWMEraseBkgnd{$ELSE}TLMEraseBkgnd{$ENDIF} );
begin
inherited;
// Message.Result := 1;
end;
end.

399
components/mbColorLib/mbColorPalette.pas
View File

@@ -15,7 +15,7 @@ uses
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} SysUtils, Classes, Controls, Graphics, {$IFDEF DELPHI_7_UP} Themes, {$ENDIF}
Forms, HTMLColors, PalUtils, Dialogs; Forms, HTMLColors, PalUtils, Dialogs, mbBasicPicker;
type type
TMouseLoc = (mlNone, mlOver, mlDown); TMouseLoc = (mlNone, mlOver, mlDown);
@@ -28,7 +28,7 @@ type
TGetHintTextEvent = procedure (AColor: TColor; Index: integer; var HintStr: string; var Handled: boolean) of object; TGetHintTextEvent = procedure (AColor: TColor; Index: integer; var HintStr: string; var Handled: boolean) of object;
TArrowKeyEvent = procedure (Key: Word; Shift: TShiftState) of object; TArrowKeyEvent = procedure (Key: Word; Shift: TShiftState) of object;
TmbColorPalette = class(TCustomControl) TmbColorPalette = class(TmbBasicPicker)
private private
FMouseLoc: TMouseLoc; FMouseLoc: TMouseLoc;
FMouseOver, FMouseDown, FAutoHeight: boolean; FMouseOver, FMouseDown, FAutoHeight: boolean;
@@ -77,13 +77,11 @@ type
procedure Click; override; procedure Click; override;
procedure Resize; override; procedure Resize; override;
procedure SelectCell(i: integer); procedure SelectCell(i: integer);
procedure PaintParentBack;
procedure CreateWnd; override; procedure CreateWnd; override;
procedure MouseDown(Button: TMouseButton; 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 MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
{$IFDEF DELPHI} {$IFDEF DELPHI}
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN; procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
@@ -92,7 +90,6 @@ type
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED; procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
{$ELSE} {$ELSE}
procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
procedure CMMouseEnter(var Message: TLMessage); message CM_MOUSEENTER; procedure CMMouseEnter(var Message: TLMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE; procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN; procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN;
@@ -101,6 +98,7 @@ type
procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED; procedure CMEnabledChanged(var Message: TLMessage); message CM_ENABLEDCHANGED;
procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW; procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW;
{$ENDIF} {$ENDIF}
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; destructor Destroy; override;
@@ -116,6 +114,7 @@ type
procedure SaveColorsAsPalette(FileName: TFileName); procedure SaveColorsAsPalette(FileName: TFileName);
procedure GeneratePalette(BaseColor: TColor); procedure GeneratePalette(BaseColor: TColor);
procedure GenerateGradientPalette(Colors: array of TColor); procedure GenerateGradientPalette(Colors: array of TColor);
published published
property Align; property Align;
property Anchors; property Anchors;
@@ -141,8 +140,6 @@ type
property TabOrder; property TabOrder;
property ShowHint default false; property ShowHint default false;
property Constraints; property Constraints;
property Color;
property ParentColor;
property ParentShowHint default true; property ParentShowHint default true;
property PopupMenu; property PopupMenu;
property Visible; property Visible;
@@ -193,6 +190,8 @@ begin
DoubleBuffered := true; DoubleBuffered := true;
PBack := TBitmap.Create; PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit; PBack.PixelFormat := pf32bit;
FTempBmp := TBitmap.Create;
FTempBmp.PixelFormat := pf32bit;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
ParentBackground := true; ParentBackground := true;
{$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF}
@@ -229,35 +228,36 @@ end;
destructor TmbColorPalette.Destroy; destructor TmbColorPalette.Destroy;
begin begin
PBack.Free; PBack.Free;
FNames.Free; FTempBmp.Free;
FColors.Free; FNames.Free;
inherited Destroy; FColors.Free;
inherited Destroy;
end; end;
procedure TmbColorPalette.CalcAutoHeight; procedure TmbColorPalette.CalcAutoHeight;
begin begin
if Parent = nil then if Parent = nil then
exit; exit;
FColCount := Width div FCellSize; FColCount := Width div FCellSize;
if FAutoHeight and (FColCount <> 0) then if FAutoHeight and (FColCount <> 0) then
begin begin
if FColors.Count mod FColCount > 0 then if FColors.Count mod FColCount > 0 then
Height := (FColors.Count div FColCount + 1) * FCellSize Height := (FColors.Count div FColCount + 1) * FCellSize
else else
Height := (FColors.Count div FColCount) * FCellSize; Height := (FColors.Count div FColCount) * FCellSize;
end; end;
if Height = 0 then Height := FCellSize; if Height = 0 then Height := FCellSize;
FRowCount := Height div FCellSize; FRowCount := Height div FCellSize;
Width := FColCount * FCellSize; Width := FColCount * FCellSize;
end; end;
function TmbColorPalette.GetTotalRowCount: integer; function TmbColorPalette.GetTotalRowCount: integer;
begin begin
if FColCount <> 0 then if FColCount <> 0 then
Result := FTotalCells div FColCount Result := FTotalCells div FColCount
else else
Result := 0; Result := 0;
end; end;
procedure TmbColorPalette.CreateWnd; procedure TmbColorPalette.CreateWnd;
@@ -266,7 +266,7 @@ begin
CalcAutoHeight; CalcAutoHeight;
Invalidate; Invalidate;
end; end;
(*
procedure TmbColorPalette.PaintParentBack; procedure TmbColorPalette.PaintParentBack;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI_7_UP}
var var
@@ -283,7 +283,7 @@ begin
PBack.Height := Height; PBack.Height := Height;
{$IFDEF FPC} {$IFDEF FPC}
if Color = clDefault then if Color = clDefault then
PBack.Canvas.Brush.Color := clForm PBack.Canvas.Brush.Color := GetDefaultColor(dctBrush)
else else
{$ENDIF} {$ENDIF}
PBack.Canvas.Brush.Color := Color; PBack.Canvas.Brush.Color := Color;
@@ -300,170 +300,154 @@ begin
if MemDC <> 0 then DeleteDC(MemDC); if MemDC <> 0 then DeleteDC(MemDC);
end; end;
{$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF}
end; end; *)
procedure TmbColorPalette.Paint; procedure TmbColorPalette.Paint;
var var
i: integer; i: integer;
begin begin
PaintParentBack; PBack.Width := Width;
//make bmp PBack.Height := Height;
FTempBmp := TBitmap.Create; PaintParentBack(PBack);
try
FTempBmp.PixelFormat := pf32bit; //make bmp
FTempBmp.Width := Width; FTempBmp.Width := Width;
FTempBmp.Height := Height; FTempBmp.Height := Height;
PaintParentBack(FTempBmp);
{$IFDEF FPC}
if Color = clDefault then
FTempBmp.Canvas.Brush.Color := clForm
else
{$ENDIF}
FTempBmp.Canvas.Brush.Color := Color;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
if not ParentBackground then
{$ENDIF} {$ENDIF}
FTempBmp.Canvas.FillRect(FTempBmp.Canvas.ClipRect)
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
else
FTempBmp.Canvas.Draw(0, 0, PBack){$ENDIF} {$ENDIF};
FTotalCells := FColors.Count - 1;
//reset counters //reset counters
FTotalCells := FColors.Count - 1;
FTop := 0; FTop := 0;
FLeft := 0; FLeft := 0;
//draw the cells //draw the cells
for i := 0 to FColors.Count - 1 do for i := 0 to FColors.Count - 1 do
begin begin
if FColors.Strings[i] <> '' then if FColors.Strings[i] <> '' then
DrawCell(FColors.Strings[i]); DrawCell(FColors.Strings[i]);
Inc(FLeft); Inc(FLeft);
end; end;
//draw the result
//draw the bmp
Canvas.Draw(0, 0, FTempBmp); Canvas.Draw(0, 0, FTempBmp);
//csDesiginng border
//csDesiging border
if csDesigning in ComponentState then if csDesigning in ComponentState then
begin begin
Canvas.Brush.Style := bsClear; Canvas.Brush.Style := bsClear;
Canvas.Pen.Style := psDot; Canvas.Pen.Style := psDot;
Canvas.Pen.Color := clBtnShadow; Canvas.Pen.Color := clBtnShadow;
Canvas.Rectangle(ClientRect); Canvas.Rectangle(ClientRect);
Canvas.Brush.Style := bsSolid; Canvas.Brush.Style := bsSolid;
Canvas.Pen.Style := psSolid; Canvas.Pen.Style := psSolid;
end; end;
finally
FTempBmp.Free;
end;
end; end;
procedure TmbColorPalette.DrawCell(clr: string); procedure TmbColorPalette.DrawCell(clr: string);
var var
R: Trect; R: Trect;
FCurrentIndex: integer; FCurrentIndex: integer;
c: TColor; c: TColor;
Handled: boolean; Handled: boolean;
begin begin
// set props // set props
if (FLeft + 1) * FCellSize > FTempBmp.width then if (FLeft + 1) * FCellSize > FTempBmp.Width then
begin begin
Inc(FTop); Inc(FTop);
FLeft := 0; FLeft := 0;
end; end;
FCurrentIndex := FTop * FColCount + FLeft;
R := Rect(FLeft * FCellSize, FTop * FCellSize, (FLeft + 1) * FCellSize, (FTop + 1) * FCellSize); FCurrentIndex := FTop * FColCount + FLeft;
//start drawing R := Rect(FLeft * FCellSize, FTop * FCellSize, (FLeft + 1) * FCellSize, (FTop + 1) * FCellSize);
with FTempBmp.Canvas do
//start drawing
//get current state
if FCurrentIndex = FCheckedIndex then
begin begin
{$IFDEF FPC} if FCheckedIndex = FIndex then
if Color = clDefault then
Brush.Color := clForm else
{$ENDIF}
Brush.Color := Color;
//get current state
if FCurrentIndex = FCheckedIndex then
begin begin
if FCheckedIndex = FIndex then if FMouseDown then
begin
if FMouseDown then
FState := ccsDown FState := ccsDown
else else
FState := ccsCheckedHover; FState := ccsCheckedHover;
end
else
FState := ccsChecked;
end end
else else
if FIndex = FCurrentIndex then FState := ccsChecked;
case FMouseLoc of end
else
if FIndex = FCurrentIndex then
case FMouseLoc of
mlNone: FState := ccsNone; mlNone: FState := ccsNone;
mlOver: FState := ccsOver; mlOver: FState := ccsOver;
end end
else else
FState := ccsNone; FState := ccsNone;
//paint //paint
DrawCellBack(FTempBmp.Canvas, R, FCurrentIndex); DrawCellBack(FTempBmp.Canvas, R, FCurrentIndex);
// fire the event // fire the event
Handled := false; Handled := false;
if Assigned(FOnPaintCell) then if Assigned(FOnPaintCell) then
case FCellStyle of case FCellStyle of
csDefault: FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled); csDefault:
csCorel: FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled);
if FColCount = 1 then csCorel:
FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled) if FColCount = 1 then
else FOnPaintCell(FTempBmp.Canvas, R, mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled)
FOnPaintCell(FTempBmp.Canvas, Rect(R.Left, R.Top, R.Right + 1, R.Bottom), mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled); else
FOnPaintCell(FTempBmp.Canvas, Rect(R.Left, R.Top, R.Right + 1, R.Bottom), mbStringToColor(clr), FCurrentIndex, FState, FTStyle, Handled);
end; end;
if not Handled then
begin if not Handled then
// if standard colors draw the rect begin
if not SameText(clr, 'clCustom') and not SameText(clr, 'clTransparent') then // if standard colors draw the rect
c := mbStringToColor(clr);
if not SameText(clr, 'clCustom') and not SameText(clr, 'clTransparent') then
case FCellStyle of case FCellStyle of
csDefault: csDefault:
begin
InflateRect(R, -3, -3);
c := mbStringToColor(clr);
if Enabled then
begin begin
Brush.Color := c; InflateRect(R, -3, -3);
Pen.Color := clBtnShadow; if Enabled then
end begin
else FTempBmp.Canvas.Brush.Color := c;
begin FTempBmp.Canvas.Pen.Color := clBtnShadow;
Brush.Color := clGray; end
Pen.Color := clGray; else
begin
FTempBmp.Canvas.Brush.Color := clGray;
FTempBmp.Canvas.Pen.Color := clGray;
end;
FTempBmp.Canvas.Rectangle(R);
Exit;
end; end;
Rectangle(R);
Exit; csCorel:
end;
csCorel:
begin
if (FState <> ccsNone) then
InflateRect(R, -2, -2)
else
begin begin
Inc(R.Left); if (FState <> ccsNone) then
Dec(R.Bottom); InflateRect(R, -2, -2)
if R.Top <= 1 then else
Inc(R.Top); begin
if R.Right = Width then Inc(R.Left);
Dec(R.Right); Dec(R.Bottom);
if R.Top <= 1 then
Inc(R.Top);
if R.Right = Width then
Dec(R.Right);
end;
if Enabled then
FTempBmp.Canvas.Brush.Color := c
else
FTempBmp.Canvas.Brush.Color := clGray;
FTempBmp.Canvas.FillRect(R);
Exit;
end; end;
c := mbStringToColor(clr);
if Enabled then
Brush.Color := c
else
Brush.Color := clGray;
FillRect(R);
Exit;
end;
end; end;
//if transparent draw the glyph //if transparent draw the glyph
if SameText(clr, 'clTransparent') then PaintTransparentGlyph(FTempBmp.Canvas, R); if SameText(clr, 'clTransparent') then
end; PaintTransparentGlyph(FTempBmp.Canvas, R);
end; end;
end; end;
@@ -588,6 +572,10 @@ begin
else else
{$ENDIF} {$ENDIF}
begin begin
{$IFDEF FPC}
if Color = clDefault then
ACanvas.Brush.Color := GetDefaultColor(dctBrush) else
{$ENDIF}
ACanvas.Brush.Color := Color; ACanvas.Brush.Color := Color;
ACanvas.FillRect(R); ACanvas.FillRect(R);
end; end;
@@ -680,7 +668,7 @@ end;
procedure TmbColorPalette.Resize; procedure TmbColorPalette.Resize;
begin begin
inherited; inherited;
CalcAutoHeight; //CalcAutoHeight; // wp: will cause a ChangedBounds endless loop
Invalidate; Invalidate;
end; end;
@@ -704,14 +692,17 @@ begin
end; end;
procedure TmbColorPalette.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TmbColorPalette.MouseMove(Shift: TShiftState; X, Y: Integer);
var
newIndex: Integer;
begin begin
if FIndex <> (y div FCellSize)* FColCount + (x div FCellSize) then newIndex := (y div FCellSize) * FColCount + (x div FCellSize);
if FIndex <> newIndex then
begin begin
FIndex := (y div FCellSize)* FColCount + (x div FCellSize); FIndex := newIndex;
if FIndex > FTotalCells then FIndex := -1; if FIndex > FTotalCells then FIndex := -1;
Invalidate; Invalidate;
end; end;
inherited; inherited;
end; end;
procedure TmbColorPalette.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TmbColorPalette.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
@@ -739,99 +730,93 @@ end;
procedure TmbColorPalette.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TmbColorPalette.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var var
DontCheck: boolean; DontCheck: boolean;
AColor: TColor; AColor: TColor;
begin begin
FMouseDown := false; FMouseDown := false;
if FMouseOver then if FMouseOver then
FMouseLoc := mlOver FMouseLoc := mlOver
else else
FMouseLoc := mlNone; FMouseLoc := mlNone;
DontCheck := false; DontCheck := false;
if (FCheckedIndex > -1) and (FCheckedIndex < FColors.Count) then if (FCheckedIndex > -1) and (FCheckedIndex < FColors.Count) then
AColor := mbStringToColor(FColors.Strings[FCheckedIndex]) AColor := mbStringToColor(FColors.Strings[FCheckedIndex])
else else
AColor := clNone; AColor := clNone;
if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then
if Assigned(FOnCellClick) then if Assigned(FOnCellClick) then
FOnCellClick(Button, Shift, FCheckedIndex, AColor, DontCheck); FOnCellClick(Button, Shift, FCheckedIndex, AColor, DontCheck);
if DontCheck then FCheckedIndex := FOldIndex; if DontCheck then FCheckedIndex := FOldIndex;
Invalidate; Invalidate;
inherited; inherited;
if Assigned(FOnChange) then FOnChange(Self); if Assigned(FOnChange) then FOnChange(Self);
end; end;
procedure TmbColorPalette.CMGotFocus( procedure TmbColorPalette.CMGotFocus(
var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} );
begin begin
inherited; inherited;
Invalidate; Invalidate;
end; end;
procedure TmbColorPalette.CMLostFocus( procedure TmbColorPalette.CMLostFocus(
var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} );
begin begin
inherited; inherited;
if FMouseOver then if FMouseOver then
FMouseLoc := mlOver FMouseLoc := mlOver
else else
FMouseLoc := mlNone; FMouseLoc := mlNone;
Invalidate; Invalidate;
end; end;
procedure TmbColorPalette.CMEnabledChanged( procedure TmbColorPalette.CMEnabledChanged(
var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} );
begin begin
inherited; inherited;
Invalidate; Invalidate;
end;
procedure TmbColorPalette.WMEraseBkgnd(
var Message: {$IFDEF DELPHI}TWMEraseBkgnd{$ELSE}TLMEraseBkgnd{$ENDIF});
begin
Message.Result := 1;
end; end;
procedure TmbColorPalette.SelectCell(i: integer); procedure TmbColorPalette.SelectCell(i: integer);
begin begin
if i < FColors.Count - 1 then if i < FColors.Count - 1 then
FCheckedIndex := i FCheckedIndex := i
else else
FCheckedIndex := -1; FCheckedIndex := -1;
Invalidate; Invalidate;
if Assigned(FOnChange) then FOnChange(Self); if Assigned(FOnChange) then FOnChange(Self);
end; end;
function TmbColorPalette.GetSelColor: TColor; function TmbColorPalette.GetSelColor: TColor;
begin begin
if (FCheckedIndex > -1) and (FCheckedIndex <= FTotalCells) then if (FCheckedIndex > -1) and (FCheckedIndex <= FTotalCells) then
Result := mbStringToColor(FColors.Strings[FCheckedIndex]) Result := mbStringToColor(FColors.Strings[FCheckedIndex])
else else
Result := FOld; Result := FOld;
end; end;
function TmbColorPalette.GetColorUnderCursor: TColor; function TmbColorPalette.GetColorUnderCursor: TColor;
begin begin
Result := clNone; Result := clNone;
if FIndex > -1 then if FIndex > -1 then
if FIndex < FColors.Count then if FIndex < FColors.Count then
Result := mbStringToColor(FColors.Strings[FIndex]); Result := mbStringToColor(FColors.Strings[FIndex]);
end; end;
function TmbColorPalette.GetIndexUnderCursor: integer; function TmbColorPalette.GetIndexUnderCursor: integer;
begin begin
Result := -1; Result := -1;
if FIndex > -1 then if FIndex > -1 then
if FIndex < FColors.Count then if FIndex < FColors.Count then
Result := FIndex; Result := FIndex;
end; end;
procedure TmbColorPalette.SetTStyle(s: TTransparentStyle); procedure TmbColorPalette.SetTStyle(s: TTransparentStyle);
begin begin
if FTStyle <> s then if FTStyle <> s then
begin begin
FTStyle := s; FTStyle := s;
Invalidate; Invalidate;
end; end;
end; end;

66
components/mbColorLib/mbColorPickerControl.pas
View File

@@ -16,39 +16,37 @@ uses
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
{$IFDEF DELPHI_7_UP} Themes,{$ENDIF} {$IFDEF DELPHI_7_UP} Themes,{$ENDIF}
RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors; RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors, mbBasicPicker;
type type
TMarkerStyle = (msCircle, msSquare, msCross, msCrossCirc); TMarkerStyle = (msCircle, msSquare, msCross, msCrossCirc);
TmbCustomPicker = class(TCustomControl) TmbCustomPicker = class(TmbBasicPicker)
private private
FHintFormat: string; FHintFormat: string;
FMarkerStyle: TMarkerStyle; FMarkerStyle: TMarkerStyle;
FWebSafe: boolean; FWebSafe: boolean;
procedure SetMarkerStyle(s: TMarkerStyle); procedure SetMarkerStyle(s: TMarkerStyle);
procedure SetWebSafe(s: boolean); procedure SetWebSafe(s: boolean);
protected protected
mx, my, mdx, mdy: integer; mx, my, mdx, mdy: integer;
function GetSelectedColor: TColor; virtual; function GetSelectedColor: TColor; virtual;
procedure SetSelectedColor(C: TColor); virtual; procedure SetSelectedColor(C: TColor); virtual;
procedure WebSafeChanged; dynamic; procedure WebSafeChanged; dynamic;
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
message {$IFDEF FPC} LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
procedure CMGotFocus(var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF});
message CM_ENTER;
procedure CMLostFocus(var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMLostFocus{$ENDIF});
message CM_EXIT;
procedure CMMouseLeave(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
message CM_MOUSELEAVE;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; 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 MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure PaintParentBack(ACanvas: TCanvas);
procedure CreateWnd; 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; property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
@@ -112,7 +110,6 @@ begin
ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls]; ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls];
DoubleBuffered := true; DoubleBuffered := true;
TabStop := true; TabStop := true;
ParentColor := true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI} {$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true; ParentBackground := true;
{$ENDIF}{$ENDIF} {$ENDIF}{$ENDIF}
@@ -129,39 +126,6 @@ begin
inherited; inherited;
end; end;
procedure TmbCustomPicker.PaintParentBack(ACanvas: TCanvas);
var
OffScreen: TBitmap;
{$IFDEF DELPHI_7_UP}
MemDC: HDC;
OldBMP: HBITMAP;
{$ENDIF}
begin
Offscreen := TBitmap.Create;
Offscreen.Width := Width;
Offscreen.Height := Height;
{$IFDEF FPC}
if Color = clDefault then
Offscreen.Canvas.Brush.Color := clForm else
{$ENDIF}
Offscreen.Canvas.Brush.Color := Color;
Offscreen.Canvas.FillRect(Offscreen.Canvas.ClipRect);
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
if ParentBackground then
with ThemeServices do
if ThemesEnabled then
begin
MemDC := CreateCompatibleDC(0);
OldBMP := SelectObject(MemDC, OffScreen.Handle);
DrawParentBackground(Handle, MemDC, nil, False);
if OldBMP <> 0 then SelectObject(MemDC, OldBMP);
if MemDC <> 0 then DeleteDC(MemDC);
end;
{$ENDIF}{$ENDIF}
ACanvas.Draw(0, 0, Offscreen);
Offscreen.Free;
end;
procedure TmbCustomPicker.CMGotFocus( procedure TmbCustomPicker.CMGotFocus(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF} ); var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF} );
begin begin
@@ -176,12 +140,6 @@ begin
Invalidate; Invalidate;
end; end;
procedure TmbCustomPicker.WMEraseBkgnd(
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
begin
Message.Result := 1;
end;
procedure TmbCustomPicker.CMMouseLeave( procedure TmbCustomPicker.CMMouseLeave(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF}); var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
begin begin

88
components/mbColorLib/mbColorTree.pas
View File

@@ -44,10 +44,10 @@ type
FGetHint: TGetHintEvent; FGetHint: TGetHintEvent;
FOnStartDrag: TStartDragEvent; FOnStartDrag: TStartDragEvent;
FOnEndDrag: TEndDragEvent; FOnEndDrag: TEndDragEvent;
procedure SetInfo1(Value: string); procedure SetInfo1(Value: string);
procedure SetInfo2(Value: string); procedure SetInfo2(Value: string);
procedure SetInfoLabel(Value: string); procedure SetInfoLabel(Value: string);
protected protected
function CanChange(Node: TTreeNode): Boolean; override; function CanChange(Node: TTreeNode): Boolean; override;
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
@@ -59,6 +59,9 @@ type
procedure DrawColorItem(R: TRect; Selected: boolean; Index: integer; itemText: string; Expanded: boolean); dynamic; procedure DrawColorItem(R: TRect; Selected: boolean; Index: integer; itemText: string; Expanded: boolean); dynamic;
procedure DrawInfoItem(R: TRect; Index: integer); dynamic; procedure DrawInfoItem(R: TRect; Index: integer); dynamic;
procedure DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean); procedure DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean);
{$IFDEF FPC}
procedure WMHScroll(var Msg: TLMScroll); message LM_HSCROLL;
{$ENDIF}
public public
Colors: array of TmbColor; Colors: array of TmbColor;
@@ -309,12 +312,12 @@ end;
function TmbColorTree.CustomDrawItem(Node: TTreeNode; State: TCustomDrawState; function TmbColorTree.CustomDrawItem(Node: TTreeNode; State: TCustomDrawState;
Stage: TCustomDrawStage; var PaintImages: Boolean): Boolean; Stage: TCustomDrawStage; var PaintImages: Boolean): Boolean;
begin begin
Result := true; Result := true;
if Length(Colors) = 0 then Exit; if Length(Colors) = 0 then Exit;
if Node.HasChildren then if Node.HasChildren then
DrawColorItem(Node.DisplayRect(false), cdsSelected in State, node.Index, node.Text, node.Expanded) DrawColorItem(Node.DisplayRect(false), cdsSelected in State, node.Index, node.Text, node.Expanded)
else else
DrawInfoItem(Node.DisplayRect(false), node.Parent.Index); DrawInfoItem(Node.DisplayRect(false), node.Parent.Index);
end; end;
procedure TmbColorTree.DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean); procedure TmbColorTree.DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean);
@@ -351,24 +354,25 @@ var
SR, TR: TRect; SR, TR: TRect;
begin begin
with Canvas do with Canvas do
begin begin
//background //background
Pen.Color := clWindow; Pen.Color := clWindow;
if Selected then if Selected then
Brush.Color := clHighlight Brush.Color := clHighlight
else else
Brush.Color := clBtnFace; Brush.Color := Color; //clBtnFace;
FillRect(R); FillRect(R);
MoveTo(R.Left, R.Bottom - 1); MoveTo(R.Left, R.Bottom - 1);
LineTo(R.Right, R.Bottom - 1); LineTo(R.Right, R.Bottom - 1);
//swatches //swatches
SR := Rect(R.Left + 6, R.Top + 6, R.Left + 42, R.Top + 42); SR := Rect(R.Left + 6, R.Top + 6, R.Left + 42, R.Top + 42);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[Index].value;
if Selected then if Selected then
begin begin
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI_7_UP}
if ThemeServices.ThemesEnabled then if ThemeServices.ThemesEnabled then
begin begin
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR); ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
InflateRect(SR, -2, -2); InflateRect(SR, -2, -2);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80); Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80);
@@ -379,10 +383,10 @@ begin
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[Index].value;
FillRect(SR); FillRect(SR);
end end
else else
//windows 9x //windows 9x
begin begin
{$ENDIF} {$ENDIF}
Pen.Color := clBackground; Pen.Color := clBackground;
Brush.Color := clWindow; Brush.Color := clWindow;
@@ -399,26 +403,26 @@ begin
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[Index].value;
FillRect(SR); FillRect(SR);
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI_7_UP}
end; end;
{$ENDIF} {$ENDIF}
end end
else else
//not selected //not selected
begin begin
//windows XP //windows XP
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI_7_UP}
if ThemeServices.ThemesEnabled then if ThemeServices.ThemesEnabled then
begin begin
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR); ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
InflateRect(SR, -2, -2); InflateRect(SR, -2, -2);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[Index].value;
FillRect(SR); FillRect(SR);
end end
else else
//windows 9x //windows 9x
begin begin
{$ENDIF} {$ENDIF}
DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT); DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT);
InflateRect(SR, -2, -2); InflateRect(SR, -2, -2);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[Index].value;
@@ -428,32 +432,34 @@ begin
FillRect(SR); FillRect(SR);
InflateRect(SR, 1, 1); InflateRect(SR, 1, 1);
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI_7_UP}
end; end;
{$ENDIF} {$ENDIF}
end; end;
//names //names
Font.Style := [fsBold]; Font.Style := [fsBold];
if Selected then if Selected then
begin begin
Brush.Color := clHighlightText; Brush.Color := clHighlightText;
Pen.Color := clHighlightText; Pen.Color := clHighlightText;
end end
else else
begin begin
Brush.Color := clWindowText; Brush.Color := clWindowText;
Pen.Color := clWindowText; Pen.Color := clWindowText;
end; end;
TR := Rect(R.Left + 48, R.Top + (48 - TextHeight(itemText)) div 2, R.Right - 15, R.Bottom); 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); if Assigned(FDraw) then FDraw(Self, Index, Canvas.Font, itemText, Selected);
DrawText(Canvas.Handle, PChar(itemText), Length(itemText), TR, DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS); SetBkMode(Canvas.Handle, TRANSPARENT);
DrawText(Canvas.Handle, PChar(itemText), Length(itemText), TR, DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS);
SetBkMode(Canvas.Handle, OPAQUE);
if R.Right > 60 then if R.Right > 60 then
begin begin
if Expanded then if Expanded then
DoArrow(Canvas, sdDown, Point(R.Right - 13, R.Top + 20), selected) DoArrow(Canvas, sdDown, Point(R.Right - 13, R.Top + 20), selected)
else else
DoArrow(Canvas, sdRight, Point(R.Right - 10, R.Top + 18), selected); DoArrow(Canvas, sdRight, Point(R.Right - 10, R.Top + 18), selected);
end; end;
end; end;
end; end;
procedure TmbColorTree.DrawInfoItem(R: TRect; Index: integer); procedure TmbColorTree.DrawInfoItem(R: TRect; Index: integer);
@@ -683,4 +689,12 @@ if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then
inherited; inherited;
end; end;
{$IFDEF FPC}
procedure TmbColorTree.WMHScroll(var Msg: TLMScroll);
begin
inherited;
//Invalidate;
end;
{$ENDIF}
end. end.

865
components/mbColorLib/mbTrackBarPicker.pas
View File

File diff suppressed because it is too large Load Diff

6
components/mbColorLib/mbcolorliblaz.lpk
View File

@@ -15,7 +15,7 @@
<Description Value="Comprehensive color selection library with more than 30 components"/> <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."/> <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" Release="2"/>
<Files Count="43"> <Files Count="44">
<Item1> <Item1>
<Filename Value="PalUtils.pas"/> <Filename Value="PalUtils.pas"/>
<UnitName Value="PalUtils"/> <UnitName Value="PalUtils"/>
@@ -219,6 +219,10 @@
<HasRegisterProc Value="True"/> <HasRegisterProc Value="True"/>
<UnitName Value="HSLRingPicker"/> <UnitName Value="HSLRingPicker"/>
</Item43> </Item43>
<Item44>
<Filename Value="mbBasicPicker.pas"/>
<UnitName Value="mbBasicPicker"/>
</Item44>
</Files> </Files>
<RequiredPkgs Count="2"> <RequiredPkgs Count="2">
<Item1> <Item1>