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

311
components/mbColorLib/CColorPicker.pas
View File

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

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

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

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

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

284
components/mbColorLib/GColorPicker.pas
View File

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

275
components/mbColorLib/HColorPicker.pas
View File

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

153
components/mbColorLib/HRingPicker.pas
View File

@ -75,6 +75,9 @@ implementation
{$IFDEF FPC}
{$R HRingPicker.dcr}
uses
IntfGraphics, fpimage;
{$ENDIF}
procedure Register;
@ -116,49 +119,76 @@ end;
procedure THRingPicker.CreateHSVCircle;
var
dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer;
row: pRGBQuadArray;
tc: TColor;
dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer;
row: pRGBQuadArray;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin
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
if FBmp = nil then
begin
Y := Size - 1 - j - Radius;
row := FBMP.Scanline[Size - 1 - j];
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;
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
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;
procedure THRingPicker.Resize;
@ -267,26 +297,33 @@ end;
procedure THRingPicker.Paint;
var
rgn, r1, r2: HRGN;
r: TRect;
rgn, r1, r2: HRGN;
r: TRect;
size: Integer;
ringwidth: Integer;
begin
PaintParentBack(Canvas);
r := ClientRect;
r.Right := R.Left + Min(Width, Height);
R.Bottom := R.Top + Min(Width, Height);
r1 := CreateEllipticRgnIndirect(R);
rgn := r1;
InflateRect(R, - Min(Width, Height) + FRadius, - Min(Width, Height) + FRadius);
r2 := CreateEllipticRgnIndirect(R);
CombineRgn(rgn, r1, r2, RGN_DIFF);
SelectClipRgn(Canvas.Handle, rgn);
Canvas.Draw(0, 0, FBMP);
DeleteObject(rgn);
DrawHueLine;
if FDoChange then
PaintParentBack(Canvas);
size := Min(Width, Height); // diameter of circle
ringwidth := size div 2 - FRadius; // FRadius is inner radius
r := ClientRect;
r.Right := R.Left + size;
R.Bottom := R.Top + size;
r1 := CreateEllipticRgnIndirect(R);
if ringwidth > 0 then
begin
if Assigned(FOnChange) then FOnChange(Self);
FDoChange := false;
rgn := r1;
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;

43
components/mbColorLib/HSColorPicker.pas
View File

@ -10,10 +10,10 @@ uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
Windows, Messages, Scanlines,
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Math, Forms,
RGBHSLUtils, HTMLColors, SelPropUtils, mbColorPickerControl, Scanlines;
RGBHSLUtils, HTMLColors, SelPropUtils, mbColorPickerControl;
type
THSColorPicker = class(TmbColorPickerControl)
@ -66,6 +66,9 @@ implementation
{$IFDEF FPC}
{$R HSColorPicker.dcr}
uses
IntfGraphics, fpimage;
{$ENDIF}
procedure Register;
@ -109,6 +112,7 @@ begin
CreateHSLGradient;
end;
{$IFDEF DELPHI}
procedure THSColorPicker.CreateHSLGradient;
var
Hue, Sat : integer;
@ -133,6 +137,41 @@ begin
// FHSLBmp.Canvas.Pixels[Hue, 240 - Sat] := GetWebSafe(HSLRangeToRGB(Hue, Sat, 120));
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);
begin

148
components/mbColorLib/HSLColorPicker.pas
View File

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

71
components/mbColorLib/HSLRingPicker.pas
View File

