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

mbColorLib: Apply standard code formatting

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5503 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2016-12-15 11:27:12 +00:00
parent 72c76eb6d6
commit 2c43f4222c
19 changed files with 2429 additions and 2463 deletions
Download Patch File Download Diff File Expand all files Collapse all files

176
components/mbColorLib/HTMLColors.pas
View File

@ -137,19 +137,19 @@ function GetWebSafe(C: TColor): TColor;
implementation implementation
var var
WS: array [0..255] of byte; WS: array [0..255] of byte;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
//checks membership of a string array //checks membership of a string array
function IsMember(a: array of string; n: integer; s: string): boolean; function IsMember(a: array of string; n: integer; s: string): boolean;
var var
i: integer; i: integer;
begin begin
Result := false; Result := false;
for i := 0 to n - 1 do for i := 0 to n - 1 do
if SameText(s, a[i]) then if SameText(s, a[i]) then
Result := true; Result := true;
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
@ -157,7 +157,7 @@ end;
//checks if the color's nam was used instead of hex //checks if the color's nam was used instead of hex
function IsSpecialColor(s: string): boolean; function IsSpecialColor(s: string): boolean;
begin begin
Result := IsMember(BASIC_NAMES, BASIC_COUNT, s) or IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) or IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s); Result := IsMember(BASIC_NAMES, BASIC_COUNT, s) or IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) or IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s);
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
@ -165,12 +165,12 @@ end;
//is hex was used then remove the wrong characters //is hex was used then remove the wrong characters
procedure MakeIntoHex(var s: string); procedure MakeIntoHex(var s: string);
var var
i: integer; i: integer;
begin begin
if s <> '' then if s <> '' then
for i := 1 to Length(s) do for i := 1 to Length(s) do
if not (s[i] in ['0'..'9', 'A'..'F', 'a'..'f']) then if not (s[i] in ['0'..'9', 'A'..'F', 'a'..'f']) then
s[i] := '0'; s[i] := '0';
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
@ -178,35 +178,35 @@ end;
//formats entered text into a true hex value //formats entered text into a true hex value
function FormatHexColor(S: string): string; function FormatHexColor(S: string): string;
var var
c: string; c: string;
i: integer; i: integer;
begin begin
c := ''; c := '';
if not IsSpecialColor(s) then if not IsSpecialColor(s) then
begin begin
if (s <> '') and (s[1] = '#') then if (s <> '') and (s[1] = '#') then
Delete(s, 1, 1); Delete(s, 1, 1);
if s <> '' then if s <> '' then
begin begin
MakeIntoHex(c); MakeIntoHex(c);
if Length(c) = 6 then if Length(c) = 6 then
Result := c Result := c
else else
begin begin
if Length(c) > 6 then if Length(c) > 6 then
c := Copy(c, 1, 6); c := Copy(c, 1, 6);
if Length(c) < 6 then if Length(c) < 6 then
for i := 0 to 6 - Length(c) - 1 do for i := 0 to 6 - Length(c) - 1 do
c := '0' + c; c := '0' + c;
Result := c; Result := c;
end; end;
end end
else else
Result := '000000'; Result := '000000';
end end
else else
Result := s; Result := s;
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
@ -214,16 +214,16 @@ end;
//gets a hex value from a color name from special colors //gets a hex value from a color name from special colors
function GetHexFromName(s: string): string; function GetHexFromName(s: string): string;
var var
i, k: integer; i, k: integer;
begin begin
k := 0; k := 0;
for i := 0 to SPECIAL_COUNT - 1 do for i := 0 to SPECIAL_COUNT - 1 do
if SameText(s, SPECIAL_NAMES[i]) then if SameText(s, SPECIAL_NAMES[i]) then
begin begin
k := i; k := i;
Break; Break;
end; end;
Result := SPECIAL_HEX[k]; Result := SPECIAL_HEX[k];
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
@ -231,33 +231,32 @@ end;
// gets a TColor value from a color name from basic or system colors // gets a TColor value from a color name from basic or system colors
function GetValueFromName(s: string): TColor; function GetValueFromName(s: string): TColor;
var var
i, k: integer; i, k: integer;
begin begin
k := 0; k := 0;
s := LowerCase(s); s := LowerCase(s);
if IsMember(BASIC_NAMES, BASIC_COUNT, s) then if IsMember(BASIC_NAMES, BASIC_COUNT, s) then
begin begin
for i := 0 to BASIC_COUNT - 1 do for i := 0 to BASIC_COUNT - 1 do
if SameText(s, BASIC_NAMES[i]) then if SameText(s, BASIC_NAMES[i]) then
begin
k := i;
Break;
end;
Result := BASIC_VALUES[k];
end
else
if IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s) then
begin
for i := 0 to SYSTEM_COUNT - 1 do
if SameText(s, SYSTEM_NAMES[i]) then
begin begin
k := i; k := i;
Break; Break;
end;
Result := BASIC_VALUES[k];
end
else if IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s) then
begin
for i := 0 to SYSTEM_COUNT - 1 do
if SameText(s, SYSTEM_NAMES[i]) then
begin
k := i;
Break;
end; end;
Result := SYSTEM_VALUES[k]; Result := SYSTEM_VALUES[k];
end end
else else
Result := clNone; Result := clNone;
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
@ -276,27 +275,26 @@ end;
//converts a hex value to a TColor //converts a hex value to a TColor
function HexToTColor(s: OleVariant): TColor; function HexToTColor(s: OleVariant): TColor;
begin begin
if s <> null then if s <> null then
begin begin
if not IsSpecialColor(s) then if not IsSpecialColor(s) then
begin begin
s := FormatHexColor(s); s := FormatHexColor(s);
if s <> '' then if s <> '' then
Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2))) Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2)))
else else
Result := clNone; Result := clNone;
end end
else else if IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) then
if IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) then begin
begin
s := GetHexFromName(s); s := GetHexFromName(s);
Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2))); Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2)));
end end
else else
Result := GetValueFromName(s); Result := GetValueFromName(s);
end end
else else
Result := clNone; Result := clNone;
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
@ -304,8 +302,8 @@ end;
//checks if a hex value belongs to the websafe palette //checks if a hex value belongs to the websafe palette
function IsWebSafe(s: string): boolean; function IsWebSafe(s: string): boolean;
begin begin
s := FormatHexColor(s); s := FormatHexColor(s);
Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s); Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s);
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
@ -313,34 +311,34 @@ end;
//checks if a color belongs to the websafe palette //checks if a color belongs to the websafe palette
function IsWebSafe(c: TColor): boolean; function IsWebSafe(c: TColor): boolean;
var var
s: string; s: string;
begin begin
s := ColorToHex(c); s := ColorToHex(c);
Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s); Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s);
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
//initializes the websafe comparison array //initializes the websafe comparison array
procedure InitializeWS; procedure InitializeWS;
var var
i: integer; i: integer;
begin begin
for i := 0 to 255 do for i := 0 to 255 do
WS[I] := ((i + $19) div $33) * $33; WS[I] := ((i + $19) div $33) * $33;
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
//returns the closest web safe color to the one given //returns the closest web safe color to the one given
function GetWebSafe(C: TColor): TColor; function GetWebSafe(C: TColor): TColor;
begin begin
Result := RGB(WS[GetRValue(C)], WS[GetGValue(C)], WS[GetBValue(C)]); Result := RGB(WS[GetRValue(C)], WS[GetGValue(C)], WS[GetBValue(C)]);
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
initialization initialization
InitializeWS; InitializeWS;
end. end.

328
components/mbColorLib/HexaColorPicker.pas
View File

@ -9,188 +9,186 @@ interface
{$I mxs.inc} {$I mxs.inc}
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, StdCtrls, Forms, SysUtils, Classes, Controls, Graphics, StdCtrls, Forms,
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, RGBHSLUtils, Math, {$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, RGBHSLUtils, Math,
RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, mbBasicPicker; RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, mbBasicPicker;
const const
CustomCell = -2; CustomCell = -2;
NoCell = -1; NoCell = -1;
type type
TMarker = (smArrow, smRect); TMarker = (smArrow, smRect);
TCombEntry = record TCombEntry = record
Position: TPoint; Position: TPoint;
Color: COLORREF; Color: COLORREF;
TabIndex: integer; TabIndex: integer;
end; end;
TCombArray = array of TCombEntry; TCombArray = array of TCombEntry;
TFloatPoint = record TFloatPoint = record
X, Y: Extended; X, Y: Extended;
end; end;
TRGBrec = record TRGBrec = record
Red, Green, Blue: Single; Red, Green, Blue: Single;
end; end;
TSelectionMode = (smNone, smColor, smBW, smRamp); TSelectionMode = (smNone, smColor, smBW, smRamp);
THexaColorPicker = class(TmbBasicPicker) THexaColorPicker = class(TmbBasicPicker)
private private
FIncrement: integer; FIncrement: integer;
FSelectedCombIndex: integer; FSelectedCombIndex: integer;
mX, mY: integer; mX, mY: integer;
FHintFormat: string; FHintFormat: string;
FUnderCursor: TColor; FUnderCursor: TColor;
FOnChange, FOnIntensityChange: TNotifyEvent; FOnChange, FOnIntensityChange: TNotifyEvent;
FCurrentColor: TColor; FCurrentColor: TColor;
FSelectedIndex: Integer; FSelectedIndex: Integer;
FColorCombRect, FBWCombRect, FSliderRect, FCustomColorRect: TRect; FColorCombRect, FBWCombRect, FSliderRect, FCustomColorRect: TRect;
FCombSize, FLevels: Integer; FCombSize, FLevels: Integer;
FBWCombs, FColorCombs: TCombArray; FBWCombs, FColorCombs: TCombArray;
FCombCorners: array[0..5] of TFloatPoint; FCombCorners: array[0..5] of TFloatPoint;
FCenterColor: TRGBrec; FCenterColor: TRGBrec;
FCenterIntensity: Single; FCenterIntensity: Single;
FSliderWidth: integer; FSliderWidth: integer;
FCustomIndex: Integer; // If FSelectedIndex contains CustomCell then this index shows FCustomIndex: Integer; // If FSelectedIndex contains CustomCell then this index shows
// which index in the custom area has been selected. // which index in the custom area has been selected.
// Positive values indicate the color comb and negative values // Positive values indicate the color comb and negative values
// indicate the B&W combs (complement). This value is offset with // indicate the B&W combs (complement). This value is offset with
// 1 to use index 0 to show no selection. // 1 to use index 0 to show no selection.
FRadius: Integer; FRadius: Integer;
FSelectionMode: TSelectionMode; FSelectionMode: TSelectionMode;
FSliderVisible: boolean; FSliderVisible: boolean;
FMarker: TMarker; FMarker: TMarker;
FNewArrowStyle: boolean; FNewArrowStyle: boolean;
FIntensityText: string; FIntensityText: string;
procedure SetNewArrowStyle(Value: boolean); procedure SetNewArrowStyle(Value: boolean);
procedure SetMarker(Value: TMarker); procedure SetMarker(Value: TMarker);
procedure SetSliderVisible(Value: boolean); procedure SetSliderVisible(Value: boolean);
procedure SetRadius(r: integer); procedure SetRadius(r: integer);
procedure SetSliderWidth(w: integer); procedure SetSliderWidth(w: integer);
procedure SetIntensity(v: integer); procedure SetIntensity(v: integer);
procedure ChangeIntensity(increase: boolean); procedure ChangeIntensity(increase: boolean);
procedure SelectColor(Color: TColor); procedure SelectColor(Color: TColor);
procedure Initialize; procedure Initialize;
procedure DrawAll; procedure DrawAll;
procedure SetSelectedColor(const Value: TColor); procedure SetSelectedColor(const Value: TColor);
procedure DrawCombControls; procedure DrawCombControls;
procedure DrawComb(Canvas: TCanvas; X, Y, Size: Integer); procedure DrawComb(Canvas: TCanvas; X, Y, Size: Integer);
procedure HandleCustomColors(var Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}); procedure HandleCustomColors(var Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF});
procedure CalculateCombLayout; procedure CalculateCombLayout;
procedure EndSelection; procedure EndSelection;
procedure EnumerateCombs; procedure EnumerateCombs;
function SelectAvailableColor(Color: TColor): boolean; function SelectAvailableColor(Color: TColor): boolean;
function GetIntensity: integer; function GetIntensity: integer;
function HandleBWArea(const Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}): Boolean; function HandleBWArea(const Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}): Boolean;
function HandleColorComb(const Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}): Boolean; function HandleColorComb(const Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}): Boolean;
function HandleSlider(const Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}): Boolean; function HandleSlider(const Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF}): Boolean;
function PtInComb(Comb: TCombEntry; P: TPoint; Scale: Integer): Boolean; function PtInComb(Comb: TCombEntry; P: TPoint; Scale: Integer): Boolean;
function FindBWArea(X, Y: Integer): Integer; function FindBWArea(X, Y: Integer): Integer;
function FindColorArea(X, Y: Integer): Integer; function FindColorArea(X, Y: Integer): Integer;
function GetNextCombIndex(i: integer): integer; function GetNextCombIndex(i: integer): integer;
function GetPreviousCombIndex(i: integer): integer; function GetPreviousCombIndex(i: integer): integer;
protected protected
procedure CreateWnd; override; procedure CreateWnd; override;
procedure Paint; override; procedure Paint; override;
procedure Resize; override; procedure Resize; override;
procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
{$IFDEF DELPHI} {$IFDEF DELPHI}
procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN; procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP; procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE; procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
{$ELSE} {$ELSE}
procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN; procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN;
procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW; procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW;
procedure WMLButtonDown(var Message: TLMLButtonDown); message LM_LBUTTONDOWN; procedure WMLButtonDown(var Message: TLMLButtonDown); message LM_LBUTTONDOWN;
procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP; procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP;
procedure WMMouseMove(var Message: TLMMouseMove); message LM_MOUSEMOVE; procedure WMMouseMove(var Message: TLMMouseMove); message LM_MOUSEMOVE;
{$ENDIF} {$ENDIF}
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; destructor Destroy; override;
procedure SelectCombIndex(i: integer);
function GetSelectedCombIndex: integer;
function GetColorUnderCursor: TColor;
function GetHexColorUnderCursor: string;
function GetColorAtPoint(X, Y: integer): TColor;
function GetHexColorAtPoint(X, Y: integer): string;
property ColorUnderCursor: TColor read GetColorUnderCursor;
published
property Align;
property Anchors;
property HintFormat: string read FHintFormat write FHintFormat;
property SelectedColor: TColor read FCurrentColor write SetSelectedColor default clBlack;
property Intensity: integer read GetIntensity write SetIntensity default 100;
property IntensityIncrement: integer read FIncrement write FIncrement default 1;
property SliderVisible: boolean read FSliderVisible write SetSliderVisible default true;
property SliderMarker: TMarker read FMarker write SetMarker default smArrow;
property NewArrowStyle: boolean read FNewArrowStyle write SetNewArrowStyle default false;
property IntensityText: string read FIntensityText write FIntensityText;
property ShowHint default true;
property TabStop default true;
property Visible;
property Enabled;
property PopupMenu;
{$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;
property DragKind;
property Constraints;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnIntensityChange: TNotifyEvent read FOnIntensityChange write FOnIntensityChange;
property OnDblClick;
property OnContextPopup;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelUp;
property OnMouseWheelDown;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnResize;
property OnStartDrag;
end;
procedure SelectCombIndex(i: integer); const
function GetSelectedCombIndex: integer; DefCenterColor: TRGBrec =(Red: 1; Green: 1; Blue: 1); // White
function GetColorUnderCursor: TColor; DefColors: array[0..5] of TRGBrec = (
function GetHexColorUnderCursor: string; (Red: 1; Green: 0; Blue: 1), // Magenta
function GetColorAtPoint(X, Y: integer): TColor; (Red: 1; Green: 0; Blue: 0), // Red
function GetHexColorAtPoint(X, Y: integer): string; (Red: 1; Green: 1; Blue: 0), // Yellow
property ColorUnderCursor: TColor read GetColorUnderCursor; (Red: 0; Green: 1; Blue: 0), // Green
published (Red: 0; Green: 1; Blue: 1), // Cyan
property Align; (Red: 0; Green: 0; Blue: 1) // Blue
property Anchors; );
property HintFormat: string read FHintFormat write FHintFormat; DefCenter: TFloatPoint = (X: 0; Y: 0);
property SelectedColor: TColor read FCurrentColor write SetSelectedColor default clBlack;
property Intensity: integer read GetIntensity write SetIntensity default 100;
property IntensityIncrement: integer read FIncrement write FIncrement default 1;
property SliderVisible: boolean read FSliderVisible write SetSliderVisible default true;
property SliderMarker: TMarker read FMarker write SetMarker default smArrow;
property NewArrowStyle: boolean read FNewArrowStyle write SetNewArrowStyle default false;
property IntensityText: string read FIntensityText write FIntensityText;
property ShowHint default true;
property TabStop default true;
property Visible;
property Enabled;
property PopupMenu;
{$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;
property DragKind;
property Constraints;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnIntensityChange: TNotifyEvent read FOnIntensityChange write FOnIntensityChange;
property OnDblClick;
property OnContextPopup;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelUp;
property OnMouseWheelDown;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnResize;
property OnStartDrag;
end;
const
DefCenterColor: TRGBrec =(Red: 1; Green: 1; Blue: 1); // White
DefColors: array[0..5] of TRGBrec = (
(Red: 1; Green: 0; Blue: 1), // Magenta
(Red: 1; Green: 0; Blue: 0), // Red
(Red: 1; Green: 1; Blue: 0), // Yellow
(Red: 0; Green: 1; Blue: 0), // Green
(Red: 0; Green: 1; Blue: 1), // Cyan
(Red: 0; Green: 0; Blue: 1) // Blue
);
DefCenter: TFloatPoint = (X: 0; Y: 0);
implementation implementation

995
components/mbColorLib/PalUtils.pas
View File

File diff suppressed because it is too large Load Diff

64
components/mbColorLib/RColorPicker.pas
View File

@ -7,42 +7,42 @@ unit RColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
mbTrackBarPicker, HTMLColors, Scanlines; mbTrackBarPicker, HTMLColors, Scanlines;
type type
{ TRColorPicker } { TRColorPicker }
TRColorPicker = class(TmbTrackBarPicker) TRColorPicker = class(TmbTrackBarPicker)
private private
FRed, FGreen, FBlue: integer; FRed, FGreen, FBlue: integer;
function ArrowPosFromRed(r: integer): integer; function ArrowPosFromRed(r: integer): integer;
function RedFromArrowPos(p: integer): integer; function RedFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor; function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor); procedure SetSelectedColor(c: TColor);
procedure SetRed(r: integer); procedure SetRed(r: integer);
procedure SetGreen(g: integer); procedure SetGreen(g: integer);
procedure SetBlue(b: integer); procedure SetBlue(b: integer);
protected protected
procedure Execute(tbaAction: integer); override; procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override; function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; override; function GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override; function GetSelectedValue: integer; override;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
published published
property Red: integer read FRed write SetRed default 255; property Red: integer read FRed write SetRed default 255;
property Green: integer read FGreen write SetGreen default 122; property Green: integer read FGreen write SetGreen default 122;
property Blue: integer read FBlue write SetBlue default 122; property Blue: integer read FBlue write SetBlue default 122;
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property Layout default lyVertical; property Layout default lyVertical;
end; end;
implementation implementation

437
components/mbColorLib/RGBCIEUtils.pas
View File

@ -8,315 +8,312 @@ uses
Graphics, Math; Graphics, Math;
const const
{// Observer= 2�, Illuminant= D65 - Daylignt {// Observer= 2�, Illuminant= D65 - Daylignt
ref_X = 95.047; ref_X = 95.047;
ref_Z = 108.883; ref_Z = 108.883;
// Observer= 10�, Illuminant= D65 - Daylight // Observer= 10�, Illuminant= D65 - Daylight
ref_X = 94.811; ref_X = 94.811;
ref_Z = 35.2; ref_Z = 35.2;
// Observer= 2�, Illuminant= A - Incadescent // Observer= 2�, Illuminant= A - Incadescent
ref_X = 109.850; ref_X = 109.850;
ref_Z = 35.585; ref_Z = 35.585;
// Observer= 10�, Illuminant= A - Incadescent // Observer= 10�, Illuminant= A - Incadescent
ref_X = 111.144; ref_X = 111.144;
ref_Z = 35.2; ref_Z = 35.2;
// Observer= 2�, Illuminant= C // Observer= 2�, Illuminant= C
ref_X = 98.074; ref_X = 98.074;
ref_Z = 118.232; ref_Z = 118.232;
// Observer= 10�, Illuminant= C // Observer= 10�, Illuminant= C
ref_X = 97.285; ref_X = 97.285;
ref_Z = 116.145; ref_Z = 116.145;
} }
// Observer= 2�, Illuminant= D50 // Observer= 2�, Illuminant= D50
ref_X = 96.422; ref_X = 96.422;
ref_Z = 82.521;{ ref_Z = 82.521;{
// Observer= 10�, Illuminant= D50 - Photoshop // Observer= 10�, Illuminant= D50 - Photoshop
ref_X = 96.72; ref_X = 96.72;
ref_Z = 81.427; } ref_Z = 81.427; }
{// Observer= 2�, Illuminant= D55 {// Observer= 2�, Illuminant= D55
ref_X = 95.682; ref_X = 95.682;
ref_Z = 92.149; ref_Z = 92.149;
// Observer= 10�, Illuminant= D55 // Observer= 10�, Illuminant= D55
ref_X = 95.799; ref_X = 95.799;
ref_Z = 90.926; ref_Z = 90.926;
// Observer= 2�, Illuminant= D75 // Observer= 2�, Illuminant= D75
ref_X = 94.972; ref_X = 94.972;
ref_Z = 122.638; ref_Z = 122.638;
// Observer= 10�, Illuminant= D75 // Observer= 10�, Illuminant= D75
ref_X = 94.416; ref_X = 94.416;
ref_Z = 12.641; ref_Z = 12.641;
// Observer= 2�, Illuminant= F2 - Fluorescent // Observer= 2�, Illuminant= F2 - Fluorescent
ref_X = 99.187; ref_X = 99.187;
ref_Z = 67.395; ref_Z = 67.395;
// Observer= 10�, Illuminant= F2 - Fluorescent // Observer= 10�, Illuminant= F2 - Fluorescent
ref_X = 103.28; ref_X = 103.28;
ref_Z = 69.026; ref_Z = 69.026;
// Observer= 2�, Illuminant= F7 // Observer= 2�, Illuminant= F7
ref_X = 95.044; ref_X = 95.044;
ref_Z = 108.755; ref_Z = 108.755;
// Observer= 10�, Illuminant= F7 // Observer= 10�, Illuminant= F7
ref_X = 95.792; ref_X = 95.792;
ref_Z = 107.678; ref_Z = 107.678;
// Observer= 2�, Illuminant= F11 // Observer= 2�, Illuminant= F11
ref_X = 100.966; ref_X = 100.966;
ref_Z = 64.370; ref_Z = 64.370;
// Observer= 10�, Illuminant= F11 // Observer= 10�, Illuminant= F11
ref_X = 103.866; ref_X = 103.866;
ref_Z = 65.627; } ref_Z = 65.627; }
type type
xyz = record xyz = record
x: real; x: Double;
y: real; y: Double;
z: real; z: Double;
end; end;
function LabToXYZ(l, a, b: real): xyz; function LabToXYZ(l, a, b: double): xyz;
function XYZToRGB(space: xyz): TColor; function XYZToRGB(space: xyz): TColor;
function LabToRGB(l, a, b: real): TColor; function LabToRGB(l, a, b: double): TColor;
function RGBToXYZ(c: TColor): xyz; function RGBToXYZ(c: TColor): xyz;
procedure RGBToLab(clr: TColor; var l, a, b: real); procedure RGBToLab(clr: TColor; var l, a, b: double);
procedure XYZToLab(space: xyz; var l, a, b: real); procedure XYZToLab(space: xyz; var l, a, b: double);
procedure LCHToLab(lum, c, h: real; var l, a, b: real); procedure LCHToLab(lum, c, h: double; var l, a, b: double);
procedure LabToLCH(l, a, b: real; var lum, c, h: real); procedure LabToLCH(l, a, b: double; var lum, c, h: double);
function LCHToRGB(l, c, h: real): TColor; function LCHToRGB(l, c, h: double): TColor;
procedure RGBToLCH(clr: TColor; var l, c, h: real); procedure RGBToLCH(clr: TColor; var l, c, h: double);
function GetCIEXValue(c: TColor): real; function GetCIEXValue(c: TColor): double;
function GetCIEYValue(c: TColor): real; function GetCIEYValue(c: TColor): double;
function GetCIEZValue(c: TColor): real; function GetCIEZValue(c: TColor): double;
function GetCIELValue(c: TColor): real; function GetCIELValue(c: TColor): double;
function GetCIEAValue(c: TColor): real; function GetCIEAValue(c: TColor): double;
function GetCIEBValue(c: TColor): real; function GetCIEBValue(c: TColor): double;
function GetCIECValue(c: TColor): real; function GetCIECValue(c: TColor): double;
function GetCIEHValue(c: TColor): real; function GetCIEHValue(c: TColor): double;
implementation implementation
function LabToXYZ(l, a, b: real): xyz; uses
mbUtils;
function LabToXYZ(l, a, b: double): xyz;
var var
x, y, z: real; x, y, z: double;
begin begin
y := (l + 16)/116; y := (l + 16)/116;
x := a/500 + y; x := a/500 + y;
z := y - b/200; z := y - b/200;
if y > 0.2069 then if y > 0.2069 then
y := IntPower(y, 3) y := IntPower(y, 3)
else else
y := (y - 0.138)/7.787; y := (y - 0.138)/7.787;
if x > 0.2069 then if x > 0.2069 then
x := IntPower(x, 3) x := IntPower(x, 3)
else else
x := (x - 0.138)/7.787; x := (x - 0.138)/7.787;
if z > 0.2069 then if z > 0.2069 then
z := IntPower(z, 3) z := IntPower(z, 3)
else else
z := (z - 0.138)/7.787; z := (z - 0.138)/7.787;
Result.x := ref_X * x; Result.x := ref_X * x;
Result.y := 100 * y; Result.y := 100 * y;
Result.z := ref_Z * z; Result.z := ref_Z * z;
end; end;
function XYZToRGB(space: xyz): TColor; function XYZToRGB(space: xyz): TColor;
var var
r, g, b, x, y, z: real; r, g, b, x, y, z: double;
begin begin
x := space.x/100; x := space.x/100;
y := space.y/100; y := space.y/100;
z := space.z/100; z := space.z/100;
r := x * 3.2406 + y * (-1.5372) + z * (-0.49); r := x * 3.2406 + y * (-1.5372) + z * (-0.49);
g := x * (-0.969) + y * 1.8758 + z * 0.0415; g := x * (-0.969) + y * 1.8758 + z * 0.0415;
b := x * 0.0557 + y * (-0.2040) + z * 1.0570; b := x * 0.0557 + y * (-0.2040) + z * 1.0570;
if r > 0.00313 then if r > 0.00313 then
r := 1.055 * Power(r, 1/2.4) - 0.055 r := 1.055 * Power(r, 1/2.4) - 0.055
else else
r := 12.92 * r; r := 12.92 * r;
if g > 0.00313 then if g > 0.00313 then
g := 1.055 * Power(g, 1/2.4) - 0.055 g := 1.055 * Power(g, 1/2.4) - 0.055
else else
g := 12.92 * g; g := 12.92 * g;
if b > 0.00313 then if b > 0.00313 then
b := 1.055 * Power(b, 1/2.4) - 0.055 b := 1.055 * Power(b, 1/2.4) - 0.055
else else
b := 12.92 * b; b := 12.92 * b;
if r < 0 then r := 0; Clamp(r, 0, 1);
if r > 1 then r := 1; Clamp(g, 0, 1);
if g < 0 then g := 0; Clamp(b, 0, 1);
if g > 1 then g := 1; Result := RGB(Round(r*255), Round(g*255), Round(b*255));
if b < 0 then b := 0;
if b > 1 then b := 1;
Result := RGB(Round(r*255), Round(g*255), Round(b*255));
end; end;
function LabToRGB(l, a, b: real): TColor; function LabToRGB(l, a, b: double): TColor;
begin begin
Result := XYZToRGB(LabToXYZ(l, a, b)); Result := XYZToRGB(LabToXYZ(l, a, b));
end; end;
function RGBToXYZ(c: TColor): xyz; function RGBToXYZ(c: TColor): xyz;
var var
r, g, b: real; r, g, b: double;
begin begin
r := GetRValue(c)/255; r := GetRValue(c)/255;
g := GetGValue(c)/255; g := GetGValue(c)/255;
b := GetBValue(c)/255; b := GetBValue(c)/255;
if r > 0.04045 then if r > 0.04045 then
r := Power((r + 0.055)/1.055, 2.4) r := Power((r + 0.055)/1.055, 2.4)
else else
r := r/12.92; r := r/12.92;
if g > 0.04045 then if g > 0.04045 then
g := Power((g + 0.055)/1.055, 2.4) g := Power((g + 0.055)/1.055, 2.4)
else else
g := g/12.92; g := g/12.92;
if b > 0.04045 then if b > 0.04045 then
b := Power((b + 0.055)/1.055, 2.4) b := Power((b + 0.055)/1.055, 2.4)
else else
b := b/12.92; b := b/12.92;
r := r * 100; r := r * 100;
g := g * 100; g := g * 100;
b := b * 100; b := b * 100;
// Observer= 2�, Illuminant= D65 // Observer= 2�, Illuminant= D65
Result.x := r * 0.4124 + g * 0.3576 + b * 0.1805; Result.x := r * 0.4124 + g * 0.3576 + b * 0.1805;
Result.y := r * 0.2126 + g * 0.7152 + b * 0.0722; Result.y := r * 0.2126 + g * 0.7152 + b * 0.0722;
Result.z := r * 0.0193 + g * 0.1192 + b * 0.9505; Result.z := r * 0.0193 + g * 0.1192 + b * 0.9505;
end; end;
procedure XYZToLab(space: xyz; var l, a, b: real); procedure XYZToLab(space: xyz; var l, a, b: Double);
var var
x, y, z: real; x, y, z: double;
begin begin
x := space.x/ref_X; x := space.x/ref_X;
y := space.y/100; y := space.y/100;
z := space.z/ref_Z; z := space.z/ref_Z;
if x > 0.008856 then if x > 0.008856 then
x := Power(x, 1/3) x := Power(x, 1/3)
else else
x := (7.787*x) + 0.138; x := (7.787*x) + 0.138;
if y > 0.008856 then if y > 0.008856 then
y := Power(y, 1/3) y := Power(y, 1/3)
else else
y := (7.787*y) + 0.138; y := (7.787*y) + 0.138;
if z > 0.008856 then if z > 0.008856 then
z := Power(z, 1/3) z := Power(z, 1/3)
else else
z := (7.787*z) + 0.138; z := (7.787*z) + 0.138;
l := (116*y) - 16; l := (116*y) - 16;
a := 500 * (x - y); a := 500 * (x - y);
b := 200 * (y - z); b := 200 * (y - z);
if l > 100 then l := 100; Clamp(l, 0, 100);
if l < 0 then l := 0; Clamp(a, -128, 127);
if a < -128 then a := -128; Clamp(b, -128, 127);
if a > 127 then a := 127;
if b < -128 then b := -128;
if b > 127 then b := 127;
end; end;
procedure RGBToLab(clr: TColor; var l, a, b: real); procedure RGBToLab(clr: TColor; var l, a, b: Double);
var var
s: xyz; s: xyz;
begin begin
s := RGBToXYZ(clr); s := RGBToXYZ(clr);
XYZToLab(s, l, a, b); XYZToLab(s, l, a, b);
end; end;
procedure LCHToLab(lum, c, h: real; var l, a, b: real); procedure LCHToLab(lum, c, h: double; var l, a, b: double);
begin begin
l := lum; l := lum;
a := cos(DegToRad(h)) * c; a := cos(DegToRad(h)) * c;
b := sin(DegToRad(h)) * c; b := sin(DegToRad(h)) * c;
end; end;
procedure LabToLCH(l, a, b: real; var lum, c, h: real); procedure LabToLCH(l, a, b: double; var lum, c, h: double);
begin begin
h := ArcTan2(b, a); h := ArcTan2(b, a);
if h > 0 then if h > 0 then
h := (h/PI) * 180 h := (h/pi) * 180
else else
h := 360 - (ABS(h)/PI) * 180; h := 360 - (abs(h)/pi) * 180;
lum := l; lum := l;
c := SQRT(a*a + b*b); c := SQRT(a*a + b*b);
end; end;
procedure RGBToLCH(clr: TColor; var l, c, h: real); procedure RGBToLCH(clr: TColor; var l, c, h: double);
var var
a, b: real; a, b: double;
begin begin
RGBToLab(clr, l, a, b); RGBToLab(clr, l, a, b);
LabToLCH(l, a, b, l, c, h); LabToLCH(l, a, b, l, c, h);
end; end;
function LCHToRGB(l, c, h: real): TColor; function LCHToRGB(l, c, h: double): TColor;
var var
lum, a, b: real; lum, a, b: double;
begin begin
LCHToLab(l, c, h, lum, a, b); LCHToLab(l, c, h, lum, a, b);
Result := LabToRGB(lum, a, b); Result := LabToRGB(lum, a, b);
end; end;
function GetCIEXValue(c: TColor): real; function GetCIEXValue(c: TColor): double;
var var
d: xyz; d: xyz;
begin begin
d := RGBToXYZ(c); d := RGBToXYZ(c);
Result := d.x; Result := d.x;
end; end;
function GetCIEYValue(c: TColor): real; function GetCIEYValue(c: TColor): double;
var var
d: xyz; d: xyz;
begin begin
d := RGBToXYZ(c); d := RGBToXYZ(c);
Result := d.y; Result := d.y;
end; end;
function GetCIEZValue(c: TColor): real; function GetCIEZValue(c: TColor): double;
var var
d: xyz; d: xyz;
begin begin
d := RGBToXYZ(c); d := RGBToXYZ(c);
Result := d.z; Result := d.z;
end; end;
function GetCIELValue(c: TColor): real; function GetCIELValue(c: TColor): double;
var var
d: real; d: real;
begin begin
XYZToLab(RGBToXYZ(c), Result, d, d); XYZToLab(RGBToXYZ(c), Result, d, d);
end; end;
function GetCIEAValue(c: TColor): real; function GetCIEAValue(c: TColor): double;
var var
d: real; d: double;
begin begin
XYZToLab(RGBToXYZ(c), d, Result, d); XYZToLab(RGBToXYZ(c), d, Result, d);
end; end;
function GetCIEBValue(c: TColor): real; function GetCIEBValue(c: TColor): double;
var var
d: real; d: double;
begin begin
XYZToLab(RGBToXYZ(c), d, d, Result); XYZToLab(RGBToXYZ(c), d, d, Result);
end; end;
function GetCIECValue(c: TColor): real; function GetCIECValue(c: TColor): double;
var var
d: real; d: double;
begin begin
RGBToLCH(c, d, Result, d); RGBToLCH(c, d, Result, d);
end; end;
function GetCIEHValue(c: TColor): real; function GetCIEHValue(c: TColor): double;
var var
d: real; d: double;
begin begin
RGBToLCH(c, d, d, Result); RGBToLCH(c, d, d, Result);
end; end;
end. end.

40
components/mbColorLib/RGBCMYKUtils.pas
View File

@ -19,58 +19,58 @@ implementation
function CMYtoTColor(C, M, Y: integer): TColor; function CMYtoTColor(C, M, Y: integer): TColor;
begin begin
Result := RGB(255 - C, 255 - M, 255 - Y); Result := RGB(255 - C, 255 - M, 255 - Y);
end; end;
procedure RGBtoCMY(clr: TColor; var C, M, Y: integer); procedure RGBtoCMY(clr: TColor; var C, M, Y: integer);
begin begin
C := 255 - GetRValue(clr); C := 255 - GetRValue(clr);
M := 255 - GetGValue(clr); M := 255 - GetGValue(clr);
Y := 255 - GetBValue(clr); Y := 255 - GetBValue(clr);
end; end;
function CMYKToTColor (C, M, Y, K: integer): TColor; function CMYKToTColor (C, M, Y, K: integer): TColor;
begin begin
Result := RGB(255 - (C + K), 255 - (M + K), 255 - (Y + K)); Result := RGB(255 - (C + K), 255 - (M + K), 255 - (Y + K));
end; end;
procedure ColorToCMYK(clr: TColor; var C, M, Y, K: integer); procedure ColorToCMYK(clr: TColor; var C, M, Y, K: integer);
begin begin
C := 255 - GetRValue(clr); C := 255 - GetRValue(clr);
M := 255 - GetGValue(clr); M := 255 - GetGValue(clr);
Y := 255 - GetBValue(clr); Y := 255 - GetBValue(clr);
K := MinIntValue([C, M, Y]); K := MinIntValue([C, M, Y]);
C := C - K; C := C - K;
M := M - K; M := M - K;
Y := Y - K; Y := Y - K;
end; end;
function GetCValue(c: TColor): integer; function GetCValue(c: TColor): integer;
var var
d: integer; d: integer;
begin begin
ColorToCMYK(c, Result, d, d, d); ColorToCMYK(c, Result, d, d, d);
end; end;
function GetMValue(c: TColor): integer; function GetMValue(c: TColor): integer;
var var
d: integer; d: integer;
begin begin
ColorToCMYK(c, d, Result, d, d); ColorToCMYK(c, d, Result, d, d);
end; end;
function GetYValue(c: TColor): integer; function GetYValue(c: TColor): integer;
var var
d: integer; d: integer;
begin begin
ColorToCMYK(c, d, d, Result, d); ColorToCMYK(c, d, d, Result, d);
end; end;
function GetKValue(c: TColor): integer; function GetKValue(c: TColor): integer;
var var
d: integer; d: integer;
begin begin
ColorToCMYK(c, d, d, d, Result); ColorToCMYK(c, d, d, d, Result);
end; end;
end. end.