@ -16,10 +16,10 @@ uses
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, Menus, Math,
{$IFDEF DELPHI_7_UP}Themes,{$ENDIF}
RGBHSLUtils, HRingPicker, SLColorPicker, HTMLColors;
RGBHSLUtils, HRingPicker, SLColorPicker, HTMLColors, mbBasicPicker;
type
THSLRingPicker = class(TCustomControl)
THSLRingPicker = class(TmbBasicPicker)
private
FOnChange: TNotifyEvent;
FRingPicker: THRingPicker;
@ -46,7 +46,6 @@ type
procedure SetRingMenu(m: TPopupMenu);
procedure SetRingCursor(c: TCursor);
procedure SetSLCursor(c: TCursor);
procedure PaintParentBack;
protected
procedure CreateWnd; override;
procedure Paint; override;
@ -56,10 +55,8 @@ type
procedure DoChange;
procedure Resize; override;
{$IFDEF DELPHI}
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
{$ELSE}
procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS;
{$ENDIF}
public
@ -123,7 +120,6 @@ begin
inherited;
ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}];
DoubleBuffered := true;
ParentColor := true;
PBack := TBitmap.Create;
PBack.PixelFormat := pf32bit;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
@ -143,6 +139,7 @@ begin
Width := 246;
Top := 0;
Left := 0;
Radius := 100;
Align := alClient;
Visible := true;
Saturation := 255;
@ -182,16 +179,33 @@ begin
end;
procedure THSLRingPicker.Resize;
var
circ: TPoint;
ctr: double;
begin
inherited;
if (FRingPicker = nil) or (FSLPicker = nil) then
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;
FSLPicker.Left := (21*FRingPicker.Radius) div 10;
FSLPicker.Top := (21*FRingPicker.Radius) div 10;
FSLPicker.Width := 4*FRingPicker.Radius;
FSLPicker.Height := 4*FRingPicker.Radius;
PaintParentBack;
*)
PaintParentBack(PBack);
end;
procedure THSLRingPicker.RingPickerChange(Sender: TObject);
@ -351,55 +365,16 @@ begin
Result := FRingPicker.Manual or FSLPicker.Manual;
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;
begin
PaintParentBack;
PaintParentBack(PBack);
Canvas.Draw(0, 0, PBack);
end;
procedure THSLRingPicker.CreateWnd;
begin
inherited;
PaintParentBack;
end;
procedure THSLRingPicker.WMEraseBkgnd(
var Message: {$IFDEF DELPHI}TWMEraseBkgnd{$ELSE}TLMEraseBkgnd{$ENDIF} );
begin
Message.Result := 1;
PaintParentBack(PBack);
end;
end.

103
components/mbColorLib/HSVColorPicker.pas
View File

@ -85,6 +85,9 @@ implementation
{$IFDEF FPC}
{$R HSVColorPicker.dcr}
uses
IntfGraphics, fpimage;
{$ENDIF}
procedure Register;
@ -153,51 +156,83 @@ end;
procedure THSVColorPicker.CreateHSVCircle;
var
dSquared, H, S, V, i, j, Radius, RadiusSquared, x, y, size: integer;
row: pRGBQuadArray;
tc: TColor;
dSquared, H, S, V, i, j, radius, radiusSquared, x, y, size: integer;
row: pRGBQuadArray;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin
if FHSVBmp = nil then
if FHSVBmp = nil then
begin
FHSVBmp := TBitmap.Create;
FHSVBmp.PixelFormat := pf32bit;
FHSVBmp := TBitmap.Create;
FHSVBmp.PixelFormat := pf32bit;
end;
size := Min(Width, Height);
FHSVBmp.Width := size;
FHSVBmp.Height := size;
Radius := size div 2;
RadiusSquared := Radius*Radius;
PaintParentBack(FHSVBmp.Canvas);
size := Min(Width, Height);
FHSVBmp.Width := size;
FHSVBmp.Height := size;
PaintParentBack(FHSVBmp.Canvas);
V := FValue;
for j := 0 to size-1 do
begin
Y := Size - 1 - j - Radius;
row := FHSVBmp.Scanline[Size - 1 - j];
for i := 0 to size-1 do
radius := size div 2;
radiusSquared := radius * radius;
V := FValue;
{$IFDEF FPC}
intfimg := TLazIntfImage.Create(FHSVBmp.Width, FHSVBmp.Height);
try
intfImg.LoadFromBitmap(FHSVBmp.Handle, FHSVBmp.MaskHandle);
{$ENDIF}
for j := 0 to size - 1 do
begin
X := i - Radius;
dSquared := X*X + Y*Y;
if dSquared <= RadiusSquared then
Y := size - 1 - j - Radius;
{$IFDEF FPC}
row := intfImg.GetDataLineStart(size - 1 - j);
{$ELSE}
row := FHSVBmp.Scanline(size - 1 - j);
{$ENDIF}
for i := 0 to size - 1 do
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
X := i - Radius;
dSquared := X*X + Y*Y;
if dSquared <= RadiusSquared then
begin
tc := GetWebSafe(HSVtoColor(H, S, V));
row[i] := RGBtoRGBQuad(GetRValue(tc), GetGValue(tc), GetBValue(tc));
if Radius <> 0 then
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;
{$IFDEF FPC}
intfimg.CreateBitmaps(imgHandle, imgMaskHandle, false);
FHSVBmp.Handle := imgHandle;
FHSVBmp.MaskHandle := imgMaskHandle;
finally
intfimg.Free;
end;
{$ENDIF}
end;
procedure THSVColorPicker.Resize;