238
components/mbColorLib/RGBHSLUtils.pas
View File

@ -7,17 +7,17 @@ unit RGBHSLUtils;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LCLIntf, LCLType,
{$ELSE} {$ELSE}
Windows, Windows,
{$ENDIF} {$ENDIF}
Graphics, Math, Scanlines; Graphics, Math, Scanlines;
var //set these variables to your needs, e.g. 360, 255, 255 var //set these variables to your needs, e.g. 360, 255, 255
MaxHue: integer = 359; //239; MaxHue: integer = 359; //239;
MaxSat: integer = 100; //240; MaxSat: integer = 100; //240;
MaxLum: integer = 100; //240; MaxLum: integer = 100; //240;
function HSLtoRGB (H, S, L: double): TColor; function HSLtoRGB (H, S, L: double): TColor;
function HSLRangeToRGB (H, S, L: integer): TColor; function HSLRangeToRGB (H, S, L: integer): TColor;
@ -33,138 +33,127 @@ procedure RGBTripleToHSL(RGBTriple : TRGBTriple; var h, s, l: integer);
implementation implementation
uses uses
mbUtils; mbUtils;
function HSLtoRGB(H, S, L: double): TColor; function HSLtoRGB(H, S, L: double): TColor;
var var
M1, M2: double; M1, M2: double;
function HueToColorValue(Hue: double): byte; function HueToColorValue(Hue: double): byte;
var var
V : double; V : double;
begin begin
if Hue < 0 then if Hue < 0 then
Hue := Hue + 1 Hue := Hue + 1
else else if Hue > 1 then
if Hue > 1 then Hue := Hue - 1;
Hue := Hue - 1; if 6 * Hue < 1 then
if 6 * Hue < 1 then V := M1 + (M2 - M1) * Hue * 6
V := M1 + (M2 - M1) * Hue * 6 else if 2 * Hue < 1 then
else V := M2
if 2 * Hue < 1 then else if 3 * Hue < 2 then
V := M2
else
if 3 * Hue < 2 then
V := M1 + (M2 - M1) * (2/3 - Hue) * 6 V := M1 + (M2 - M1) * (2/3 - Hue) * 6
else else
V := M1; V := M1;
Result := round (255 * V) Result := round (255 * V)
end; end;
var var
R, G, B: byte; R, G, B: byte;
begin begin
if S = 0 then if S = 0 then
begin begin
R := round (MaxLum * L); R := round(MaxLum * L);
G := R; G := R;
B := R B := R
end end
else else
begin begin
if L <= 0.5 then if L <= 0.5 then
M2 := L * (1 + S) M2 := L * (1 + S)
else else
M2 := L + S - L * S; M2 := L + S - L * S;
M1 := 2 * L - M2; M1 := 2 * L - M2;
R := HueToColorValue (H + 1/3); R := HueToColorValue(H + 1/3);
G := HueToColorValue (H); G := HueToColorValue(H);
B := HueToColorValue (H - 1/3) B := HueToColorValue(H - 1/3)
end; end;
Result := RGB (R, G, B) Result := RGB(R, G, B)
end; end;
function HSLRangeToRGB(H, S, L : integer): TColor; function HSLRangeToRGB(H, S, L: integer): TColor;
begin begin
if s > MaxSat then s := MaxSat; Clamp(H, 0, MaxHue);
if s < 0 then s := 0; Clamp(S, 0, MaxSat);
if l > MaxLum then l := MaxLum; Clamp(L, 0, MaxLum);
if l < 0 then l := 0; Result := HSLToRGB(H / MaxHue, S / MaxSat, L / MaxLum);
Result := HSLToRGB(H / MaxHue, S / MaxSat, L / MaxLum);
end; end;
procedure RGBtoHSLRange(RGB: TColor; var H1, S1, L1 : integer); procedure RGBtoHSLRange(RGB: TColor; var H1, S1, L1: integer);
var var
R, G, B, D, Cmax, Cmin, h, s, l: double; R, G, B, D, Cmax, Cmin, h, s, l: double;
begin begin
H := h1; H := h1;
S := s1; S := s1;
L := l1; L := l1;
R := GetRValue (RGB) / 255; R := GetRValue(RGB) / 255;
G := GetGValue (RGB) / 255; G := GetGValue(RGB) / 255;
B := GetBValue (RGB) / 255; B := GetBValue(RGB) / 255;
Cmax := Max (R, Max (G, B)); Cmax := Max(R, Max (G, B));
Cmin := Min (R, Min (G, B)); Cmin := Min(R, Min (G, B));
L := (Cmax + Cmin) / 2; L := (Cmax + Cmin) / 2;
if Cmax = Cmin then if Cmax = Cmin then
begin begin
H := 0; H := 0;
S := 0; S := 0;
end end
else else
begin begin
D := Cmax - Cmin; D := Cmax - Cmin;
//calc L //calc L
if L < 0.5 then if L < 0.5 then
S := D / (Cmax + Cmin) S := D / (Cmax + Cmin)
else
S := D / (2 - Cmax - Cmin);
//calc H
if R = Cmax then
H := (G - B) / D
else
if G = Cmax then
H := 2 + (B - R) /D
else else
H := 4 + (R - G) / D; S := D / (2 - Cmax - Cmin);
H := H / 6; //calc H
if H < 0 then if R = Cmax then
H := H + 1; H := (G - B) / D
else if G = Cmax then
H := 2 + (B - R) /D
else
H := 4 + (R - G) / D;
H := H / 6;
if H < 0 then
H := H + 1;
end; end;
H1 := round (H * MaxHue); H1 := round(H * MaxHue);
S1 := round (S * MaxSat); S1 := round(S * MaxSat);
L1 := round (L * MaxLum); L1 := round(L * MaxLum);
end; end;
function GetHValue(AColor: TColor): integer; function GetHValue(AColor: TColor): integer;
var var
d, h: integer; d, h: integer;
begin begin
RGBToHSLRange(AColor, h, d, d); RGBToHSLRange(AColor, h, d, d);
Result := h; Result := h;
end; end;
function GetSValue(AColor: TColor): integer; function GetSValue(AColor: TColor): integer;
var var
d, s: integer; d, s: integer;
begin begin
RGBToHSLRange(AColor, d, s, d); RGBToHSLRange(AColor, d, s, d);
Result := s; Result := s;
end; end;
function GetLValue(AColor: TColor): integer; function GetLValue(AColor: TColor): integer;
var var
d, l: integer; d, l: integer;
begin begin
RGBToHSLRange(AColor, d, d, l); RGBToHSLRange(AColor, d, d, l);
Result := l; Result := l;
end; end;
{
procedure Clamp(var Input: integer; Min, Max: integer);
begin
if (Input < Min) then Input := Min;
if (Input > Max) then Input := Max;
end; }
function HSLToRGBTriple(H, S, L: integer): TRGBTriple; function HSLToRGBTriple(H, S, L: integer): TRGBTriple;
const const
@ -234,44 +223,43 @@ end;
procedure RGBTripleToHSL(RGBTriple: TRGBTriple; var h, s, l: integer); procedure RGBTripleToHSL(RGBTriple: TRGBTriple; var h, s, l: integer);
function RGBMaxValue(RGB: TRGBTriple): byte; function RGBMaxValue(RGB: TRGBTriple): byte;
begin begin
Result := RGB.rgbtRed; Result := RGB.rgbtRed;
if (Result < RGB.rgbtGreen) then Result := RGB.rgbtGreen; if (Result < RGB.rgbtGreen) then Result := RGB.rgbtGreen;
if (Result < RGB.rgbtBlue) then Result := RGB.rgbtBlue; if (Result < RGB.rgbtBlue) then Result := RGB.rgbtBlue;
end; end;
function RGBMinValue(RGB: TRGBTriple) : byte;
begin
Result := RGB.rgbtRed;
if (Result > RGB.rgbtGreen) then Result := RGB.rgbtGreen;
if (Result > RGB.rgbtBlue) then Result := RGB.rgbtBlue;
end;
function RGBMinValue(RGB: TRGBTriple) : byte;
begin
Result := RGB.rgbtRed;
if (Result > RGB.rgbtGreen) then Result := RGB.rgbtGreen;
if (Result > RGB.rgbtBlue) then Result := RGB.rgbtBlue;
end;
var var
Delta, Min: byte; Delta, Min: byte;
begin begin
L := RGBMaxValue(RGBTriple); L := RGBMaxValue(RGBTriple);
Min := RGBMinValue(RGBTriple); Min := RGBMinValue(RGBTriple);
Delta := L-Min; Delta := L-Min;
if (L = Min) then if (L = Min) then
begin begin
H := 0; H := 0;
S := 0; S := 0;
end end
else else
begin begin
S := MulDiv(Delta, 255, L); S := MulDiv(Delta, 255, L);
with RGBTriple do with RGBTriple do
begin begin
if (rgbtRed = L) then if (rgbtRed = L) then
H := MulDiv(60, rgbtGreen-rgbtBlue, Delta) H := MulDiv(60, rgbtGreen-rgbtBlue, Delta)
else else if (rgbtGreen = L) then
if (rgbtGreen = L) then H := MulDiv(60, rgbtBlue-rgbtRed, Delta) + 120
H := MulDiv(60, rgbtBlue-rgbtRed, Delta) + 120 else if (rgbtBlue = L) then
else
if (rgbtBlue = L) then
H := MulDiv(60, rgbtRed-rgbtGreen, Delta) + 240; H := MulDiv(60, rgbtRed-rgbtGreen, Delta) + 240;
if (H < 0) then H := H + 360; if (H < 0) then H := H + 360;
end; end;
end; end;
end; end;

176
components/mbColorLib/RGBHSVUtils.pas
View File

@ -7,12 +7,12 @@ unit RGBHSVUtils;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LCLIntf, LCLType,
{$ELSE} {$ELSE}
Windows, Windows,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Graphics, Math, Scanlines; SysUtils, Classes, Graphics, Math, Scanlines;
function RGBtoRGBTriple(R, G, B: byte): TRGBTriple; function RGBtoRGBTriple(R, G, B: byte): TRGBTriple;
function RGBtoRGBQuad(R, G, B: byte): TRGBQuad; function RGBtoRGBQuad(R, G, B: byte): TRGBQuad;
@ -29,144 +29,142 @@ implementation
function RGBtoRGBTriple(R, G, B: byte): TRGBTriple; function RGBtoRGBTriple(R, G, B: byte): TRGBTriple;
begin begin
with Result do with Result do
begin begin
rgbtRed := R; rgbtRed := R;
rgbtGreen := G; rgbtGreen := G;
rgbtBlue := B; rgbtBlue := B;
end end
end; end;
function RGBtoRGBQuad(R, G, B: byte): TRGBQuad; function RGBtoRGBQuad(R, G, B: byte): TRGBQuad;
begin begin
with Result do with Result do
begin begin
rgbRed := R; rgbRed := R;
rgbGreen := G; rgbGreen := G;
rgbBlue := B; rgbBlue := B;
rgbReserved := 0; rgbReserved := 0;
end end
end; end;
function RGBTripleToColor(Triple: TRGBTriple): TColor; function RGBTripleToColor(Triple: TRGBTriple): TColor;
begin begin
Result := TColor(RGB(Triple.rgbtRed, Triple.rgbtGreen, Triple.rgbtBlue)); Result := RGB(Triple.rgbtRed, Triple.rgbtGreen, Triple.rgbtBlue);
end; end;
procedure RGBToHSV(R, G, B: integer; var H, S, V: integer); procedure RGBToHSV(R, G, B: integer; var H, S, V: integer);
var var
Delta, Min, H1, S1: real; Delta, Min, H1, S1: double;
begin begin
h1 := h; h1 := h;
s1 := s; s1 := s;
Min := MinIntValue([R, G, B]); Min := MinIntValue([R, G, B]);
V := MaxIntValue([R, G, B]); V := MaxIntValue([R, G, B]);
Delta := V - Min; Delta := V - Min;
if V = 0.0 then S1 := 0 else S1 := Delta / V; if V = 0.0 then S1 := 0 else S1 := Delta / V;
if S1 = 0.0 then if S1 = 0.0 then
H1 := 0 H1 := 0
else else
begin begin
if R = V then if R = V then
H1 := 60.0 * (G - B) / Delta H1 := 60.0 * (G - B) / Delta
else else if G = V then
if G = V then H1 := 120.0 + 60.0 * (B - R) / Delta
H1 := 120.0 + 60.0 * (B - R) / Delta else if B = V then
else
if B = V then
H1 := 240.0 + 60.0 * (R - G) / Delta; H1 := 240.0 + 60.0 * (R - G) / Delta;
if H1 < 0.0 then H1 := H1 + 360.0; if H1 < 0.0 then H1 := H1 + 360.0;
end; end;
h := round(h1); h := round(h1);
s := round(s1*255); s := round(s1*255);
end; end;
function HSVtoRGBTriple(H, S, V: integer): TRGBTriple; function HSVtoRGBTriple(H, S, V: integer): TRGBTriple;
const const
divisor: integer = 255*60; divisor: integer = 255*60;
var var
f, hTemp, p, q, t, VS: integer; f, hTemp, p, q, t, VS: integer;
begin begin
if H > 360 then H := H - 360; if H > 360 then H := H - 360;
if H < 0 then H := H + 360; if H < 0 then H := H + 360;
if s = 0 then if s = 0 then
Result := RGBtoRGBTriple(V, V, V) Result := RGBtoRGBTriple(V, V, V)
else else
begin begin
if H = 360 then hTemp := 0 else hTemp := H; if H = 360 then hTemp := 0 else hTemp := H;
f := hTemp mod 60; f := hTemp mod 60;
hTemp := hTemp div 60; hTemp := hTemp div 60;
VS := V*S; VS := V*S;
p := V - VS div 255; p := V - VS div 255;
q := V - (VS*f) div divisor; q := V - (VS*f) div divisor;
t := V - (VS*(60 - f)) div divisor; t := V - (VS*(60 - f)) div divisor;
case hTemp of case hTemp of
0: Result := RGBtoRGBTriple(V, t, p); 0: Result := RGBtoRGBTriple(V, t, p);
1: Result := RGBtoRGBTriple(q, V, p); 1: Result := RGBtoRGBTriple(q, V, p);
2: Result := RGBtoRGBTriple(p, V, t); 2: Result := RGBtoRGBTriple(p, V, t);
3: Result := RGBtoRGBTriple(p, q, V); 3: Result := RGBtoRGBTriple(p, q, V);
4: Result := RGBtoRGBTriple(t, p, V); 4: Result := RGBtoRGBTriple(t, p, V);
5: Result := RGBtoRGBTriple(V, p, q); 5: Result := RGBtoRGBTriple(V, p, q);
else Result := RGBtoRGBTriple(0,0,0) else Result := RGBtoRGBTriple(0,0,0)
end; end;
end; end;
end; end;
function HSVtoRGBQuad(H, S, V: integer): TRGBQuad; function HSVtoRGBQuad(H, S, V: integer): TRGBQuad;
const const
divisor: integer = 255*60; divisor: integer = 255*60;
var var
f, hTemp, p, q, t, VS: integer; f, hTemp, p, q, t, VS: integer;
begin begin
if H > 360 then H := H - 360; if H > 360 then H := H - 360;
if H < 0 then H := H + 360; if H < 0 then H := H + 360;
if s = 0 then if s = 0 then
Result := RGBtoRGBQuad(V, V, V) Result := RGBtoRGBQuad(V, V, V)
else else
begin begin
if H = 360 then hTemp := 0 else hTemp := H; if H = 360 then hTemp := 0 else hTemp := H;
f := hTemp mod 60; f := hTemp mod 60;
hTemp := hTemp div 60; hTemp := hTemp div 60;
VS := V*S; VS := V*S;
p := V - VS div 255; p := V - VS div 255;
q := V - (VS*f) div divisor; q := V - (VS*f) div divisor;
t := V - (VS*(60 - f)) div divisor; t := V - (VS*(60 - f)) div divisor;
case hTemp of case hTemp of
0: Result := RGBtoRGBQuad(V, t, p); 0: Result := RGBtoRGBQuad(V, t, p);
1: Result := RGBtoRGBQuad(q, V, p); 1: Result := RGBtoRGBQuad(q, V, p);
2: Result := RGBtoRGBQuad(p, V, t); 2: Result := RGBtoRGBQuad(p, V, t);
3: Result := RGBtoRGBQuad(p, q, V); 3: Result := RGBtoRGBQuad(p, q, V);
4: Result := RGBtoRGBQuad(t, p, V); 4: Result := RGBtoRGBQuad(t, p, V);
5: Result := RGBtoRGBQuad(V, p, q); 5: Result := RGBtoRGBQuad(V, p, q);
else Result := RGBtoRGBQuad(0,0,0) else Result := RGBtoRGBQuad(0,0,0)
end; end;
end; end;
end; end;
function HSVtoColor(H, S, V: integer): TColor; function HSVtoColor(H, S, V: integer): TColor;
begin begin
Result := RGBTripleToColor(HSVtoRGBTriple(H, S, V)); Result := RGBTripleToColor(HSVtoRGBTriple(H, S, V));
end; end;
function GetHValue(Color: TColor): integer; function GetHValue(Color: TColor): integer;
var var
s, v: integer; s, v: integer;
begin begin
RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), Result, s, v); RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), Result, s, v);
end; end;
function GetSValue(Color: TColor): integer; function GetSValue(Color: TColor): integer;
var var
h, v: integer; h, v: integer;
begin begin
RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), h, Result, v); RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), h, Result, v);
end; end;
function GetVValue(Color: TColor): integer; function GetVValue(Color: TColor): integer;
var var
h, s: integer; h, s: integer;
begin begin
RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), h, s, Result); RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), h, s, Result);
end; end;
end. end.

60
components/mbColorLib/SColorPicker.pas
View File

@ -7,38 +7,38 @@ unit SColorPicker;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines; RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines;
type type
TSColorPicker = class(TmbTrackBarPicker) TSColorPicker = class(TmbTrackBarPicker)
private private
FVal, FHue, FSat: integer; FVal, FHue, FSat: integer;
function ArrowPosFromSat(s: integer): integer; function ArrowPosFromSat(s: integer): integer;
function SatFromArrowPos(p: integer): integer; function SatFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor; function GetSelectedColor: TColor;
procedure SetSelectedColor(c: TColor); procedure SetSelectedColor(c: TColor);
procedure SetHue(h: integer); procedure SetHue(h: integer);
procedure SetSat(s: integer); procedure SetSat(s: integer);
procedure SetValue(v: integer); procedure SetValue(v: integer);
protected protected
procedure Execute(tbaAction: integer); override; procedure Execute(tbaAction: integer); override;
function GetArrowPos: integer; override; function GetArrowPos: integer; override;
function GetGradientColor(AValue: Integer): TColor; override; function GetGradientColor(AValue: Integer): TColor; override;
function GetSelectedValue: integer; override; function GetSelectedValue: integer; override;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
published published
property Hue: integer read FHue write SetHue default 0; property Hue: integer read FHue write SetHue default 0;
property Saturation: integer read FSat write SetSat default 255; property Saturation: integer read FSat write SetSat default 255;
property Value: integer read FVal write SetValue default 255; property Value: integer read FVal write SetValue default 255;
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
end; end;
implementation implementation

20
components/mbColorLib/ScreenWin.pas
View File

@ -92,19 +92,19 @@ end;
procedure TScreenForm.FormShow(Sender: TObject); procedure TScreenForm.FormShow(Sender: TObject);
begin begin
Width := Screen.Width; Width := Screen.Width;
Height := Screen.Height; Height := Screen.Height;
Left := 0; Left := 0;
Top := 0; Top := 0;
end; end;
procedure TScreenForm.FormCreate(Sender: TObject); procedure TScreenForm.FormCreate(Sender: TObject);
begin begin
Brush.Style := bsClear; Brush.Style := bsClear;
Screen.Cursors[crPickerCursor] := LoadCursor(HInstance, 'PickerCursor'); Screen.Cursors[crPickerCursor] := LoadCursor(HInstance, 'PickerCursor');
Cursor := crPickerCursor; Cursor := crPickerCursor;
SelectedColor := clNone; SelectedColor := clNone;
FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: %h'; FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: %h';
end; end;
procedure TScreenForm.FormKeyDown(Sender: TObject; var Key: Word; procedure TScreenForm.FormKeyDown(Sender: TObject; var Key: Word;
@ -132,7 +132,7 @@ end;
procedure TScreenForm.FormMouseUp(Sender: TObject; Button: TMouseButton; procedure TScreenForm.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); Shift: TShiftState; X, Y: Integer);
begin begin
EndSelection(x, y, true); EndSelection(x, y, true);
end; end;
procedure TScreenForm.FormMouseMove(Sender: TObject; Shift: TShiftState; X, procedure TScreenForm.FormMouseMove(Sender: TObject; Shift: TShiftState; X,

70
components/mbColorLib/SelPropUtils.pas
View File

@ -23,58 +23,58 @@ implementation
procedure DrawSelCross(x, y: integer; Canvas: TCanvas; Color: TColor); procedure DrawSelCross(x, y: integer; Canvas: TCanvas; Color: TColor);
const const
w = 5; w = 5;
h = 3; h = 3;
o = 8; o = 8;
var var
R: TRect; R: TRect;
begin begin
R := Rect(x-10, y-10, x+9, y+9); R := Rect(x-10, y-10, x+9, y+9);
Canvas.Brush.Color := Color; Canvas.Brush.Color := Color;
Canvas.FillRect(Rect(R.Left, R.Top + o, R.Left + w, R.Top + o + h)); Canvas.FillRect(Rect(R.Left, R.Top + o, R.Left + w, R.Top + o + h));
Canvas.FillRect(Rect(R.Left + o, R.Top, R.Left + o + h, R.Top + w)); Canvas.FillRect(Rect(R.Left + o, R.Top, R.Left + o + h, R.Top + w));
Canvas.FillRect(Rect(R.Right - w, R.Top + o, R.Right, R.Top + o + h)); Canvas.FillRect(Rect(R.Right - w, R.Top + o, R.Right, R.Top + o + h));
Canvas.FillRect(Rect(R.Left + o, R.Bottom - w, R.Left + o + h, R.Bottom)); Canvas.FillRect(Rect(R.Left + o, R.Bottom - w, R.Left + o + h, R.Bottom));
end; end;
procedure DrawSelCrossCirc(x, y: integer; Canvas: TCanvas; Color: TColor); procedure DrawSelCrossCirc(x, y: integer; Canvas: TCanvas; Color: TColor);
var var
R: TRect; R: TRect;
begin begin
R := Rect(x - 6, y - 6, x + 6, y + 6); R := Rect(x - 6, y - 6, x + 6, y + 6);
ExcludeClipRect(Canvas.Handle, x - 6, y - 1, x + 6, y + 1); ExcludeClipRect(Canvas.Handle, x - 6, y - 1, x + 6, y + 1);
ExcludeClipRect(Canvas.Handle, x - 1, y - 6, x + 1, y + 6); ExcludeClipRect(Canvas.Handle, x - 1, y - 6, x + 1, y + 6);
Canvas.Pen.Color := Color; Canvas.Pen.Color := Color;
Canvas.Brush.Style := bsClear; Canvas.Brush.Style := bsClear;
InflateRect(R, -1, -1); InflateRect(R, -1, -1);
Canvas.Ellipse(R); Canvas.Ellipse(R);
InflateRect(R, -1, -1); InflateRect(R, -1, -1);
Canvas.Ellipse(R); Canvas.Ellipse(R);
Canvas.Brush.Style := bsSolid; Canvas.Brush.Style := bsSolid;
end; end;
procedure DrawSelCirc(x, y: integer; Canvas: TCanvas); procedure DrawSelCirc(x, y: integer; Canvas: TCanvas);
var var
R: TRect; R: TRect;
begin begin
R := Rect(x - 5, y - 5, x + 5, y + 5); R := Rect(x - 5, y - 5, x + 5, y + 5);
Canvas.Brush.Style := bsClear; Canvas.Brush.Style := bsClear;
Canvas.Pen.Mode := pmNot; Canvas.Pen.Mode := pmNot;
Canvas.Ellipse(R); Canvas.Ellipse(R);
Canvas.Pen.Mode := pmCopy; Canvas.Pen.Mode := pmCopy;
Canvas.Brush.Style := bsSolid; Canvas.Brush.Style := bsSolid;
end; end;
procedure DrawSelSquare(x, y: integer; Canvas: TCanvas); procedure DrawSelSquare(x, y: integer; Canvas: TCanvas);
var var
R: TRect; R: TRect;
begin begin
R := Rect(x - 5, y - 5, x + 5, y + 5); R := Rect(x - 5, y - 5, x + 5, y + 5);
Canvas.Brush.Style := bsClear; Canvas.Brush.Style := bsClear;
Canvas.Pen.Mode := pmNot; Canvas.Pen.Mode := pmNot;
Canvas.Rectangle(R); Canvas.Rectangle(R);
Canvas.Pen.Mode := pmCopy; Canvas.Pen.Mode := pmCopy;
Canvas.Brush.Style := bsSolid; Canvas.Brush.Style := bsSolid;
end; end;
end. end.

67
components/mbColorLib/YColorPicker.pas
View File

@ -7,42 +7,41 @@ interface
{$ENDIF} {$ENDIF}
uses uses
{$IFDEF FPC} {$IFDEF FPC}
LCLIntf, LCLType, LMessages, LCLIntf, LCLType, LMessages,
{$ELSE} {$ELSE}
Windows, Messages, Windows, Messages,
{$ENDIF} {$ENDIF}
SysUtils, Classes, Controls, Graphics, Forms, SysUtils, Classes, Controls, Graphics, Forms,
RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines; RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines;
type type
TYColorPicker = class(TmbTrackBarPicker) TYColorPicker = class(TmbTrackBarPicker)
private private
FYellow, FMagenta, FCyan, FBlack: integer; FYellow, FMagenta, FCyan, FBlack: integer;
function ArrowPosFromYellow(y: integer): integer;
function ArrowPosFromYellow(y: integer): integer; function YellowFromArrowPos(p: integer): integer;
function YellowFromArrowPos(p: integer): integer; function GetSelectedColor: TColor;
function GetSelectedColor: TColor; procedure SetSelectedColor(c: TColor);
procedure SetSelectedColor(c: TColor); procedure SetYellow(y: integer);
procedure SetYellow(y: integer); procedure SetMagenta(m: integer);
procedure SetMagenta(m: integer); procedure SetCyan(c: integer);
procedure SetCyan(c: integer); procedure SetBlack(k: integer);
procedure SetBlack(k: integer); protected
protected procedure Execute(tbaAction: integer); override;
procedure Execute(tbaAction: integer); override; function GetArrowPos: integer; override;
function GetArrowPos: integer; override; function GetGradientColor(AValue: Integer): TColor; override;
function GetGradientColor(AValue: Integer): TColor; override; function GetSelectedValue: integer; override;
function GetSelectedValue: integer; override; public
public constructor Create(AOwner: TComponent); override;
constructor Create(AOwner: TComponent); override; published
published property Yellow: integer read FYellow write SetYellow default 255;
property Yellow: integer read FYellow write SetYellow default 255; property Magenta: integer read FMagenta write SetMagenta default 0;
property Magenta: integer read FMagenta write SetMagenta default 0; property Cyan: integer read FCyan write SetCyan default 0;
property Cyan: integer read FCyan write SetCyan default 0; property Black: integer read FBlack write SetBlack default 0;
property Black: integer read FBlack write SetBlack default 0; property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed; property Layout default lyVertical;
property Layout default lyVertical; end;
end;
implementation implementation

351
components/mbColorLib/mbColorList.pas
View File

@ -166,271 +166,264 @@ end;
constructor TmbColorList.Create(AOwner: TComponent); constructor TmbColorList.Create(AOwner: TComponent);
begin begin
inherited; inherited;
MaxHue := 360; {
MaxSat := 255; MaxHue := 360;
MaxLum := 255; MaxSat := 255;
style := lbOwnerDrawFixed; MaxLum := 255;
SetLength(Colors, 0); }
ItemHeight := 48; style := lbOwnerDrawFixed;
IntegralHeight := true; SetLength(Colors, 0);
mx := -1; ItemHeight := 48;
my := -1; IntegralHeight := true;
mx := -1;
my := -1;
end; end;
procedure TmbColorList.UpdateColors; procedure TmbColorList.UpdateColors;
var var
i: integer; i: integer;
begin begin
Items.Clear; Items.Clear;
for i := 0 to Length(Colors) - 1 do for i := 0 to Length(Colors) - 1 do
Items.Add(Colors[i].name); Items.Add(Colors[i].name);
end; end;
procedure TmbColorList.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); procedure TmbColorList.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var var
SR, TR, R: TRect; SR, TR, R: TRect;
itemText: string; itemText: string;
begin begin
if Length(Colors) = 0 then Exit; if Length(Colors) = 0 then Exit;
R := Rect; R := Rect;
with Canvas do with Canvas do
begin begin
//background //background
Pen.Color := clWindow; Pen.Color := clWindow;
if odSelected in State then if odSelected in State then
Brush.Color := clHighlight Brush.Color := clHighlight
else else
Brush.Color := self.Color; //clBtnFace; Brush.Color := self.Color; //clBtnFace;
FillRect(R); FillRect(R);
MoveTo(R.Left, R.Bottom - 1); MoveTo(R.Left, R.Bottom - 1);
LineTo(R.Right, R.Bottom - 1); LineTo(R.Right, R.Bottom - 1);
//swatches //swatches
SR := Classes.Rect(R.Left + 6, R.Top + 6, R.Left + ItemHeight - 6, R.Top + ItemHeight - 6); SR := Classes.Rect(R.Left + 6, R.Top + 6, R.Left + ItemHeight - 6, R.Top + ItemHeight - 6);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[Index].value;
if odSelected in State then if odSelected in State then
begin begin
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI_7_UP}
if ThemeServices.ThemesEnabled then if ThemeServices.ThemesEnabled then
begin begin
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR); ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
InflateRect(SR, -2, -2); InflateRect(SR, -2, -2);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80); Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80);
FillRect(SR); FillRect(SR);
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
Brush.Color := Blend(self.Colors[Index].value, clBlack, 90); Brush.Color := Blend(self.Colors[Index].value, clBlack, 90);
FillRect(SR); FillRect(SR);
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[Index].value;
FillRect(SR); FillRect(SR);
end end
else else
//windows 9x //windows 9x
begin begin
{$ENDIF} {$ENDIF}
Pen.Color := clBackground; Pen.Color := clBackground;
Brush.Color := clWindow; Brush.Color := clWindow;
Rectangle(SR); Rectangle(SR);
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
FillRect(SR); FillRect(SR);
InflateRect(SR, 1, 1); InflateRect(SR, 1, 1);
InflateRect(SR, -2, -2); InflateRect(SR, -2, -2);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 75); Brush.Color := Blend(Self.Colors[Index].value, clBlack, 75);
FillRect(SR); FillRect(SR);
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 87); Brush.Color := Blend(Self.Colors[Index].value, clBlack, 87);
FillRect(SR); FillRect(SR);
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[Index].value;
FillRect(SR); FillRect(SR);
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI_7_UP}
end; end;
{$ENDIF} {$ENDIF}
end end
else else
//not selected //not selected
begin begin
//windows XP //windows XP
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI_7_UP}
if ThemeServices.ThemesEnabled then if ThemeServices.ThemesEnabled then
begin begin
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR); ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
InflateRect(SR, -2, -2); InflateRect(SR, -2, -2);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[Index].value;
FillRect(SR); FillRect(SR);
end end
else else
//windows 9x //windows 9x
begin begin
{$ENDIF} {$ENDIF}
DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT); DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT);
InflateRect(SR, -2, -2); InflateRect(SR, -2, -2);
Brush.Color := Self.Colors[Index].value; Brush.Color := Self.Colors[Index].value;
Pen.Color := clBlack; Pen.Color := clBlack;
Rectangle(SR); Rectangle(SR);
InflateRect(SR, -1, -1); InflateRect(SR, -1, -1);
FillRect(SR); FillRect(SR);
InflateRect(SR, 1, 1); InflateRect(SR, 1, 1);
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI_7_UP}
end; end;
{$ENDIF} {$ENDIF}
end; end;
//names //names
Font.Style := [fsBold]; Font.Style := [fsBold];
if odSelected in State then if odSelected in State then
begin begin
Brush.Color := clHighlight; Brush.Color := clHighlight;
Pen.Color := clHighlightText; Pen.Color := clHighlightText;
Font.Color := clHighlightText; Font.Color := clHighlightText;
end end
else else
begin begin
Brush.Color := clBtnFace; Brush.Color := clBtnFace;
Pen.Color := clWindowText; Pen.Color := clWindowText;
Font.Color := clWindowText; Font.Color := clWindowText;
end; end;
itemText := Items.Strings[Index]; itemText := Items.Strings[Index];
Canvas.Brush.Style := bsClear; Canvas.Brush.Style := bsClear;
TR := Classes.Rect(R.Left + ItemHeight, R.Top + (ItemHeight - TextHeight(itemText)) div 2, R.Right, R.Bottom - (ItemHeight - TextHeight(itemText)) div 2); TR := Classes.Rect(R.Left + ItemHeight, R.Top + (ItemHeight - TextHeight(itemText)) div 2, R.Right, R.Bottom - (ItemHeight - TextHeight(itemText)) div 2);
if Assigned(FDraw) then FDraw(Self, Index, Canvas.Font, itemText, odSelected in State); if Assigned(FDraw) then FDraw(Self, Index, Canvas.Font, itemText, odSelected in State);
DrawText(Canvas.Handle, PChar(itemText), Length(itemText), TR, DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS); DrawText(Canvas.Handle, PChar(itemText), Length(itemText), TR, DT_LEFT or DT_NOCLIP or DT_END_ELLIPSIS);
end; end;
end; end;
procedure TmbColorList.AddColor(Name: string; Value: TColor; refresh: boolean = true); procedure TmbColorList.AddColor(Name: string; Value: TColor; refresh: boolean = true);
var var
l: integer; l: integer;
begin begin
l := Length(Colors); l := Length(Colors);
SetLength(Colors, l + 1); SetLength(Colors, l + 1);
Colors[l].name := Name; Colors[l].name := Name;
Colors[l].value := Value; Colors[l].value := Value;
if refresh then if refresh then
UpdateColors; UpdateColors;
end; end;
procedure TmbColorList.ClearColors; procedure TmbColorList.ClearColors;
begin begin
SetLength(Colors, 0); SetLength(Colors, 0);
UpdateColors; UpdateColors;
end; end;
function TmbColorList.ColorCount: integer; function TmbColorList.ColorCount: integer;
begin begin
Result := Length(Colors); Result := Length(Colors);
end; end;
procedure TmbColorList.DeleteColor(Index: integer; refresh: boolean = true); procedure TmbColorList.DeleteColor(Index: integer; refresh: boolean = true);
var var
i: integer; i: integer;
begin begin
if Length(Colors) = 0 then if Length(Colors) = 0 then
begin raise Exception.Create('There''s nothing to delete! The length of the array is 0.');
raise Exception.Create('There''s nothing to delete! The length of the array is 0.');
Exit;
end;
if Index > Length(Colors) - 1 then if Index > Length(Colors) - 1 then
begin raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
Exit;
end;
for i := Index to Length(Colors) - 2 do for i := Index to Length(Colors) - 2 do
Colors[i] := Colors[i+1]; Colors[i] := Colors[i+1];
SetLength(Colors, Length(Colors) - 1); SetLength(Colors, Length(Colors) - 1);
if refresh then if refresh then
UpdateColors; UpdateColors;
end; end;
procedure TmbColorList.DeleteColorByName(Name: string; All: boolean); procedure TmbColorList.DeleteColorByName(Name: string; All: boolean);
var var
i: integer; i: integer;
begin begin
for i := Length(Colors) - 1 downto 0 do for i := Length(Colors) - 1 downto 0 do
if SameText(Colors[i].name, Name) then if SameText(Colors[i].name, Name) then
begin begin
DeleteColor(i, false); DeleteColor(i, false);
if not All then if not All then
begin begin
UpdateColors; UpdateColors;
Exit; Exit;
end; end;
end; end;
UpdateColors; UpdateColors;
end; end;
procedure TmbColorList.DeleteColorByValue(Value: TColor; All: boolean); procedure TmbColorList.DeleteColorByValue(Value: TColor; All: boolean);
var var
i: integer; i: integer;
begin begin
for i := Length(Colors) - 1 downto 0 do for i := Length(Colors) - 1 downto 0 do
if Colors[i].Value = Value then if Colors[i].Value = Value then
begin begin
DeleteColor(i, false); DeleteColor(i, false);
if not All then if not All then
begin begin
UpdateColors; UpdateColors;
Exit; Exit;
end; end;
end; end;
UpdateColors; UpdateColors;
end; end;
procedure TmbColorList.InsertColor(Index: integer; Name: string; Value: TColor); procedure TmbColorList.InsertColor(Index: integer; Name: string; Value: TColor);
var var
i: integer; i: integer;
begin begin
if Index > Length(Colors) - 1 then if Index > Length(Colors) - 1 then
begin raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
Exit;
end;
SetLength(Colors, Length(Colors) + 1); SetLength(Colors, Length(Colors) + 1);
for i := Length(Colors) - 1 downto Index do for i := Length(Colors) - 1 downto Index do
Colors[i] := Colors[i-1]; Colors[i] := Colors[i-1];
Colors[Index].Name := Name; Colors[Index].Name := Name;
Colors[Index].Value := Value; Colors[Index].Value := Value;
UpdateColors; UpdateColors;
end; end;
procedure TmbColorList.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TmbColorList.MouseMove(Shift: TShiftState; X, Y: Integer);
begin begin
inherited; inherited;
mx := x; mx := x;
my := y; my := y;
end; end;
procedure TmbColorList.CMHintShow(var Message: TCMHintShow); procedure TmbColorList.CMHintShow(var Message: TCMHintShow);
var var
Handled: boolean; Handled: boolean;
i: integer; i: integer;
begin begin
if PtInRect(ClientRect, Point(mx, my)) and ShowHint then if PtInRect(ClientRect, Point(mx, my)) and ShowHint then
begin begin
i := ItemAtPos(Point(mx, my), true); i := ItemAtPos(Point(mx, my), true);
if i > -1 then if i > -1 then
with TCMHintShow(Message) do with TCMHintShow(Message) do
if not ShowHint then if not ShowHint then
Message.Result := 1 Message.Result := 1
else else
with HintInfo^ do with HintInfo^ do
begin begin
Result := 0; Result := 0;
ReshowTimeout := 2000; ReshowTimeout := 2000;
HideTimeout := 1000; HideTimeout := 1000;
Handled := false; Handled := false;
if Assigned(FGetHint) then FGetHint(i, HintStr, Handled); if Assigned(FGetHint) then FGetHint(i, HintStr, Handled);
if Handled then if Handled then
HintStr := FormatHint(HintStr, Colors[i].Value) HintStr := FormatHint(HintStr, Colors[i].Value)
else else
HintStr := Colors[i].Name; HintStr := Colors[i].Name;
end; end;
end; end;
inherited; inherited;
end; end;
end. end.