83
components/mbColorLib/HexaColorPicker.pas
View File

@ -16,7 +16,7 @@ uses
{$ENDIF}
SysUtils, Classes, Controls, Graphics, StdCtrls, Forms,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, RGBHSLUtils, Math,
RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils;
RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, mbBasicPicker;
const
CustomCell = -2;
@ -43,7 +43,7 @@ type
TSelectionMode = (smNone, smColor, smBW, smRamp);
THexaColorPicker = class(TCustomControl)
THexaColorPicker = class(TmbBasicPicker)
private
FIncrement: integer;
FSelectedCombIndex: integer;
@ -60,7 +60,7 @@ type
FCenterColor: TRGBrec;
FCenterIntensity: Single;
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.
// Positive values indicate the color comb and negative values
// indicate the B&W combs (complement). This value is offset with
@ -84,7 +84,6 @@ type
procedure DrawAll;
procedure SetSelectedColor(const Value: TColor);
procedure DrawCombControls;
procedure PaintParentBack;
procedure DrawComb(Canvas: TCanvas; X, Y, Size: Integer);
procedure HandleCustomColors(var Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF});
procedure CalculateCombLayout;
@ -101,23 +100,25 @@ type
function GetNextCombIndex(i: integer): integer;
function GetPreviousCombIndex(i: integer): integer;
protected
procedure CreateWnd; override;
procedure Paint; override;
procedure Resize; override;
procedure WheelUp(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});
message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
procedure CNKeyDown(var Message: {$IFDEF FPC}TLMKeyDown{$ELSE}TWMKeyDown{$ENDIF});
message CN_KEYDOWN;
procedure CMHintShow(var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
message CM_HINTSHOW;
procedure WMLButtonDown(var Message: {$IFDEF FPC}TLMLButtonDown{$ELSE}TWMLButtonDown{$ENDIF});
message {$IFDEF FPC}LM_LBUTTONDOWN{$ELSE}WM_LBUTTONDOWN{$ENDIF};
procedure WMLButtonUp(var Message: {$IFDEF FPC}TLMLButtonUp{$ELSE}TWMLButtonUp{$ENDIF});
message {$IFDEF FPC}LM_LBUTTONUP{$ELSE}WM_LBUTTONUP{$ENDIF};
procedure WMMouseMove(var Message: {$IFDEF FPC}TLMMouseMove{$ELSE}TWMMouseMove{$ENDIF});
message {$IFDEF FPC}LM_MOUSEMOVE{$ELSE}WM_MOUSEMOVE{$ENDIF};
procedure Paint; override;
procedure CreateWnd; override;
procedure Resize; override;
{$IFDEF DELPHI}
procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
{$ELSE}
procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN;
procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW;
procedure WMLButtonDown(var Message: TLMLButtonDown); message LM_LBUTTONDOWN;
procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP;
procedure WMMouseMove(var Message: TLMMouseMove); message LM_MOUSEMOVE;
{$ENDIF}
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
@ -145,12 +146,12 @@ type
property Visible;
property Enabled;
property PopupMenu;
property ParentColor default true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
property ParentBackground default true;
{$ENDIF}{$ENDIF}
property TabOrder;
property Color;
property ParentColor;
property SliderWidth: integer read FSliderWidth write SetSliderWidth default 12;
property DragCursor;
property DragMode;
@ -214,7 +215,6 @@ begin
FRadius := 90;
FSliderWidth := 12;
DoubleBuffered := true;
ParentColor := true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF}{$ENDIF}
@ -453,47 +453,6 @@ begin
EnumerateCombs;
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;
begin
PaintParentBack;