727
components/mbColorLib/mbColorPalette.pas
View File

@ -177,45 +177,45 @@ implementation
constructor TmbColorPalette.Create(AOwner: TComponent); constructor TmbColorPalette.Create(AOwner: TComponent);
begin begin
inherited Create(AOwner); inherited Create(AOwner);
// ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque]; // ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];
// DoubleBuffered := true; // DoubleBuffered := true;
// PBack := TBitmap.Create; // PBack := TBitmap.Create;
// PBack.PixelFormat := pf32bit; // PBack.PixelFormat := pf32bit;
FTempBmp := TBitmap.Create; FTempBmp := TBitmap.Create;
//FTempBmp.PixelFormat := pf32bit; //FTempBmp.PixelFormat := pf32bit;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI} {$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
ParentBackground := true; ParentBackground := true;
{$ENDIF} {$ENDIF} {$ENDIF} {$ENDIF}
TabStop := true; TabStop := true;
ParentShowHint := true; ParentShowHint := true;
ShowHint := false; ShowHint := false;
Width := 180; Width := 180;
Height := 126; Height := 126;
FMouseLoc := mlNone; FMouseLoc := mlNone;
FMouseOver := false; FMouseOver := false;
FMouseDown := false; FMouseDown := false;
FColCount := 0; FColCount := 0;
FRowCount := 0; FRowCount := 0;
FIndex := -1; FIndex := -1;
FCheckedIndex := -1; FCheckedIndex := -1;
FTop := 0; FTop := 0;
FLeft := 0; FLeft := 0;
FCellSize := 18; FCellSize := 18;
FState := ccsNone; FState := ccsNone;
FNames := TStringList.Create; FNames := TStringList.Create;
FColors := TStringList.Create; FColors := TStringList.Create;
(FColors as TStringList).OnChange := ColorsChange; (FColors as TStringList).OnChange := ColorsChange;
FTotalCells := 0; FTotalCells := 0;
FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: %hex'; FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: %hex';
FAutoHeight := false; FAutoHeight := false;
FMinColors := 0; FMinColors := 0;
FMaxColors := 0; FMaxColors := 0;
FSort := smNone; FSort := smNone;
FOrder := soAscending; FOrder := soAscending;
FOld := clNone; FOld := clNone;
FTStyle := tsNone; FTStyle := tsNone;
FCellStyle := csDefault; FCellStyle := csDefault;
end; end;
destructor TmbColorPalette.Destroy; destructor TmbColorPalette.Destroy;
@ -254,9 +254,9 @@ end;
procedure TmbColorPalette.CreateWnd; procedure TmbColorPalette.CreateWnd;
begin begin
inherited; inherited;
CalcAutoHeight; CalcAutoHeight;
Invalidate; Invalidate;
end; end;
(* (*
procedure TmbColorPalette.PaintParentBack; procedure TmbColorPalette.PaintParentBack;
@ -578,110 +578,109 @@ end;
procedure TmbColorPalette.PaintTransparentGlyph(ACanvas: TCanvas; R: TRect); procedure TmbColorPalette.PaintTransparentGlyph(ACanvas: TCanvas; R: TRect);
begin begin
InflateRect(R, -3, -3); InflateRect(R, -3, -3);
if FCellStyle = csCorel then if FCellStyle = csCorel then
begin begin
if FState <> ccsNone then if FState <> ccsNone then
InflateRect(R, -2, -2) InflateRect(R, -2, -2)
else else if FColCount > 1 then
if FColCount > 1 then Inc(R.Right);
Inc(R.Right);
end; end;
with ACanvas do with ACanvas do
case FTStyle of case FTStyle of
tsPhotoshop: tsPhotoshop:
begin begin
if Enabled then if Enabled then
Pen.Color := clBtnShadow Pen.Color := clBtnShadow
else else
Pen.Color := clGray; Pen.Color := clGray;
Brush.Color := clWhite; Brush.Color := clWhite;
Rectangle(R); Rectangle(R);
Brush.Color := clSilver; Brush.Color := clSilver;
FillRect(Rect(R.Left + (R.Right - R.Left) div 2, R.Top + 1, R.Right - 1, R.Top + (R.Bottom - R.Top) div 2)); FillRect(Rect(R.Left + (R.Right - R.Left) div 2, R.Top + 1, R.Right - 1, R.Top + (R.Bottom - R.Top) div 2));
FillRect(Rect(R.Left + 1, R.Top + (R.Bottom - R.Top) div 2, R.Left + (R.Right - R.Left) div 2, R.Bottom - 1)); FillRect(Rect(R.Left + 1, R.Top + (R.Bottom - R.Top) div 2, R.Left + (R.Right - R.Left) div 2, R.Bottom - 1));
end;
tsPhotoshop2:
begin
InflateRect(R, -1, -1);
Brush.Color := clWhite;
Rectangle(R);
Pen.Color := clRed;
Pen.Width := 2;
InflateRect(R, 1, 1);
MoveTo(R.Left, R.Top);
LineTo(R.Right - 1, R.Bottom - 1);
Pen.Width := 1;
Pen.Color := clBlack;
end;
tsCorel:
begin
if FCellStyle = csCorel then
begin
Pen.Color := clBlack;
InflateRect(R, 3, 3);
Brush.Color := clWhite;
Rectangle(R);
//the \ line
MoveTo(R.Left, R.Top);
LineTo(R.Right, R.Bottom);
//the / line
MoveTo(R.Right-1, R.Top);
LineTo(R.Left-1, R.Bottom);
end
else
begin
if Enabled then
Pen.Color := clBtnShadow
else
Pen.Color := clGray;
Brush.Color := clWhite;
Rectangle(R);
MoveTo(R.Left, R.Top);
LineTo(R.Right, R.Bottom);
MoveTo(R.Right - 1, R.Top);
LineTo(R.Left - 1, R.Bottom);
end;
end;
tsMicroangelo:
begin
InflateRect(R, -1, -1);
Dec(R.Bottom);
Pen.Color := clBlack;
Brush.Color := clTeal;
Rectangle(R);
Pixels[R.Left + 2, R.Top + 2] := clWhite;
Pixels[R.Left + (R.Right - R.Left) div 2, R.Bottom] := clBlack;
MoveTo(R.Left + (R.Right - R.Left) div 2 - 2, R.Bottom + 1);
LineTo(R.Left + (R.Right - R.Left) div 2 + 3, R.Bottom + 1);
end;
end; end;
tsPhotoshop2:
begin
InflateRect(R, -1, -1);
Brush.Color := clWhite;
Rectangle(R);
Pen.Color := clRed;
Pen.Width := 2;
InflateRect(R, 1, 1);
MoveTo(R.Left, R.Top);
LineTo(R.Right - 1, R.Bottom - 1);
Pen.Width := 1;
Pen.Color := clBlack;
end;
tsCorel:
begin
if FCellStyle = csCorel then
begin
Pen.Color := clBlack;
InflateRect(R, 3, 3);
Brush.Color := clWhite;
Rectangle(R);
//the \ line
MoveTo(R.Left, R.Top);
LineTo(R.Right, R.Bottom);
//the / line
MoveTo(R.Right-1, R.Top);
LineTo(R.Left-1, R.Bottom);
end
else
begin
if Enabled then
Pen.Color := clBtnShadow
else
Pen.Color := clGray;
Brush.Color := clWhite;
Rectangle(R);
MoveTo(R.Left, R.Top);
LineTo(R.Right, R.Bottom);
MoveTo(R.Right - 1, R.Top);
LineTo(R.Left - 1, R.Bottom);
end;
end;
tsMicroangelo:
begin
InflateRect(R, -1, -1);
Dec(R.Bottom);
Pen.Color := clBlack;
Brush.Color := clTeal;
Rectangle(R);
Pixels[R.Left + 2, R.Top + 2] := clWhite;
Pixels[R.Left + (R.Right - R.Left) div 2, R.Bottom] := clBlack;
MoveTo(R.Left + (R.Right - R.Left) div 2 - 2, R.Bottom + 1);
LineTo(R.Left + (R.Right - R.Left) div 2 + 3, R.Bottom + 1);
end;
end;
end; end;
procedure TmbColorPalette.Resize; procedure TmbColorPalette.Resize;
begin begin
inherited; inherited;
//CalcAutoHeight; // wp: will cause a ChangedBounds endless loop //CalcAutoHeight; // wp: will cause a ChangedBounds endless loop
Invalidate; Invalidate;
end; end;
procedure TmbColorPalette.CMMouseEnter( procedure TmbColorPalette.CMMouseEnter(
var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} );
begin begin
FMouseOver := true; FMouseOver := true;
FMouseLoc := mlOver; FMouseLoc := mlOver;
Invalidate; Invalidate;
inherited; inherited;
end; end;
procedure TmbColorPalette.CMMouseLeave( procedure TmbColorPalette.CMMouseLeave(
var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} );
begin begin
FMouseOver := false; FMouseOver := false;
FMouseLoc := mlNone; FMouseLoc := mlNone;
FIndex := -1; FIndex := -1;
Invalidate; Invalidate;
inherited; inherited;
end; end;
procedure TmbColorPalette.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TmbColorPalette.MouseMove(Shift: TShiftState; X, Y: Integer);
@ -700,25 +699,25 @@ end;
procedure TmbColorPalette.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TmbColorPalette.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin begin
if Button = mbLeft then if Button = mbLeft then
begin begin
SetFocus; SetFocus;
FMouseDown := true; FMouseDown := true;
FMouseLoc := mlDown; FMouseLoc := mlDown;
if (y div FCellSize)* FColCount + (x div FCellSize) <= FTotalCells then if (y div FCellSize)* FColCount + (x div FCellSize) <= FTotalCells then
if FCheckedIndex <> (y div FCellSize)* FColCount + (x div FCellSize) then if FCheckedIndex <> (y div FCellSize)* FColCount + (x div FCellSize) then
begin begin
FOldIndex := FCheckedIndex; FOldIndex := FCheckedIndex;
FCheckedIndex := (y div FCellSize)* FColCount + (x div FCellSize); FCheckedIndex := (y div FCellSize)* FColCount + (x div FCellSize);
end; end;
Invalidate; Invalidate;
end; end;
inherited; inherited;
end; end;
procedure TmbColorPalette.Click; procedure TmbColorPalette.Click;
begin begin
inherited; inherited;
end; end;
procedure TmbColorPalette.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TmbColorPalette.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
@ -815,171 +814,173 @@ end;
procedure TmbColorPalette.SetCellStyle(s: TCellStyle); procedure TmbColorPalette.SetCellStyle(s: TCellStyle);
begin begin
if FCellStyle <> s then if FCellStyle <> s then
begin begin
FCellStyle := s; FCellStyle := s;
Invalidate; Invalidate;
end; end;
end; end;
procedure TmbColorPalette.SetSelColor(k: TColor); procedure TmbColorPalette.SetSelColor(k: TColor);
var var
s: string; s: string;
i: integer; i: integer;
begin begin
s := mbColorToString(k); s := mbColorToString(k);
for i:= 0 to FColors.Count - 1 do for i:= 0 to FColors.Count - 1 do
if SameText(s, FColors.Strings[i]) then if SameText(s, FColors.Strings[i]) then
begin begin
FCheckedIndex := i; FCheckedIndex := i;
Break; Break;
end end
else else
FCheckedIndex := -1; FCheckedIndex := -1;
Invalidate; Invalidate;
FOld := k; FOld := k;
if Assigned(FOnChange) then FOnChange(Self); if Assigned(FOnChange) then FOnChange(Self);
end; end;
procedure TmbColorPalette.SetStrings(s: TStrings); procedure TmbColorPalette.SetStrings(s: TStrings);
var var
i: integer; i: integer;
begin begin
FColors.Clear; FColors.Clear;
FColors.AddStrings(s); FColors.AddStrings(s);
if FColors.Count < FMinColors then if FColors.Count < FMinColors then
for i := 0 to FMinColors - FColors.Count - 1 do for i := 0 to FMinColors - FColors.Count - 1 do
FColors.Add('clNone'); FColors.Add('clNone');
if (FColors.Count > FMaxColors) and (FMaxColors > 0) then if (FColors.Count > FMaxColors) and (FMaxColors > 0) then
for i := FColors.Count - 1 downto FMaxColors do for i := FColors.Count - 1 downto FMaxColors do
FColors.Delete(i); FColors.Delete(i);
CalcAutoHeight; CalcAutoHeight;
SortColors; SortColors;
Invalidate; Invalidate;
end; end;
procedure TmbColorPalette.SetNames(n: TStrings); procedure TmbColorPalette.SetNames(n: TStrings);
var var
i: integer; i: integer;
begin begin
FNames.Clear; FNames.Clear;
FNames.AddStrings(n); FNames.AddStrings(n);
if (FNames.Count > FMaxColors) and (FMaxColors > 0) then if (FNames.Count > FMaxColors) and (FMaxColors > 0) then
for i := FNames.Count - 1 downto FMaxColors do for i := FNames.Count - 1 downto FMaxColors do
FNames.Delete(i); FNames.Delete(i);
end; end;
function TmbColorPalette.GetMoveCellIndex(move: TMoveDirection): integer; function TmbColorPalette.GetMoveCellIndex(move: TMoveDirection): integer;
var var
FBefore: integer; FBefore: integer;
begin begin
Result := -1; Result := -1;
case move of case move of
mdLeft: mdLeft:
if FCheckedIndex -1 < 0 then if FCheckedIndex -1 < 0 then
Result := FTotalCells Result := FTotalCells
else else
Result := FCheckedIndex - 1; Result := FCheckedIndex - 1;
mdRight: mdRight:
if FCheckedIndex + 1 > FTotalCells then if FCheckedIndex + 1 > FTotalCells then
Result := 0 Result := 0
else else
Result := FCheckedIndex + 1; Result := FCheckedIndex + 1;
mdUp: mdUp:
if FCheckedIndex - FColCount < 0 then if FCheckedIndex - FColCount < 0 then
begin begin
FBefore := (FTotalcells div FColCount) * FColCount; FBefore := (FTotalcells div FColCount) * FColCount;
if FBefore + FCheckedIndex - 1 > FTotalCells then Dec(FBefore, FColCount); if FBefore + FCheckedIndex - 1 > FTotalCells then Dec(FBefore, FColCount);
Result := FBefore + FCheckedIndex - 1; Result := FBefore + FCheckedIndex - 1;
end end
else else
Result := FCheckedIndex - FColCount; Result := FCheckedIndex - FColCount;
mdDown: mdDown:
if FCheckedIndex + FColCount > FTotalCells then if FCheckedIndex + FColCount > FTotalCells then
Result := FCheckedIndex mod FColCount + 1 Result := FCheckedIndex mod FColCount + 1
else else
Result := FCheckedIndex + FColCount; Result := FCheckedIndex + FColCount;
end; end;
if Result > FColors.Count - 1 then if Result > FColors.Count - 1 then
Result := 0; Result := 0;
end; end;
procedure TmbColorPalette.CNKeyDown( procedure TmbColorPalette.CNKeyDown(
var Message: {$IFDEF DELPHI}TWMKeyDown{$ELSE}TLMKeyDown{$ENDIF} ); var Message: {$IFDEF DELPHI}TWMKeyDown{$ELSE}TLMKeyDown{$ENDIF} );
var var
FInherited: boolean; FInherited: boolean;
Shift: TShiftState; Shift: TShiftState;
begin begin
Shift := KeyDataToShiftState(Message.KeyData); Shift := KeyDataToShiftState(Message.KeyData);
Finherited := false; Finherited := false;
case Message.CharCode of case Message.CharCode of
VK_LEFT: VK_LEFT:
begin begin
FCheckedIndex := GetMoveCellIndex(mdLeft); FCheckedIndex := GetMoveCellIndex(mdLeft);
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift); if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
end; end;
VK_RIGHT: VK_RIGHT:
begin begin
FCheckedIndex := GetMoveCellIndex(mdRight); FCheckedIndex := GetMoveCellIndex(mdRight);
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift); if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
end; end;
VK_UP: VK_UP:
begin begin
FCheckedIndex := GetMoveCellIndex(mdUp); FCheckedIndex := GetMoveCellIndex(mdUp);
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift); if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
end; end;
VK_DOWN: VK_DOWN:
begin begin
FCheckedIndex := GetMoveCellIndex(mdDown); FCheckedIndex := GetMoveCellIndex(mdDown);
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift); if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
end; end;
VK_SPACE, VK_RETURN: if Assigned(FOnChange) then FOnChange(Self); VK_SPACE, VK_RETURN:
else if Assigned(FOnChange) then FOnChange(Self);
begin else
FInherited := true; begin
inherited; FInherited := true;
inherited;
end;
end; end;
end; if not FInherited then
if not FInherited then
begin begin
Invalidate; Invalidate;
if Assigned(OnKeyDown) then OnKeyDown(Self, Message.CharCode, Shift); if Assigned(OnKeyDown) then OnKeyDown(Self, Message.CharCode, Shift);
if Assigned(FOnChange) then FOnChange(Self); if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure TmbColorPalette.CMHintShow( procedure TmbColorPalette.CMHintShow(
var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} ); var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} );
var var
clr: TColor; clr: TColor;
Handled: boolean; Handled: boolean;
begin begin
if (Colors.Count > 0) and (FIndex > -1) then if (Colors.Count > 0) and (FIndex > -1) then
with TCMHintShow(Message) do with TCMHintShow(Message) do
begin begin
if not ShowHint then if not ShowHint then
Message.Result := 1 Message.Result := 1
else else
begin begin
with HintInfo^ do with HintInfo^ do
begin begin
// show that we want a hint // show that we want a hint
Result := 0; Result := 0;
ReshowTimeout := 1; ReshowTimeout := 1;
HideTimeout := 5000; HideTimeout := 5000;
clr := GetColorUnderCursor; clr := GetColorUnderCursor;
//fire event //fire event
Handled := false; Handled := false;
if Assigned(FOnGetHintText) then FOnGetHintText(clr, GetIndexUnderCursor, HintStr, Handled); if Assigned(FOnGetHintText) then
if Handled then Exit; FOnGetHintText(clr, GetIndexUnderCursor, HintStr, Handled);
//do default if Handled then Exit;
if FIndex < FNames.Count then //do default
HintStr := FNames.Strings[FIndex] if FIndex < FNames.Count then
else HintStr := FNames.Strings[FIndex]
if SameText(FColors.Strings[GetIndexUnderCursor], 'clCustom') or SameText(FColors.Strings[GetIndexUnderCursor], 'clTransparent') then
HintStr := StringReplace(FColors.Strings[GetIndexUnderCursor], 'cl', '', [rfReplaceAll])
else else
HintStr := FormatHint(FHintFormat, GetColorUnderCursor); if SameText(FColors.Strings[GetIndexUnderCursor], 'clCustom') or SameText(FColors.Strings[GetIndexUnderCursor], 'clTransparent') then
HintStr := StringReplace(FColors.Strings[GetIndexUnderCursor], 'cl', '', [rfReplaceAll])
else
HintStr := FormatHint(FHintFormat, GetColorUnderCursor);
end; end;
end; end;
end; end;
@ -987,181 +988,179 @@ end;
procedure TmbColorPalette.SetAutoHeight(auto: boolean); procedure TmbColorPalette.SetAutoHeight(auto: boolean);
begin begin
FAutoHeight := auto; FAutoHeight := auto;
CalcAutoHeight; CalcAutoHeight;
Invalidate; Invalidate;
end; end;
procedure TmbColorPalette.SetMinColors(m: integer); procedure TmbColorPalette.SetMinColors(m: integer);
var var
i: integer; i: integer;
begin begin
if (FMaxColors > 0) and (m > FMaxColors) then if (FMaxColors > 0) and (m > FMaxColors) then
m := FMaxColors; m := FMaxColors;
FMinColors := m; FMinColors := m;
if FColors.Count < m then if FColors.Count < m then
for i := 0 to m - FColors.Count - 1 do for i := 0 to m - FColors.Count - 1 do
FColors.Add('clNone'); FColors.Add('clNone');
CalcAutoHeight; CalcAutoHeight;
SortColors; SortColors;
Invalidate; Invalidate;
end; end;
procedure TmbColorPalette.SetMaxColors(m: integer); procedure TmbColorPalette.SetMaxColors(m: integer);
var var
i: integer; i: integer;
begin begin
if m < 0 then m := 0; if m < 0 then m := 0;
FMaxColors := m; FMaxColors := m;
if (m < FMinColors) and (m > 0) then if (m < FMinColors) and (m > 0) then
SetMinColors(m); SetMinColors(m);
if (FColors.Count > FMaxColors) and (FMaxColors > 0) then if (FColors.Count > FMaxColors) and (FMaxColors > 0) then
for i := FColors.Count - 1 downto FMaxColors do for i := FColors.Count - 1 downto FMaxColors do
FColors.Delete(i); FColors.Delete(i);
CalcAutoHeight; CalcAutoHeight;
SortColors; SortColors;
Invalidate; Invalidate;
end; end;
procedure TmbColorPalette.SetSortMode(s: TSortMode); procedure TmbColorPalette.SetSortMode(s: TSortMode);
begin begin
if FSort <> s then if FSort <> s then
begin begin
FSort := s; FSort := s;
SortColors; SortColors;
Invalidate; Invalidate;
end; end;
end; end;
procedure TmbColorPalette.SetSortOrder(s: TSortOrder); procedure TmbColorPalette.SetSortOrder(s: TSortOrder);
begin begin
if FOrder <> s then if FOrder <> s then
begin begin
FOrder := s; FOrder := s;
SortColors; SortColors;
Invalidate; Invalidate;
end; end;
end; end;
procedure TmbColorPalette.ColorsChange(Sender: TObject); procedure TmbColorPalette.ColorsChange(Sender: TObject);
begin begin
if Assigned(FOnColorsChange) then FOnColorsChange(Self); if Assigned(FOnColorsChange) then FOnColorsChange(Self);
FTotalCells := FColors.Count - 1; FTotalCells := FColors.Count - 1;
CalcAutoHeight; CalcAutoHeight;
Invalidate; Invalidate;
end; end;
procedure TmbColorPalette.SetCellSize(s: integer); procedure TmbColorPalette.SetCellSize(s: integer);
begin begin
FCellSize := s; FCellSize := s;
CalcAutoHeight; CalcAutoHeight;
Invalidate; Invalidate;
end; end;
function TmbColorPalette.GetSelectedCellRect: TRect; function TmbColorPalette.GetSelectedCellRect: TRect;
var var
row, fbottom, fleft: integer; row, fbottom, fleft: integer;
begin begin
if FCheckedIndex > -1 then if FCheckedIndex > -1 then
begin begin
if FCheckedIndex mod FColCount = 0 then if FCheckedIndex mod FColCount = 0 then
begin begin
row := FCheckedIndex div FColCount; row := FCheckedIndex div FColCount;
fleft := Width - FCellSize; fleft := Width - FCellSize;
end end
else else
begin begin
row := FCheckedIndex div FColCount + 1; row := FCheckedIndex div FColCount + 1;
fleft := (FCheckedIndex mod FColCount - 1) * FCellSize; fleft := (FCheckedIndex mod FColCount - 1) * FCellSize;
end; end;
fbottom := row * FCellSize; fbottom := row * FCellSize;
Result := Rect(fleft, fbottom - FCellSize, fleft + FCellSize, fbottom); Result := Rect(fleft, fbottom - FCellSize, fleft + FCellSize, fbottom);
end end
else else
Result := Rect(0, 0, 0, 0); Result := Rect(0, 0, 0, 0);
end; end;
procedure TmbColorPalette.GeneratePalette(BaseColor: TColor); procedure TmbColorPalette.GeneratePalette(BaseColor: TColor);
begin begin
FColors.Text := MakePalette(BaseColor, FOrder); FColors.Text := MakePalette(BaseColor, FOrder);
CalcAutoHeight; CalcAutoHeight;
SortColors; SortColors;
Invalidate; Invalidate;
if Assigned(FOnChange) then FOnChange(Self); if Assigned(FOnChange) then FOnChange(Self);
end; end;
procedure TmbColorPalette.GenerateGradientPalette(Colors: array of TColor); procedure TmbColorPalette.GenerateGradientPalette(Colors: array of TColor);
begin begin
FColors.Text := MakeGradientPalette(Colors); FColors.Text := MakeGradientPalette(Colors);
CalcAutoHeight; CalcAutoHeight;
SortColors; SortColors;
Invalidate; Invalidate;
if Assigned(FOnChange) then FOnChange(Self); if Assigned(FOnChange) then FOnChange(Self);
end; end;
procedure TmbColorPalette.LoadPalette(FileName: TFileName); procedure TmbColorPalette.LoadPalette(FileName: TFileName);
var var
supported: boolean; supported: boolean;
a: AcoColors; a: AcoColors;
i: integer; i: integer;
begin begin
supported := false; supported := false;
if SameText(ExtractFileExt(FileName), '.pal') then if SameText(ExtractFileExt(FileName), '.pal') then
begin begin
supported := true; supported := true;
FNames.Clear; FNames.Clear;
FColors.Text := ReadJASCPal(FileName); FColors.Text := ReadJASCPal(FileName);
end end
else else if SameText(ExtractFileExt(FileName), '.aco') then
if SameText(ExtractFileExt(FileName), '.aco') then begin
begin
supported := true; supported := true;
a := ReadPhotoshopAco(FileName); a := ReadPhotoshopAco(FileName);
FColors.Clear; FColors.Clear;
for i := 0 to Length(a.Colors) - 1 do for i := 0 to Length(a.Colors) - 1 do
FColors.Add(ColorToString(a.Colors[i])); FColors.Add(ColorToString(a.Colors[i]));
FNames.Clear; FNames.Clear;
if a.HasNames then if a.HasNames then
for i := 0 to Length(a.Names) - 1 do for i := 0 to Length(a.Names) - 1 do
FNames.Add(a.Names[i]); FNames.Add(a.Names[i]);
end end
else else if SameText(ExtractFileExt(FileName), '.act') then
if SameText(ExtractFileExt(FileName), '.act') then
begin
supported := true;
FNames.Clear;
FColors.Text := ReadPhotoshopAct(FileName);
end
else
Exception.Create('The file format you are trying to load is not supported in this version of the palette'#13'Please send a request to MXS along with the files of this format so'#13'loading support for this file can be added too');
if supported then
begin begin
CalcAutoHeight; supported := true;
SortColors; FNames.Clear;
Invalidate; FColors.Text := ReadPhotoshopAct(FileName);
if Assigned(FOnChange) then FOnChange(Self); end
else
raise Exception.Create('The file format you are trying to load is not supported in this version of the palette'#13'Please send a request to MXS along with the files of this format so'#13'loading support for this file can be added too');
if supported then
begin
CalcAutoHeight;
SortColors;
Invalidate;
if Assigned(FOnChange) then FOnChange(Self);
end; end;
end; end;
procedure TmbColorPalette.SaveColorsAsPalette(FileName: TFileName); procedure TmbColorPalette.SaveColorsAsPalette(FileName: TFileName);
begin begin
if SameText(ExtractFileExt(FileName), '.pal') then if SameText(ExtractFileExt(FileName), '.pal') then
SaveJASCPal(FColors, FileName) SaveJASCPal(FColors, FileName)
else else
raise Exception.Create('The file extension specified does not identify a supported file format!'#13'Supported files formats are: .pal .aco .act'); raise Exception.Create('The file extension specified does not identify a supported file format!'#13'Supported files formats are: .pal .aco .act');
end; end;
procedure TmbColorPalette.SortColors; procedure TmbColorPalette.SortColors;
var var
old: TColor; old: TColor;
begin begin
if FSort <> smNone then if FSort <> smNone then
begin begin
if FColors.Count = 0 then Exit; if FColors.Count = 0 then Exit;
old := GetSelColor; old := GetSelColor;
SortPalColors(FColors, FSort, FOrder); SortPalColors(FColors, FSort, FOrder);
SetSelColor(old); SetSelColor(old);
Invalidate; Invalidate;
end; end;
end; end;

331
components/mbColorLib/mbColorPreview.pas
View File

@ -17,60 +17,60 @@ uses
type type
TmbColorPreview = class(TCustomControl) TmbColorPreview = class(TCustomControl)
private private
FSelColor: TColor; FSelColor: TColor;
FOpacity: integer; FOpacity: integer;
FOnColorChange: TNotifyEvent; FOnColorChange: TNotifyEvent;
FOnOpacityChange: TNotifyEvent; FOnOpacityChange: TNotifyEvent;
FBlockSize: integer; FBlockSize: integer;
FSwatchStyle: boolean; FSwatchStyle: boolean;
procedure SetSwatchStyle(Value: boolean); procedure SetSwatchStyle(Value: boolean);
procedure SetSelColor(c: TColor); procedure SetSelColor(c: TColor);
procedure SetOpacity(o: integer); procedure SetOpacity(o: integer);
procedure SetBlockSize(s: integer); procedure SetBlockSize(s: integer);
function MakeBmp: TBitmap; function MakeBmp: TBitmap;
protected protected
procedure Paint; override; procedure Paint; override;
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF}; message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
published published
property Color: TColor read FSelColor write SetSelColor default clWhite; property Color: TColor read FSelColor write SetSelColor default clWhite;
property Opacity: integer read FOpacity write SetOpacity default 100; property Opacity: integer read FOpacity write SetOpacity default 100;
property BlockSize: integer read FBlockSize write SetBlockSize default 6; property BlockSize: integer read FBlockSize write SetBlockSize default 6;
property SwatchStyle: boolean read FSwatchStyle write SetSwatchStyle default false; property SwatchStyle: boolean read FSwatchStyle write SetSwatchStyle default false;
property Anchors; property Anchors;
property Align; property Align;
property ShowHint; property ShowHint;
property ParentShowHint; property ParentShowHint;
property Visible; property Visible;
property Enabled; property Enabled;
property PopupMenu; property PopupMenu;
property DragCursor; property DragCursor;
property DragMode; property DragMode;
property DragKind; property DragKind;
property Constraints; property Constraints;
property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange;
property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange; property OnOpacityChange: TNotifyEvent read FOnOpacityChange write FOnOpacityChange;
property OnOpacityChange: TNotifyEvent read FOnOpacityChange write FOnOpacityChange; property OnContextPopup;
property OnContextPopup; property OnMouseDown;
property OnMouseDown; property OnMouseMove;
property OnMouseMove; property OnMouseUp;
property OnMouseUp; property OnKeyDown;
property OnKeyDown; property OnKeyPress;
property OnKeyPress; property OnKeyUp;
property OnKeyUp; property OnDragDrop;
property OnDragDrop; property OnDragOver;
property OnDragOver; property OnEndDrag;
property OnEndDrag; property OnEnter;
property OnEnter; property OnExit;
property OnExit; property OnResize;
property OnResize; property OnStartDrag;
property OnStartDrag; property OnDblClick;
property OnDblClick;
end; end;
implementation implementation
uses uses
@ -80,162 +80,161 @@ uses
constructor TmbColorPreview.Create(AOwner: TComponent); constructor TmbColorPreview.Create(AOwner: TComponent);
begin begin
inherited; inherited;
DoubleBuffered := true; DoubleBuffered := true;
ControlStyle := COntrolStyle - [csAcceptsControls] + [csOpaque]; ControlStyle := COntrolStyle - [csAcceptsControls] + [csOpaque];
FSelColor := clWhite; FSelColor := clWhite;
Width := 68; SetInitialBounds(0, 0, 68, 32);
Height := 32; TabStop := false;
TabStop := false; FOpacity := 100;
FOpacity := 100; FBlockSize := 6;
FBlockSize := 6; FSwatchStyle := false;
FSwatchStyle := false;
end; end;
function TmbColorPreview.MakeBmp: TBitmap; function TmbColorPreview.MakeBmp: TBitmap;
begin begin
Result := TBitmap.Create; Result := TBitmap.Create;
Result.Width := FBlockSize; Result.Width := FBlockSize;
Result.Height := FBlockSize; Result.Height := FBlockSize;
if (FSelColor = clNone) or (FOpacity = 0) then if (FSelColor = clNone) or (FOpacity = 0) then
Result.Canvas.Brush.Color := clSilver Result.Canvas.Brush.Color := clSilver
else else
Result.Canvas.Brush.Color := Blend(FSelColor, clSilver, FOpacity); Result.Canvas.Brush.Color := Blend(FSelColor, clSilver, FOpacity);
Result.Canvas.FillRect(Result.Canvas.ClipRect); Result.Canvas.FillRect(Result.Canvas.ClipRect);
end; end;
procedure TmbColorPreview.Paint; procedure TmbColorPreview.Paint;
var var
TempBMP, cBMP: TBitmap; TempBMP, cBMP: TBitmap;
i, j: integer; i, j: integer;
R: TRect; R: TRect;
rgn: HRgn; rgn: HRgn;
c: TColor; c: TColor;
begin begin
TempBMP := TBitmap.Create; TempBMP := TBitmap.Create;
cBMP := nil; cBMP := nil;
rgn := 0; rgn := 0;
try try
TempBMP.Width := Width + FBlockSize; TempBMP.Width := Width + FBlockSize;
TempBMP.Height := Height + FBlockSize; TempBMP.Height := Height + FBlockSize;
TempBMP.PixelFormat := pf24bit; TempBMP.PixelFormat := pf24bit;
TempBmp.Canvas.Pen.Color := clBtnShadow; TempBmp.Canvas.Pen.Color := clBtnShadow;
TempBmp.Canvas.Brush.Color := FSelColor; TempBmp.Canvas.Brush.Color := FSelColor;
R := ClientRect; R := ClientRect;
with TempBmp.Canvas do with TempBmp.Canvas do
if (FSelColor <> clNone) and (FOpacity = 100) then if (FSelColor <> clNone) and (FOpacity = 100) then
begin
if not FSwatchStyle then
Rectangle(R)
else
begin begin
Brush.Color := clWindow; if not FSwatchStyle then
Rectangle(R); Rectangle(R)
InflateRect(R, -1, -1);
FillRect(R);
InflateRect(R, 1, 1);
InflateRect(R, -2, -2);
Brush.Color := Blend(FSelColor, clBlack, 75);
FillRect(R);
InflateRect(R, -1, -1);
Brush.Color := Blend(FSelColor, clBlack, 87);
FillRect(R);
InflateRect(R, -1, -1);
Brush.Color := FSelColor;
FillRect(R);
end;
end
else
begin
cBMP := MakeBmp;
if (FSelColor = clNone) or (FOpacity = 0) then
c := clWhite
else
c := Blend(FSelColor, clWhite, FOpacity);
Brush.Color := c;
Rectangle(R);
if FSwatchStyle then
begin
InflateRect(R, -1, -1);
FillRect(R);
InflateRect(R, 1, 1);
InflateRect(R, -2, -2);
Brush.Color := Blend(c, clBlack, 75);
FillRect(R);
InflateRect(R, -1, -1);
Brush.Color := Blend(c, clBlack, 87);
FillRect(R);
InflateRect(R, -1, -1);
Brush.Color := c;
FillRect(R);
end;
InflateRect(R, -1, -1);
rgn := CreateRectRgnIndirect(R);
SelectClipRgn(TempBmp.Canvas.Handle, rgn);
for i := 0 to (Height div FBlockSize) do
for j := 0 to (Width div FBlockSize) do
begin
if i mod 2 = 0 then
begin
if j mod 2 > 0 then
TempBmp.Canvas.Draw(j*FBlockSize, i*FBlockSize, cBMP);
end
else else
begin begin
if j mod 2 = 0 then Brush.Color := clWindow;
TempBmp.Canvas.Draw(j*FBlockSize, i*FBlockSize, cBMP); Rectangle(R);
end; InflateRect(R, -1, -1);
end; FillRect(R);
end; InflateRect(R, 1, 1);
Canvas.Draw(0, 0, TempBmp); InflateRect(R, -2, -2);
finally Brush.Color := Blend(FSelColor, clBlack, 75);
DeleteObject(rgn); FillRect(R);
cBMP.Free; InflateRect(R, -1, -1);
TempBMP.Free; Brush.Color := Blend(FSelColor, clBlack, 87);
end; FillRect(R);
InflateRect(R, -1, -1);
Brush.Color := FSelColor;
FillRect(R);
end;
end
else
begin
cBMP := MakeBmp;
if (FSelColor = clNone) or (FOpacity = 0) then
c := clWhite
else
c := Blend(FSelColor, clWhite, FOpacity);
Brush.Color := c;
Rectangle(R);
if FSwatchStyle then
begin
InflateRect(R, -1, -1);
FillRect(R);
InflateRect(R, 1, 1);
InflateRect(R, -2, -2);
Brush.Color := Blend(c, clBlack, 75);
FillRect(R);
InflateRect(R, -1, -1);
Brush.Color := Blend(c, clBlack, 87);
FillRect(R);
InflateRect(R, -1, -1);
Brush.Color := c;
FillRect(R);
end;
InflateRect(R, -1, -1);
rgn := CreateRectRgnIndirect(R);
SelectClipRgn(TempBmp.Canvas.Handle, rgn);
for i := 0 to (Height div FBlockSize) do
for j := 0 to (Width div FBlockSize) do
begin
if i mod 2 = 0 then
begin
if j mod 2 > 0 then
TempBmp.Canvas.Draw(j*FBlockSize, i*FBlockSize, cBMP);
end
else
begin
if j mod 2 = 0 then
TempBmp.Canvas.Draw(j*FBlockSize, i*FBlockSize, cBMP);
end;
end;
end;
Canvas.Draw(0, 0, TempBmp);
finally
DeleteObject(rgn);
cBMP.Free;
TempBMP.Free;
end;
end; end;
procedure TmbColorPreview.WMEraseBkgnd( procedure TmbColorPreview.WMEraseBkgnd(
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF}); var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
begin begin
Message.Result := 1; Message.Result := 1;
end; end;
procedure TmbColorPreview.SetSelColor(c: TColor); procedure TmbColorPreview.SetSelColor(c: TColor);
begin begin
if c <> FSelColor then if c <> FSelColor then
begin begin
FSelColor := c; FSelColor := c;
Invalidate; Invalidate;
if Assigned(FOnColorChange) then FOnColorChange(Self); if Assigned(FOnColorChange) then FOnColorChange(Self);
end; end;
end; end;
procedure TmbColorPreview.SetOpacity(o: integer); procedure TmbColorPreview.SetOpacity(o: integer);
begin begin
if FOpacity <> o then if FOpacity <> o then
begin begin
FOpacity := o; FOpacity := o;
Invalidate; Invalidate;
if Assigned(FOnOpacityChange) then FOnOpacityChange(Self); if Assigned(FOnOpacityChange) then FOnOpacityChange(Self);
end; end;
end; end;
procedure TmbColorPreview.SetBlockSize(s: integer); procedure TmbColorPreview.SetBlockSize(s: integer);
begin begin
if (FBlockSize <> s) and (s > 0) then if (FBlockSize <> s) and (s > 0) then
begin begin
FBlockSize := s; FBlockSize := s;
Invalidate; Invalidate;
end; end;
end; end;
procedure TmbColorPreview.SetSwatchStyle(Value: boolean); procedure TmbColorPreview.SetSwatchStyle(Value: boolean);
begin begin
if FSwatchStyle <> Value then if FSwatchStyle <> Value then
begin begin
FSwatchStyle := Value; FSwatchStyle := Value;
Invalidate; Invalidate;
end; end;
end; end;

691
components/mbColorLib/mbColorTree.pas
View File

@ -25,8 +25,8 @@ type
{$ENDIF} {$ENDIF}
TmbColor = record TmbColor = record
name: string; Name: string;
value: TColor; Value: TColor;
end; end;
TDrawCaptionEvent = procedure (Sender: TObject; AIndex: integer; AFont: TFont; var AText: string; Selected: boolean) of object; TDrawCaptionEvent = procedure (Sender: TObject; AIndex: integer; AFont: TFont; var AText: string; Selected: boolean) of object;
@ -35,128 +35,124 @@ type
TmbColorTree = class(TCustomTreeView) TmbColorTree = class(TCustomTreeView)
private private
dummy: TCustomImageList; FInfo1, FInfo2: string;
FInfo1, FInfo2: string; FInfoLabel: string;
FInfoLabel: string; FDraw: TDrawCaptionEvent;
FDraw: TDrawCaptionEvent; FDraw1, FDraw2, FDraw3: TDrawLabelEvent;
FDraw1, FDraw2, FDraw3: TDrawLabelEvent; mx, my: integer;
mx, my: integer; FGetHint: TGetHintEvent;
FGetHint: TGetHintEvent; FOnStartDrag: TStartDragEvent;
FOnStartDrag: TStartDragEvent; FOnEndDrag: TEndDragEvent;
FOnEndDrag: TEndDragEvent; procedure SetInfo1(Value: string);
procedure SetInfo1(Value: string); procedure SetInfo2(Value: string);
procedure SetInfo2(Value: string); procedure SetInfoLabel(Value: string);
procedure SetInfoLabel(Value: string);
protected protected
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW; procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
function CustomDrawItem(Node: TTreeNode; State: TCustomDrawState; function CustomDrawItem(Node: TTreeNode; State: TCustomDrawState;
Stage: TCustomDrawStage; var PaintImages: Boolean): Boolean; override; Stage: TCustomDrawStage; var PaintImages: Boolean): Boolean; override;
function IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean; {$IFDEF DELPHI_7_UP}override;{$ENDIF} function IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean; {$IFDEF DELPHI_7_UP}override;{$ENDIF}
procedure DrawColorItem(R: TRect; Selected: boolean; Index: integer; itemText: string; Expanded: boolean); dynamic; procedure DrawColorItem(R: TRect; Selected: boolean; Index: integer; itemText: string; Expanded: boolean); dynamic;
procedure DrawInfoItem(R: TRect; Index: integer); dynamic; procedure DrawInfoItem(R: TRect; Index: integer); dynamic;
procedure DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean); procedure DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean);
public public
Colors: array of TmbColor; Colors: array of TmbColor;
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; procedure UpdateColors;
procedure AddColor(AName: string; AValue: TColor; ARefresh: boolean = true);
procedure UpdateColors; procedure ClearColors;
procedure AddColor(Name: string; Value: TColor; refresh: boolean = true); procedure DeleteColor(AIndex: integer; ARefresh: boolean = true);
procedure ClearColors; procedure DeleteColorByName(AName: string; All: boolean);
procedure DeleteColor(Index: integer; refresh: boolean = true); procedure DeleteColorByValue(AValue: TColor; All: boolean);
procedure DeleteColorByName(Name: string; All: boolean); procedure InsertColor(AIndex: integer; AName: string; AValue: TColor);
procedure DeleteColorByValue(Value: TColor; All: boolean); function ColorCount: integer;
procedure InsertColor(Index: integer; Name: string; Value: TColor);
function ColorCount: integer;
published published
property InfoLabelText: string read FInfoLabel write SetInfoLabel; property InfoLabelText: string read FInfoLabel write SetInfoLabel;
property InfoDisplay1: string read FInfo1 write SetInfo1; property InfoDisplay1: string read FInfo1 write SetInfo1;
property InfoDisplay2: string read FInfo2 write SetInfo2; property InfoDisplay2: string read FInfo2 write SetInfo2;
property Align; property Align;
property Anchors; property Anchors;
property AutoExpand; property AutoExpand;
{$IFDEF DELPHI} {$IFDEF DELPHI}
property BevelEdges; property BevelEdges;
property BevelInner; property BevelInner;
property BevelOuter; property BevelOuter;
property BevelKind default bkNone; property BevelKind default bkNone;
property BevelWidth; property BevelWidth;
{$ENDIF} {$ENDIF}
property BorderStyle; property BorderStyle;
property BorderWidth; property BorderWidth;
{$IFDEF DELPHI} {$IFDEF DELPHI}
property ChangeDelay; property ChangeDelay;
property Ctl3D; property Ctl3D;
property ParentCtl3D; property ParentCtl3D;
{$ENDIF} {$ENDIF}
property Constraints; property Constraints;
property Color; property Color;
property DragKind; property DragKind;
property DragCursor; property DragCursor;
property DragMode; property DragMode;
property Enabled; property Enabled;
property Font; property Font;
property Indent; property Indent;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI_7_UP}
property MultiSelect; property MultiSelect;
property MultiSelectStyle; property MultiSelectStyle;
{$ENDIF} {$ENDIF}
property ParentColor default False; property ParentColor default False;
property ParentFont; property ParentFont;
property ParentShowHint; property ParentShowHint;
property PopupMenu; property PopupMenu;
property RightClickSelect; property RightClickSelect;
property ShowHint; property ShowHint;
property SortType; property SortType;
property TabOrder; property TabOrder;
property TabStop default True; property TabStop default True;
property ToolTips; property ToolTips;
property Visible; property Visible;
property OnGetHint: TGetHintEvent read FGetHint write FGetHint;
property OnGetHint: TGetHintEvent read FGetHint write FGetHint; property OnDrawCaption: TDrawCaptionEvent read FDraw write FDraw;
property OnDrawCaption: TDrawCaptionEvent read FDraw write FDraw; property OnDrawInfoLabel: TDrawLabelEvent read FDraw1 write FDraw1;
property OnDrawInfoLabel: TDrawLabelEvent read FDraw1 write FDraw1; property OnDrawInfoDisplay1: TDrawLabelEvent read FDraw2 write FDraw2;
property OnDrawInfoDisplay1: TDrawLabelEvent read FDraw2 write FDraw2; property OnDrawInfoDisplay2: TDrawLabelEvent read FDraw3 write FDraw3;
property OnDrawInfoDisplay2: TDrawLabelEvent read FDraw3 write FDraw3;
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI_7_UP}
property OnAddition; property OnAddition;
property OnCreateNodeClass; property OnCreateNodeClass;
{$ENDIF} {$ENDIF}
property OnAdvancedCustomDraw; property OnAdvancedCustomDraw;
property OnAdvancedCustomDrawItem; property OnAdvancedCustomDrawItem;
property OnChange; property OnChange;
property OnChanging; property OnChanging;
property OnClick; property OnClick;
property OnCollapsed; property OnCollapsed;
property OnCollapsing; property OnCollapsing;
property OnCompare; property OnCompare;
property OnContextPopup; property OnContextPopup;
property OnCustomDraw; property OnCustomDraw;
property OnCustomDrawItem; property OnCustomDrawItem;
property OnDblClick; property OnDblClick;
property OnDeletion; property OnDeletion;
property OnDragDrop; property OnDragDrop;
property OnDragOver; property OnDragOver;
property OnEndDock; property OnEndDock;
property OnEndDrag: TEndDragEvent read FOnEndDrag write FOnEndDrag; property OnEndDrag: TEndDragEvent read FOnEndDrag write FOnEndDrag;
property OnEnter; property OnEnter;
property OnExit; property OnExit;
property OnExpanding; property OnExpanding;
property OnExpanded; property OnExpanded;
property OnKeyDown; property OnKeyDown;
property OnKeyPress; property OnKeyPress;
property OnKeyUp; property OnKeyUp;
property OnMouseDown; property OnMouseDown;
property OnMouseMove; property OnMouseMove;
property OnMouseUp; property OnMouseUp;
property OnStartDock; property OnStartDock;
property OnStartDrag: TStartDragEvent read FOnStartDrag write FOnStartDrag; property OnStartDrag: TStartDragEvent read FOnStartDrag write FOnStartDrag;
property Items; property Items;
end; end;
implementation implementation
@ -203,96 +199,86 @@ end;
constructor TmbColorTree.Create(AOwner: TComponent); constructor TmbColorTree.Create(AOwner: TComponent);
begin begin
inherited; inherited;
ControlStyle := ControlStyle + [csDisplayDragImage]; ControlStyle := ControlStyle + [csDisplayDragImage];
MaxHue := 360; {
MaxSat := 255; MaxHue := 360;
MaxLum := 255; MaxSat := 255;
ReadOnly := true; MaxLum := 255;
ShowButtons := false; }
ShowLines := false; ReadOnly := true;
ShowRoot := true; ShowButtons := false;
RowSelect := true; ShowLines := false;
HotTrack := false; ShowRoot := true;
SetLength(Colors, 0); RowSelect := true;
Images := TImageList.Create(Self); HotTrack := false;
Images.Width := 48; SetLength(Colors, 0);
Images.Height := 48; Images := TImageList.Create(Self);
{ Images.Width := 48;
dummy := TCustomImageList.Create(Self); Images.Height := 48;
dummy.Width := 48; FInfoLabel := 'Color Values:';
dummy.Height := 48; FInfo1 := 'RGB: %r.%g.%b';
Images := dummy; FInfo2 := 'HEX: #%hex';
}
FInfoLabel := 'Color Values:';
FInfo1 := 'RGB: %r.%g.%b';
FInfo2 := 'HEX: #%hex';
end;
destructor TmbColorTree.Destroy;
begin
dummy.Free;
inherited;
end; end;
procedure TmbColorTree.UpdateColors; procedure TmbColorTree.UpdateColors;
var var
i: integer; i: integer;
n: TTreeNode; n: TTreeNode;
begin begin
Items.Clear; Items.Clear;
for i := 0 to Length(Colors) - 1 do for i := 0 to Length(Colors) - 1 do
begin begin
n := Items.Add(TopItem, Colors[i].name); n := Items.Add(TopItem, Colors[i].name);
Items.AddChild(n, ''); Items.AddChild(n, '');
end; end;
end; end;
procedure TmbColorTree.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure TmbColorTree.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var var
r: TRect; r: TRect;
begin begin
inherited; inherited;
if (ssShift in Shift) or (ssCtrl in Shift) then Exit; if (ssShift in Shift) or (ssCtrl in Shift) then Exit;
if Selected <> nil then if Selected <> nil then
r := Selected.DisplayRect(false) r := Selected.DisplayRect(false)
else else
Exit; exit;
if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then
if (Selected.HasChildren) and PtInRect(r, Point(x, y)) then if (Selected.HasChildren) and PtInRect(r, Point(x, y)) then
begin begin
if selected.Expanded then if selected.Expanded then
Selected.Collapse(false) Selected.Collapse(false)
else else
Selected.Expand(false); Selected.Expand(false);
Invalidate; Invalidate;
end; end;
end; end;
procedure TmbColorTree.MouseMove(Shift: TShiftState; X, Y: Integer); procedure TmbColorTree.MouseMove(Shift: TShiftState; X, Y: Integer);
var var
r: TRect; r: TRect;
begin begin
inherited; inherited;
mx := x; mx := x;
my := y; my := y;
if GetNodeAt(x, y) <> nil then if GetNodeAt(x, y) <> nil then
r := GetNodeAt(x, y).DisplayRect(false) r := GetNodeAt(x, y).DisplayRect(false)
else else
begin begin
Cursor := crDefault; Cursor := crDefault;
Exit; exit;
end; end;
if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then
begin begin
if (GetNodeAt(x, y).HasChildren) and PtInRect(r, Point(x, y)) then if (GetNodeAt(x, y).HasChildren) and PtInRect(r, Point(x, y)) then
Cursor := crHandPoint Cursor := crHandPoint
else else
Cursor := crDefault; Cursor := crDefault;
end end
else else
Cursor := crDefault; Cursor := crDefault;
end; end;
function TmbColorTree.CustomDrawItem(Node: TTreeNode; State: TCustomDrawState; function TmbColorTree.CustomDrawItem(Node: TTreeNode; State: TCustomDrawState;
@ -306,38 +292,40 @@ begin
DrawInfoItem(Node.DisplayRect(false), node.Parent.Index); DrawInfoItem(Node.DisplayRect(false), node.Parent.Index);
end; end;
procedure TmbColorTree.DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean); procedure TmbColorTree.DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint;
sel: boolean);
var var
b: TBitmap; b: TBitmap;
begin begin
b := TBitmap.Create; b := TBitmap.Create;
try try
b.Height := 12; b.Height := 12;
b.Width := 12; b.Width := 12;
if Sel then if Sel then
begin begin
b.Canvas.Brush.Color := clHighlight; b.Canvas.Brush.Color := clHighlight;
b.Canvas.Pen.Color := clHighlightText; b.Canvas.Pen.Color := clHighlightText;
end end
else else
begin begin
b.Canvas.Brush.Color := clFuchsia; b.Canvas.Brush.Color := clFuchsia;
b.Canvas.Pen.Color := clWindowText; b.Canvas.Pen.Color := clWindowText;
b.Transparent := true; b.Transparent := true;
b.TransparentColor := clFuchsia; b.TransparentColor := clFuchsia;
end; end;
b.Canvas.FillRect(B.Canvas.ClipRect); b.Canvas.FillRect(B.Canvas.ClipRect);
case dir of case dir of
sdDown: DrawArrow(b.Canvas, dir, Point(2, 3), 3); sdDown : DrawArrow(b.Canvas, dir, Point(2, 3), 3);
sdRight: DrawArrow(b.Canvas, dir, Point(1, 2), 3); sdRight : DrawArrow(b.Canvas, dir, Point(1, 2), 3);
end;
c.Draw(p.x, p.y, b);
finally
b.Free;
end; end;
c.Draw(p.x, p.y, b);
finally
b.Free;
end;
end; end;
procedure TmbColorTree.DrawColorItem(R: TRect; Selected: boolean; Index: integer; itemText: string; Expanded: boolean); procedure TmbColorTree.DrawColorItem(R: TRect; Selected: boolean; Index: integer;
itemText: string; Expanded: boolean);
var var
SR, TR: TRect; SR, TR: TRect;
begin begin
@ -457,224 +445,217 @@ const
FLAGS = DT_LEFT or DT_END_ELLIPSIS or DT_NOCLIP; FLAGS = DT_LEFT or DT_END_ELLIPSIS or DT_NOCLIP;
DELTA = 2; DELTA = 2;
var var
b: TBitmap; b: TBitmap;
BR, TR: TRect; BR, TR: TRect;
i, fx: integer; i, fx: integer;
s: string; s: string;
h: Integer; h: Integer;
begin begin
b := TBitmap.Create; b := TBitmap.Create;
try try
b.Width := R.Right - R.Left; b.Width := R.Right - R.Left;
b.Height := R.Bottom - R.Top; b.Height := R.Bottom - R.Top;
BR := b.Canvas.ClipRect; BR := b.Canvas.ClipRect;
with b.Canvas do with b.Canvas do
begin begin
Canvas.Font.Assign(Self.Font); Canvas.Font.Assign(Self.Font);
Brush.Color := Blend(clBtnFace, clWindow, 30); Brush.Color := Blend(clBtnFace, clWindow, 30);
FillRect(BR); FillRect(BR);
BR := Rect(BR.Left + 42, BR.Top, BR.Right, BR.Bottom); BR := Rect(BR.Left + 42, BR.Top, BR.Right, BR.Bottom);
Brush.Color := clWindow; Brush.Color := clWindow;
FillRect(BR); FillRect(BR);
Inc(BR.Left, 6); Inc(BR.Left, 6);
Font.Style := []; Font.Style := [];
Font.Size := 7; Font.Size := 7;
s := FInfoLabel; s := FInfoLabel;
h := TextHeight(s); h := TextHeight(s);
TR := Rect(BR.Left, BR.Top{ + 2}, BR.Right, BR.Top + {2 + }h + DELTA); TR := Rect(BR.Left, BR.Top{ + 2}, BR.Right, BR.Top + {2 + }h + DELTA);
if Assigned(FDraw1) then FDraw1(Self, Index, Canvas.Font, s); if Assigned(FDraw1) then FDraw1(Self, Index, Canvas.Font, s);
DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, FLAGS); DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, FLAGS);
DrawHorDottedLine(b.Canvas, BR.Left, BR.Right, TR.Bottom + DELTA, clGray); DrawHorDottedLine(b.Canvas, BR.Left, BR.Right, TR.Bottom + DELTA, clGray);
s := FormatHint(FInfo1, Self.Colors[Index].value); s := FormatHint(FInfo1, Self.Colors[Index].value);
TR.Top := TR.Bottom + 2 * DELTA; TR.Top := TR.Bottom + 2 * DELTA;
TR.Bottom := TR.Top + h + DELTA; TR.Bottom := TR.Top + h + DELTA;
if Assigned(FDraw2) then FDraw2(Self, Index, Canvas.Font, s); if Assigned(FDraw2) then FDraw2(Self, Index, Canvas.Font, s);
DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, FLAGS); DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, FLAGS);
DrawHorDottedLine(b.Canvas, BR.LEft, BR.Right, TR.Bottom + DELTA, clGray); DrawHorDottedLine(b.Canvas, BR.LEft, BR.Right, TR.Bottom + DELTA, clGray);
s := FormatHint(FInfo2, Self.Colors[Index].value); s := FormatHint(FInfo2, Self.Colors[Index].value);
TR.Top := TR.Bottom + 2 * DELTA; TR.Top := TR.Bottom + 2 * DELTA;
TR.Bottom := TR.Top + h + DELTA; TR.Bottom := TR.Top + h + DELTA;
if Assigned(FDraw3) then FDraw3(Self, Index, Canvas.Font, s); if Assigned(FDraw3) then FDraw3(Self, Index, Canvas.Font, s);
DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, FLAGS); DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, FLAGS);
end; end;
Canvas.Draw(R.Left, R.Top, b); Canvas.Draw(R.Left, R.Top, b);
finally finally
b.Free; b.Free;
end; end;
end; end;
function TmbColorTree.IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean; function TmbColorTree.IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean;
begin begin
Result := true; Result := true;
end; end;
procedure TmbColorTree.SetInfoLabel(Value: string); procedure TmbColorTree.SetInfoLabel(Value: string);
begin begin
if FInfoLabel <> Value then if FInfoLabel <> Value then
begin begin
FInfoLabel := Value; FInfoLabel := Value;
Invalidate; Invalidate;
end; end;
end; end;
procedure TmbColorTree.SetInfo1(Value: string); procedure TmbColorTree.SetInfo1(Value: string);
begin begin
if FInfo1 <> Value then if FInfo1 <> Value then
begin begin
FInfo1 := Value; FInfo1 := Value;
Invalidate; Invalidate;
end; end;
end; end;
procedure TmbColorTree.SetInfo2(Value: string); procedure TmbColorTree.SetInfo2(Value: string);
begin begin
if FInfo2 <> Value then if FInfo2 <> Value then
begin begin
FInfo2 := Value; FInfo2 := Value;
Invalidate; Invalidate;
end; end;
end; end;
procedure TmbColorTree.AddColor(Name: string; Value: TColor; refresh: boolean = true); procedure TmbColorTree.AddColor(AName: string; AValue: TColor;
ARefresh: boolean = true);
var var
L: integer; L: integer;
begin begin
L := Length(Colors); L := Length(Colors);
SetLength(Colors, L + 1); SetLength(Colors, L + 1);
Colors[L].name := Name; Colors[L].Name := AName;
Colors[L].value := Value; Colors[L].Value := AValue;
if refresh then if ARefresh then
UpdateColors; UpdateColors;
end; end;
procedure TmbColorTree.ClearColors; procedure TmbColorTree.ClearColors;
begin begin
SetLength(Colors, 0); SetLength(Colors, 0);
UpdateColors; UpdateColors;
end; end;
function TmbColorTree.ColorCount: integer; function TmbColorTree.ColorCount: integer;
begin begin
Result := Length(Colors); Result := Length(Colors);
end; end;
procedure TmbColorTree.DeleteColor(Index: integer; refresh: boolean = true); procedure TmbColorTree.DeleteColor(AIndex: integer; ARefresh: boolean = true);
var var
i: integer; i: integer;
begin begin
if Length(Colors) = 0 then if Length(Colors) = 0 then
begin
raise Exception.Create('There''s nothing to delete! The length of the array is 0.'); raise Exception.Create('There''s nothing to delete! The length of the array is 0.');
Exit;
end;
if Index > Length(Colors) - 1 then if AIndex > Length(Colors) - 1 then
raise Exception.Create(Format('List index out of bounds (%d)', [AIndex]));
for i := AIndex to Length(Colors) - 2 do
Colors[i] := Colors[i+1];
SetLength(Colors, Length(Colors) - 1);
if ARefresh then
UpdateColors;
end;
procedure TmbColorTree.DeleteColorByName(AName: string; All: boolean);
var
i: integer;
begin
for i := Length(Colors) - 1 downto 0 do
if SameText(Colors[i].Name, AName) then
begin begin
raise Exception.Create(Format('List index out of bounds (%d)', [Index])); DeleteColor(i, false);
Exit; if not All then
begin
UpdateColors;
Exit;
end;
end; end;
for i := Index to Length(Colors) - 2 do
Colors[i] := Colors[i+1];
SetLength(Colors, Length(Colors) - 1);
if refresh then
UpdateColors; UpdateColors;
end; end;
procedure TmbColorTree.DeleteColorByName(Name: string; All: boolean); procedure TmbColorTree.DeleteColorByValue(AValue: TColor; All: boolean);
var var
i: integer; i: integer;
begin begin
for i := Length(Colors) - 1 downto 0 do for i := Length(Colors) - 1 downto 0 do
if SameText(Colors[i].name, Name) then if Colors[i].Value = AValue then
begin begin
DeleteColor(i, false); DeleteColor(i, false);
if not All then if not All then
begin begin
UpdateColors; UpdateColors;
Exit; Exit;
end; end;
end; end;
UpdateColors; UpdateColors;
end; end;
procedure TmbColorTree.DeleteColorByValue(Value: TColor; All: boolean); procedure TmbColorTree.InsertColor(AIndex: integer; AName: string; AValue: TColor);
var var
i: integer; i: integer;
begin begin
for i := Length(Colors) - 1 downto 0 do if AIndex > Length(Colors) - 1 then
if Colors[i].Value = Value then raise Exception.Create(Format('List index out of bounds (%d)', [AIndex]));
begin
DeleteColor(i, false);
if not All then
begin
UpdateColors;
Exit;
end;
end;
UpdateColors;
end;
procedure TmbColorTree.InsertColor(Index: integer; Name: string; Value: TColor); SetLength(Colors, Length(Colors) + 1);
var for i := Length(Colors) - 1 downto AIndex do
i: integer; Colors[i] := Colors[i-1];
begin
if Index > Length(Colors) - 1 then
begin
raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
Exit;
end;
SetLength(Colors, Length(Colors) + 1); Colors[AIndex].Name := AName;
for i := Length(Colors) - 1 downto Index do Colors[AIndex].Value := AValue;
Colors[i] := Colors[i-1];
Colors[Index].Name := Name; UpdateColors;
Colors[Index].Value := Value;
UpdateColors;
end; end;
procedure TmbColorTree.CMHintShow(var Message: TCMHintShow); procedure TmbColorTree.CMHintShow(var Message: TCMHintShow);
var var
Handled: boolean; Handled: boolean;
i: integer; i: integer;
n: TTreeNode; n: TTreeNode;
begin begin
if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then
begin begin
n := GetNodeAt(mx, my); n := GetNodeAt(mx, my);
if n <> nil then if n <> nil then
begin begin
if not n.HasChildren then if not n.HasChildren then
i := n.Parent.Index i := n.Parent.Index
else else
i := n.Index; i := n.Index;
with TCMHintShow(Message) do with TCMHintShow(Message) do
if not ShowHint then if not ShowHint then
Message.Result := 1 Message.Result := 1
else
with HintInfo^ do
begin
Result := 0;
ReshowTimeout := 2000;
HideTimeout := 1000;
Handled := false;
if Assigned(FGetHint) then FGetHint(i, HintStr, Handled);
if Handled then
HintStr := FormatHint(HintStr, Colors[i].Value)
else else
HintStr := Colors[i].Name; with HintInfo^ do
end; begin
end; Result := 0;
end; ReshowTimeout := 2000;
inherited; HideTimeout := 1000;
Handled := false;
if Assigned(FGetHint) then
FGetHint(i, HintStr, Handled);
if Handled then
HintStr := FormatHint(HintStr, Colors[i].Value)
else
HintStr := Colors[i].Name;
end;
end;
end;
inherited;
end; end;
end. end.