313
components/mbColorLib/KColorPicker.pas
View File

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

281
components/mbColorLib/LColorPicker.pas
View File

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

307
components/mbColorLib/MColorPicker.pas
View File

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

221
components/mbColorLib/RColorPicker.pas
View File

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

50
components/mbColorLib/RGBHSLUtils.pas
View File

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

218
components/mbColorLib/SColorPicker.pas
View File

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

110
components/mbColorLib/SLColorPicker.pas
View File

@ -65,6 +65,9 @@ implementation
{$IFDEF FPC}
{$R SLColorPicker.dcr}
uses
IntfGraphics, fpimage;
{$ENDIF}
procedure Register;
@ -96,35 +99,98 @@ begin
inherited;
end;
//{$IFDEF DELPHI}
procedure TSLColorPicker.CreateSLGradient;
var
x, y, skip: integer;
row: pRGBQuadArray;
tc: TColor;
x, y, skip: integer;
row: pRGBQuadArray;
c: TColor;
{$IFDEF FPC}
intfimg: TLazIntfImage;
imgHandle, imgMaskHandle: HBitmap;
{$ENDIF}
begin
if FBMP = nil then
if FBmp = nil then
begin
FBMP := TBitmap.Create;
FBMP.PixelFormat := pf32bit;
FBMP.Width := 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);
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.Width := 256;
FBmp.Height := 256;
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;
(*
{$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;
begin
inherited;

176
components/mbColorLib/SLHColorPicker.pas
View File

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

51
components/mbColorLib/Scanlines.pas
View File

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

330
components/mbColorLib/VColorPicker.pas
View File

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

240
components/mbColorLib/YColorPicker.pas
View File

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

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

66
components/mbColorLib/mbColorPickerControl.pas
View File

@ -16,39 +16,37 @@ uses
{$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms,
{$IFDEF DELPHI_7_UP} Themes,{$ENDIF}
RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors;
RGBHSLUtils, RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, HTMLColors, mbBasicPicker;
type
TMarkerStyle = (msCircle, msSquare, msCross, msCrossCirc);
TmbCustomPicker = class(TCustomControl)
TmbCustomPicker = class(TmbBasicPicker)
private
FHintFormat: string;
FMarkerStyle: TMarkerStyle;
FWebSafe: boolean;
procedure SetMarkerStyle(s: TMarkerStyle);
procedure SetWebSafe(s: boolean);
protected
mx, my, mdx, mdy: integer;
function GetSelectedColor: TColor; virtual;
procedure SetSelectedColor(C: TColor); virtual;
procedure WebSafeChanged; dynamic;
procedure 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 MouseDown(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 CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
{$IFDEF DELPHI}
procedure CMGotFocus(var Message: TCMGotFocus); message CM_ENTER;
procedure CMLostFocus(var Message: TCMLostFocus); message CM_EXIT;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
{$ELSE}
procedure CMGotFocus(var Message: TLMessage); message CM_ENTER;
procedure CMLostFocus(var Message: TLMessage); message CM_EXIT;
procedure CMMouseLeave(var Message: TLMessage); message CM_MOUSELEAVE;
{$ENDIF}
property MarkerStyle: TMarkerStyle read FMarkerStyle write SetMarkerStyle;
public
constructor Create(AOwner: TComponent); override;
@ -112,7 +110,6 @@ begin
ControlStyle := ControlStyle + [csOpaque] - [csAcceptsControls];
DoubleBuffered := true;
TabStop := true;
ParentColor := true;
{$IFDEF DELPHI_7_UP}{$IFDEF DELPHI}
ParentBackground := true;
{$ENDIF}{$ENDIF}
@ -129,39 +126,6 @@ begin
inherited;
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(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TCMGotFocus{$ENDIF} );
begin
@ -176,12 +140,6 @@ begin
Invalidate;
end;
procedure TmbCustomPicker.WMEraseBkgnd(
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
begin
Message.Result := 1;
end;
procedure TmbCustomPicker.CMMouseLeave(
var Message: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
begin

88
components/mbColorLib/mbColorTree.pas
View File

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