42
components/mbColorLib/mbDeskPickerButton.pas
View File

@ -49,33 +49,33 @@ implementation
constructor TmbDeskPickerButton.Create(AOwner: TComponent); constructor TmbDeskPickerButton.Create(AOwner: TComponent);
begin begin
inherited; inherited;
DoubleBuffered := true; // DoubleBuffered := true;
// ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}]; // ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}];
FHintFmt := 'RGB(%r, %g, %b)'#13'Hex: %h'; FHintFmt := 'RGB(%r, %g, %b)'#13'Hex: %h';
FShowScreenHint := false; FShowScreenHint := false;
end; end;
procedure TmbDeskPickerButton.Click; procedure TmbDeskPickerButton.Click;
begin begin
inherited; inherited;
StartPicking; StartPicking;
end; end;
procedure TmbDeskPickerButton.StartPicking; procedure TmbDeskPickerButton.StartPicking;
begin begin
ScreenFrm := TScreenForm.Create(Application); ScreenFrm := TScreenForm.Create(Application);
try try
ScreenFrm.OnSelColorChange := ColorPicked; ScreenFrm.OnSelColorChange := ColorPicked;
ScreenFrm.OnScreenKeyDown := ScreenKeyDown; ScreenFrm.OnScreenKeyDown := ScreenKeyDown;
ScreenFrm.OnMouseWheelDown := WheelDown; ScreenFrm.OnMouseWheelDown := WheelDown;
ScreenFrm.OnMouseWheelUp := WheelUp; ScreenFrm.OnMouseWheelUp := WheelUp;
ScreenFrm.ShowHint := FShowScreenHint; ScreenFrm.ShowHint := FShowScreenHint;
ScreenFrm.FHintFormat := FHintFmt; ScreenFrm.FHintFormat := FHintFmt;
ScreenFrm.ShowModal; ScreenFrm.ShowModal;
finally finally
ScreenFrm.Free; ScreenFrm.Free;
end; end;
end; end;
procedure TmbDeskPickerButton.ColorPicked(Sender: TObject); procedure TmbDeskPickerButton.ColorPicked(Sender: TObject);
@ -86,17 +86,17 @@ end;
procedure TmbDeskPickerButton.ScreenKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure TmbDeskPickerButton.ScreenKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin begin
if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift); if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift);
end; end;
procedure TmbDeskPickerButton.WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure TmbDeskPickerButton.WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
begin begin
if Assigned(OnWUp) then OnWUp(Self, Shift, MousePos, Handled); if Assigned(OnWUp) then OnWUp(Self, Shift, MousePos, Handled);
end; end;
procedure TmbDeskPickerButton.WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure TmbDeskPickerButton.WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
begin begin
if Assigned(OnWDown) then OnWDown(Self, Shift, MousePos, Handled); if Assigned(OnWDown) then OnWDown(Self, Shift, MousePos, Handled);
end; end;
end. end.

70
components/mbColorLib/mbOfficeColorDialog.pas
View File

@ -17,16 +17,16 @@ uses
type type
TmbOfficeColorDialog = class(TComponent) TmbOfficeColorDialog = class(TComponent)
private private
FWin: TOfficeMoreColorsWin; FWin: TOfficeMoreColorsWin;
FSelColor: TColor; FSelColor: TColor;
FUseHint: boolean; FUseHint: boolean;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
function Execute: boolean; overload; function Execute: boolean; overload;
function Execute(AColor: TColor): boolean; overload; function Execute(AColor: TColor): boolean; overload;
published published
property SelectedColor: TColor read FSelColor write FSelColor default clWhite; property SelectedColor: TColor read FSelColor write FSelColor default clWhite;
property UseHints: boolean read FUseHint write FUseHint default false; property UseHints: boolean read FUseHint write FUseHint default false;
end; end;
implementation implementation
@ -35,41 +35,41 @@ implementation
constructor TmbOfficeColorDialog.Create(AOwner: TComponent); constructor TmbOfficeColorDialog.Create(AOwner: TComponent);
begin begin
inherited; inherited;
FSelColor := clWhite; FSelColor := clWhite;
FUseHint := false; FUseHint := false;
end; end;
function TmbOfficeColorDialog.Execute: boolean; function TmbOfficeColorDialog.Execute: boolean;
begin begin
FWin := TOfficeMoreColorsWin.Create(Application); FWin := TOfficeMoreColorsWin.Create(Application);
try try
FWin.OldSwatch.Color := FSelColor; FWin.OldSwatch.Color := FSelColor;
FWin.ShowHint := FUseHint; FWin.ShowHint := FUseHint;
Result := (FWin.ShowModal = IdOK); Result := (FWin.ShowModal = IdOK);
if Result then if Result then
FSelColor := FWin.NewSwatch.Color FSelColor := FWin.NewSwatch.Color
else else
FSelColor := clNone; FSelColor := clNone;
finally finally
FWin.Free; FWin.Free;
end; end;
end; end;
function TmbOfficeColorDialog.Execute(AColor: TColor): boolean; function TmbOfficeColorDialog.Execute(AColor: TColor): boolean;
begin begin
FWin := TOfficeMoreColorsWin.Create(Application); FWin := TOfficeMoreColorsWin.Create(Application);
try try
FWin.OldSwatch.Color := AColor; FWin.OldSwatch.Color := AColor;
FWin.ShowHint := FUseHint; FWin.ShowHint := FUseHint;
Result := (FWin.ShowModal = IdOK); Result := (FWin.ShowModal = IdOK);
if Result then if Result then
FSelColor := FWin.NewSwatch.Color FSelColor := FWin.NewSwatch.Color
else else
FSelColor := clNone; FSelColor := clNone;
finally finally
FWin.Free; FWin.Free;
end; end;
end; end;
end. end.

9
components/mbColorLib/mbutils.pas
View File

@ -7,7 +7,8 @@ interface
uses uses
Classes, SysUtils, Graphics, LCLIntf; Classes, SysUtils, Graphics, LCLIntf;
procedure Clamp(var AValue:Integer; AMin, AMax: Integer); procedure Clamp(var AValue: Integer; AMin, AMax: Integer); overload;
procedure Clamp(var AValue: Double; AMin, AMax: Double); overload;
procedure DrawHorDottedLine(ACanvas: TCanvas; X1, X2, Y: Integer; AColor: TColor); procedure DrawHorDottedLine(ACanvas: TCanvas; X1, X2, Y: Integer; AColor: TColor);
function PointInCircle(p: TPoint; Size: integer): boolean; function PointInCircle(p: TPoint; Size: integer): boolean;
function PtInCircle(p, ctr: TPoint; Radius: Integer): Boolean; function PtInCircle(p, ctr: TPoint; Radius: Integer): Boolean;
@ -25,6 +26,12 @@ begin
if AValue > AMax then AValue := AMax; if AValue > AMax then AValue := AMax;
end; end;
procedure Clamp(var AValue: Double; AMin, AMax: Double);
begin
if AValue < AMin then AValue := AMin;
if AValue > AMax then AValue := AMax;
end;
procedure DrawHorDottedLine(ACanvas: TCanvas; X1, X2, Y: Integer; AColor: TColor); procedure DrawHorDottedLine(ACanvas: TCanvas; X1, X2, Y: Integer; AColor: TColor);
begin begin
while X1 <= X2 do begin while X1 <= X2 do begin