You've already forked lazarus-ccr
mbColorLib: Apply standard code formatting
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
@ -137,19 +137,19 @@ function GetWebSafe(C: TColor): TColor;
|
||||
implementation
|
||||
|
||||
var
|
||||
WS: array [0..255] of byte;
|
||||
WS: array [0..255] of byte;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
|
||||
//checks membership of a string array
|
||||
function IsMember(a: array of string; n: integer; s: string): boolean;
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
Result := false;
|
||||
for i := 0 to n - 1 do
|
||||
if SameText(s, a[i]) then
|
||||
Result := true;
|
||||
Result := false;
|
||||
for i := 0 to n - 1 do
|
||||
if SameText(s, a[i]) then
|
||||
Result := true;
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
@ -157,7 +157,7 @@ end;
|
||||
//checks if the color's nam was used instead of hex
|
||||
function IsSpecialColor(s: string): boolean;
|
||||
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;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
@ -165,12 +165,12 @@ end;
|
||||
//is hex was used then remove the wrong characters
|
||||
procedure MakeIntoHex(var s: string);
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
if s <> '' then
|
||||
for i := 1 to Length(s) do
|
||||
if not (s[i] in ['0'..'9', 'A'..'F', 'a'..'f']) then
|
||||
s[i] := '0';
|
||||
if s <> '' then
|
||||
for i := 1 to Length(s) do
|
||||
if not (s[i] in ['0'..'9', 'A'..'F', 'a'..'f']) then
|
||||
s[i] := '0';
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
@ -178,35 +178,35 @@ end;
|
||||
//formats entered text into a true hex value
|
||||
function FormatHexColor(S: string): string;
|
||||
var
|
||||
c: string;
|
||||
i: integer;
|
||||
c: string;
|
||||
i: integer;
|
||||
begin
|
||||
c := '';
|
||||
if not IsSpecialColor(s) then
|
||||
c := '';
|
||||
if not IsSpecialColor(s) then
|
||||
begin
|
||||
if (s <> '') and (s[1] = '#') then
|
||||
Delete(s, 1, 1);
|
||||
if (s <> '') and (s[1] = '#') then
|
||||
Delete(s, 1, 1);
|
||||
|
||||
if s <> '' then
|
||||
if s <> '' then
|
||||
begin
|
||||
MakeIntoHex(c);
|
||||
if Length(c) = 6 then
|
||||
Result := c
|
||||
else
|
||||
MakeIntoHex(c);
|
||||
if Length(c) = 6 then
|
||||
Result := c
|
||||
else
|
||||
begin
|
||||
if Length(c) > 6 then
|
||||
c := Copy(c, 1, 6);
|
||||
if Length(c) < 6 then
|
||||
for i := 0 to 6 - Length(c) - 1 do
|
||||
c := '0' + c;
|
||||
Result := c;
|
||||
if Length(c) > 6 then
|
||||
c := Copy(c, 1, 6);
|
||||
if Length(c) < 6 then
|
||||
for i := 0 to 6 - Length(c) - 1 do
|
||||
c := '0' + c;
|
||||
Result := c;
|
||||
end;
|
||||
end
|
||||
else
|
||||
Result := '000000';
|
||||
else
|
||||
Result := '000000';
|
||||
end
|
||||
else
|
||||
Result := s;
|
||||
else
|
||||
Result := s;
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
@ -214,16 +214,16 @@ end;
|
||||
//gets a hex value from a color name from special colors
|
||||
function GetHexFromName(s: string): string;
|
||||
var
|
||||
i, k: integer;
|
||||
i, k: integer;
|
||||
begin
|
||||
k := 0;
|
||||
for i := 0 to SPECIAL_COUNT - 1 do
|
||||
if SameText(s, SPECIAL_NAMES[i]) then
|
||||
begin
|
||||
k := i;
|
||||
Break;
|
||||
end;
|
||||
Result := SPECIAL_HEX[k];
|
||||
k := 0;
|
||||
for i := 0 to SPECIAL_COUNT - 1 do
|
||||
if SameText(s, SPECIAL_NAMES[i]) then
|
||||
begin
|
||||
k := i;
|
||||
Break;
|
||||
end;
|
||||
Result := SPECIAL_HEX[k];
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
@ -231,33 +231,32 @@ end;
|
||||
// gets a TColor value from a color name from basic or system colors
|
||||
function GetValueFromName(s: string): TColor;
|
||||
var
|
||||
i, k: integer;
|
||||
i, k: integer;
|
||||
begin
|
||||
k := 0;
|
||||
s := LowerCase(s);
|
||||
if IsMember(BASIC_NAMES, BASIC_COUNT, s) then
|
||||
k := 0;
|
||||
s := LowerCase(s);
|
||||
if IsMember(BASIC_NAMES, BASIC_COUNT, s) then
|
||||
begin
|
||||
for i := 0 to BASIC_COUNT - 1 do
|
||||
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
|
||||
for i := 0 to BASIC_COUNT - 1 do
|
||||
if SameText(s, BASIC_NAMES[i]) then
|
||||
begin
|
||||
k := i;
|
||||
Break;
|
||||
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
|
||||
k := i;
|
||||
Break;
|
||||
end;
|
||||
Result := SYSTEM_VALUES[k];
|
||||
end
|
||||
end
|
||||
else
|
||||
Result := clNone;
|
||||
Result := clNone;
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
@ -276,27 +275,26 @@ end;
|
||||
//converts a hex value to a TColor
|
||||
function HexToTColor(s: OleVariant): TColor;
|
||||
begin
|
||||
if s <> null then
|
||||
if s <> null then
|
||||
begin
|
||||
if not IsSpecialColor(s) then
|
||||
if not IsSpecialColor(s) then
|
||||
begin
|
||||
s := FormatHexColor(s);
|
||||
if s <> '' then
|
||||
Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2)))
|
||||
else
|
||||
Result := clNone;
|
||||
s := FormatHexColor(s);
|
||||
if s <> '' then
|
||||
Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2)))
|
||||
else
|
||||
Result := clNone;
|
||||
end
|
||||
else
|
||||
if IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) then
|
||||
begin
|
||||
else if IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) then
|
||||
begin
|
||||
s := GetHexFromName(s);
|
||||
Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2)));
|
||||
end
|
||||
end
|
||||
else
|
||||
Result := GetValueFromName(s);
|
||||
Result := GetValueFromName(s);
|
||||
end
|
||||
else
|
||||
Result := clNone;
|
||||
else
|
||||
Result := clNone;
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
@ -304,8 +302,8 @@ end;
|
||||
//checks if a hex value belongs to the websafe palette
|
||||
function IsWebSafe(s: string): boolean;
|
||||
begin
|
||||
s := FormatHexColor(s);
|
||||
Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s);
|
||||
s := FormatHexColor(s);
|
||||
Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s);
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
@ -313,34 +311,34 @@ end;
|
||||
//checks if a color belongs to the websafe palette
|
||||
function IsWebSafe(c: TColor): boolean;
|
||||
var
|
||||
s: string;
|
||||
s: string;
|
||||
begin
|
||||
s := ColorToHex(c);
|
||||
Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s);
|
||||
s := ColorToHex(c);
|
||||
Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s);
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
|
||||
//initializes the websafe comparison array
|
||||
procedure InitializeWS;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i := 0 to 255 do
|
||||
WS[I] := ((i + $19) div $33) * $33;
|
||||
end;
|
||||
WS[I] := ((i + $19) div $33) * $33;
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
|
||||
//returns the closest web safe color to the one given
|
||||
function GetWebSafe(C: TColor): TColor;
|
||||
begin
|
||||
Result := RGB(WS[GetRValue(C)], WS[GetGValue(C)], WS[GetBValue(C)]);
|
||||
Result := RGB(WS[GetRValue(C)], WS[GetGValue(C)], WS[GetBValue(C)]);
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
|
||||
initialization
|
||||
InitializeWS;
|
||||
InitializeWS;
|
||||
|
||||
end.
|
||||
|
||||
@ -9,188 +9,186 @@ interface
|
||||
{$I mxs.inc}
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType, LMessages,
|
||||
{$ELSE}
|
||||
Windows, Messages,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Controls, Graphics, StdCtrls, Forms,
|
||||
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, RGBHSLUtils, Math,
|
||||
RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, mbBasicPicker;
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType, LMessages,
|
||||
{$ELSE}
|
||||
Windows, Messages,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Controls, Graphics, StdCtrls, Forms,
|
||||
{$IFDEF DELPHI_7_UP} Themes, {$ENDIF} HTMLColors, RGBHSLUtils, Math,
|
||||
RGBHSVUtils, RGBCMYKUtils, RGBCIEUtils, mbBasicPicker;
|
||||
|
||||
const
|
||||
CustomCell = -2;
|
||||
NoCell = -1;
|
||||
CustomCell = -2;
|
||||
NoCell = -1;
|
||||
|
||||
type
|
||||
TMarker = (smArrow, smRect);
|
||||
TMarker = (smArrow, smRect);
|
||||
|
||||
TCombEntry = record
|
||||
Position: TPoint;
|
||||
Color: COLORREF;
|
||||
TabIndex: integer;
|
||||
end;
|
||||
TCombEntry = record
|
||||
Position: TPoint;
|
||||
Color: COLORREF;
|
||||
TabIndex: integer;
|
||||
end;
|
||||
|
||||
TCombArray = array of TCombEntry;
|
||||
TCombArray = array of TCombEntry;
|
||||
|
||||
TFloatPoint = record
|
||||
X, Y: Extended;
|
||||
end;
|
||||
TFloatPoint = record
|
||||
X, Y: Extended;
|
||||
end;
|
||||
|
||||
TRGBrec = record
|
||||
Red, Green, Blue: Single;
|
||||
end;
|
||||
TRGBrec = record
|
||||
Red, Green, Blue: Single;
|
||||
end;
|
||||
|
||||
TSelectionMode = (smNone, smColor, smBW, smRamp);
|
||||
TSelectionMode = (smNone, smColor, smBW, smRamp);
|
||||
|
||||
THexaColorPicker = class(TmbBasicPicker)
|
||||
private
|
||||
FIncrement: integer;
|
||||
FSelectedCombIndex: integer;
|
||||
mX, mY: integer;
|
||||
FHintFormat: string;
|
||||
FUnderCursor: TColor;
|
||||
FOnChange, FOnIntensityChange: TNotifyEvent;
|
||||
FCurrentColor: TColor;
|
||||
FSelectedIndex: Integer;
|
||||
FColorCombRect, FBWCombRect, FSliderRect, FCustomColorRect: TRect;
|
||||
FCombSize, FLevels: Integer;
|
||||
FBWCombs, FColorCombs: TCombArray;
|
||||
FCombCorners: array[0..5] of TFloatPoint;
|
||||
FCenterColor: TRGBrec;
|
||||
FCenterIntensity: Single;
|
||||
FSliderWidth: integer;
|
||||
FCustomIndex: Integer; // If FSelectedIndex contains CustomCell then this index shows
|
||||
THexaColorPicker = class(TmbBasicPicker)
|
||||
private
|
||||
FIncrement: integer;
|
||||
FSelectedCombIndex: integer;
|
||||
mX, mY: integer;
|
||||
FHintFormat: string;
|
||||
FUnderCursor: TColor;
|
||||
FOnChange, FOnIntensityChange: TNotifyEvent;
|
||||
FCurrentColor: TColor;
|
||||
FSelectedIndex: Integer;
|
||||
FColorCombRect, FBWCombRect, FSliderRect, FCustomColorRect: TRect;
|
||||
FCombSize, FLevels: Integer;
|
||||
FBWCombs, FColorCombs: TCombArray;
|
||||
FCombCorners: array[0..5] of TFloatPoint;
|
||||
FCenterColor: TRGBrec;
|
||||
FCenterIntensity: Single;
|
||||
FSliderWidth: integer;
|
||||
FCustomIndex: Integer; // If FSelectedIndex contains CustomCell then this index shows
|
||||
// which index in the custom area has been selected.
|
||||
// Positive values indicate the color comb and negative values
|
||||
// indicate the B&W combs (complement). This value is offset with
|
||||
// 1 to use index 0 to show no selection.
|
||||
FRadius: Integer;
|
||||
FSelectionMode: TSelectionMode;
|
||||
FSliderVisible: boolean;
|
||||
FMarker: TMarker;
|
||||
FNewArrowStyle: boolean;
|
||||
FIntensityText: string;
|
||||
FRadius: Integer;
|
||||
FSelectionMode: TSelectionMode;
|
||||
FSliderVisible: boolean;
|
||||
FMarker: TMarker;
|
||||
FNewArrowStyle: boolean;
|
||||
FIntensityText: string;
|
||||
|
||||
procedure SetNewArrowStyle(Value: boolean);
|
||||
procedure SetMarker(Value: TMarker);
|
||||
procedure SetSliderVisible(Value: boolean);
|
||||
procedure SetRadius(r: integer);
|
||||
procedure SetSliderWidth(w: integer);
|
||||
procedure SetIntensity(v: integer);
|
||||
procedure ChangeIntensity(increase: boolean);
|
||||
procedure SelectColor(Color: TColor);
|
||||
procedure Initialize;
|
||||
procedure DrawAll;
|
||||
procedure SetSelectedColor(const Value: TColor);
|
||||
procedure DrawCombControls;
|
||||
procedure DrawComb(Canvas: TCanvas; X, Y, Size: Integer);
|
||||
procedure HandleCustomColors(var Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF});
|
||||
procedure CalculateCombLayout;
|
||||
procedure EndSelection;
|
||||
procedure EnumerateCombs;
|
||||
function SelectAvailableColor(Color: TColor): boolean;
|
||||
function GetIntensity: integer;
|
||||
function HandleBWArea(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 PtInComb(Comb: TCombEntry; P: TPoint; Scale: Integer): Boolean;
|
||||
function FindBWArea(X, Y: Integer): Integer;
|
||||
function FindColorArea(X, Y: Integer): Integer;
|
||||
function GetNextCombIndex(i: integer): integer;
|
||||
function GetPreviousCombIndex(i: integer): integer;
|
||||
protected
|
||||
procedure CreateWnd; override;
|
||||
procedure Paint; override;
|
||||
procedure Resize; override;
|
||||
procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
|
||||
procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
|
||||
{$IFDEF DELPHI}
|
||||
procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
|
||||
procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
|
||||
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
|
||||
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
|
||||
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
|
||||
{$ELSE}
|
||||
procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN;
|
||||
procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW;
|
||||
procedure WMLButtonDown(var Message: TLMLButtonDown); message LM_LBUTTONDOWN;
|
||||
procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP;
|
||||
procedure WMMouseMove(var Message: TLMMouseMove); message LM_MOUSEMOVE;
|
||||
{$ENDIF}
|
||||
procedure SetNewArrowStyle(Value: boolean);
|
||||
procedure SetMarker(Value: TMarker);
|
||||
procedure SetSliderVisible(Value: boolean);
|
||||
procedure SetRadius(r: integer);
|
||||
procedure SetSliderWidth(w: integer);
|
||||
procedure SetIntensity(v: integer);
|
||||
procedure ChangeIntensity(increase: boolean);
|
||||
procedure SelectColor(Color: TColor);
|
||||
procedure Initialize;
|
||||
procedure DrawAll;
|
||||
procedure SetSelectedColor(const Value: TColor);
|
||||
procedure DrawCombControls;
|
||||
procedure DrawComb(Canvas: TCanvas; X, Y, Size: Integer);
|
||||
procedure HandleCustomColors(var Message: {$IFDEF FPC}TLMMouse{$ELSE}TWMMouse{$ENDIF});
|
||||
procedure CalculateCombLayout;
|
||||
procedure EndSelection;
|
||||
procedure EnumerateCombs;
|
||||
function SelectAvailableColor(Color: TColor): boolean;
|
||||
function GetIntensity: integer;
|
||||
function HandleBWArea(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 PtInComb(Comb: TCombEntry; P: TPoint; Scale: Integer): Boolean;
|
||||
function FindBWArea(X, Y: Integer): Integer;
|
||||
function FindColorArea(X, Y: Integer): Integer;
|
||||
function GetNextCombIndex(i: integer): integer;
|
||||
function GetPreviousCombIndex(i: integer): integer;
|
||||
protected
|
||||
procedure CreateWnd; override;
|
||||
procedure Paint; override;
|
||||
procedure Resize; override;
|
||||
procedure WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
|
||||
procedure WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
|
||||
{$IFDEF DELPHI}
|
||||
procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
|
||||
procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
|
||||
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
|
||||
procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
|
||||
procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
|
||||
{$ELSE}
|
||||
procedure CNKeyDown(var Message: TLMKeyDown); message CN_KEYDOWN;
|
||||
procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW;
|
||||
procedure WMLButtonDown(var Message: TLMLButtonDown); message LM_LBUTTONDOWN;
|
||||
procedure WMLButtonUp(var Message: TLMLButtonUp); message LM_LBUTTONUP;
|
||||
procedure WMMouseMove(var Message: TLMMouseMove); message LM_MOUSEMOVE;
|
||||
{$ENDIF}
|
||||
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); 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);
|
||||
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;
|
||||
|
||||
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);
|
||||
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
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -7,42 +7,42 @@ unit RColorPicker;
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType, LMessages,
|
||||
{$ELSE}
|
||||
Windows, Messages,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Controls, Graphics, Forms,
|
||||
mbTrackBarPicker, HTMLColors, Scanlines;
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType, LMessages,
|
||||
{$ELSE}
|
||||
Windows, Messages,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Controls, Graphics, Forms,
|
||||
mbTrackBarPicker, HTMLColors, Scanlines;
|
||||
|
||||
type
|
||||
|
||||
{ TRColorPicker }
|
||||
{ TRColorPicker }
|
||||
|
||||
TRColorPicker = class(TmbTrackBarPicker)
|
||||
private
|
||||
FRed, FGreen, FBlue: integer;
|
||||
function ArrowPosFromRed(r: integer): integer;
|
||||
function RedFromArrowPos(p: integer): integer;
|
||||
function GetSelectedColor: TColor;
|
||||
procedure SetSelectedColor(c: TColor);
|
||||
procedure SetRed(r: integer);
|
||||
procedure SetGreen(g: integer);
|
||||
procedure SetBlue(b: integer);
|
||||
protected
|
||||
procedure Execute(tbaAction: integer); override;
|
||||
function GetArrowPos: integer; override;
|
||||
function GetGradientColor(AValue: Integer): TColor; override;
|
||||
function GetSelectedValue: integer; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Red: integer read FRed write SetRed default 255;
|
||||
property Green: integer read FGreen write SetGreen default 122;
|
||||
property Blue: integer read FBlue write SetBlue default 122;
|
||||
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
|
||||
property Layout default lyVertical;
|
||||
end;
|
||||
TRColorPicker = class(TmbTrackBarPicker)
|
||||
private
|
||||
FRed, FGreen, FBlue: integer;
|
||||
function ArrowPosFromRed(r: integer): integer;
|
||||
function RedFromArrowPos(p: integer): integer;
|
||||
function GetSelectedColor: TColor;
|
||||
procedure SetSelectedColor(c: TColor);
|
||||
procedure SetRed(r: integer);
|
||||
procedure SetGreen(g: integer);
|
||||
procedure SetBlue(b: integer);
|
||||
protected
|
||||
procedure Execute(tbaAction: integer); override;
|
||||
function GetArrowPos: integer; override;
|
||||
function GetGradientColor(AValue: Integer): TColor; override;
|
||||
function GetSelectedValue: integer; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Red: integer read FRed write SetRed default 255;
|
||||
property Green: integer read FGreen write SetGreen default 122;
|
||||
property Blue: integer read FBlue write SetBlue default 122;
|
||||
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
|
||||
property Layout default lyVertical;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
@ -8,315 +8,312 @@ uses
|
||||
Graphics, Math;
|
||||
|
||||
const
|
||||
{// Observer= 2�, Illuminant= D65 - Daylignt
|
||||
ref_X = 95.047;
|
||||
ref_Z = 108.883;
|
||||
// Observer= 10�, Illuminant= D65 - Daylight
|
||||
ref_X = 94.811;
|
||||
ref_Z = 35.2;
|
||||
{// Observer= 2�, Illuminant= D65 - Daylignt
|
||||
ref_X = 95.047;
|
||||
ref_Z = 108.883;
|
||||
// Observer= 10�, Illuminant= D65 - Daylight
|
||||
ref_X = 94.811;
|
||||
ref_Z = 35.2;
|
||||
|
||||
// Observer= 2�, Illuminant= A - Incadescent
|
||||
ref_X = 109.850;
|
||||
ref_Z = 35.585;
|
||||
// Observer= 10�, Illuminant= A - Incadescent
|
||||
ref_X = 111.144;
|
||||
ref_Z = 35.2;
|
||||
// Observer= 2�, Illuminant= A - Incadescent
|
||||
ref_X = 109.850;
|
||||
ref_Z = 35.585;
|
||||
// Observer= 10�, Illuminant= A - Incadescent
|
||||
ref_X = 111.144;
|
||||
ref_Z = 35.2;
|
||||
|
||||
// Observer= 2�, Illuminant= C
|
||||
ref_X = 98.074;
|
||||
ref_Z = 118.232;
|
||||
// Observer= 10�, Illuminant= C
|
||||
ref_X = 97.285;
|
||||
ref_Z = 116.145;
|
||||
// Observer= 2�, Illuminant= C
|
||||
ref_X = 98.074;
|
||||
ref_Z = 118.232;
|
||||
// Observer= 10�, Illuminant= C
|
||||
ref_X = 97.285;
|
||||
ref_Z = 116.145;
|
||||
}
|
||||
// Observer= 2�, Illuminant= D50
|
||||
ref_X = 96.422;
|
||||
ref_Z = 82.521;{
|
||||
// Observer= 10�, Illuminant= D50 - Photoshop
|
||||
ref_X = 96.72;
|
||||
ref_Z = 81.427; }
|
||||
// Observer= 2�, Illuminant= D50
|
||||
ref_X = 96.422;
|
||||
ref_Z = 82.521;{
|
||||
// Observer= 10�, Illuminant= D50 - Photoshop
|
||||
ref_X = 96.72;
|
||||
ref_Z = 81.427; }
|
||||
|
||||
{// Observer= 2�, Illuminant= D55
|
||||
ref_X = 95.682;
|
||||
ref_Z = 92.149;
|
||||
// Observer= 10�, Illuminant= D55
|
||||
ref_X = 95.799;
|
||||
ref_Z = 90.926;
|
||||
{// Observer= 2�, Illuminant= D55
|
||||
ref_X = 95.682;
|
||||
ref_Z = 92.149;
|
||||
// Observer= 10�, Illuminant= D55
|
||||
ref_X = 95.799;
|
||||
ref_Z = 90.926;
|
||||
|
||||
// Observer= 2�, Illuminant= D75
|
||||
ref_X = 94.972;
|
||||
ref_Z = 122.638;
|
||||
// Observer= 10�, Illuminant= D75
|
||||
ref_X = 94.416;
|
||||
ref_Z = 12.641;
|
||||
// Observer= 2�, Illuminant= D75
|
||||
ref_X = 94.972;
|
||||
ref_Z = 122.638;
|
||||
// Observer= 10�, Illuminant= D75
|
||||
ref_X = 94.416;
|
||||
ref_Z = 12.641;
|
||||
|
||||
// Observer= 2�, Illuminant= F2 - Fluorescent
|
||||
ref_X = 99.187;
|
||||
ref_Z = 67.395;
|
||||
// Observer= 10�, Illuminant= F2 - Fluorescent
|
||||
ref_X = 103.28;
|
||||
ref_Z = 69.026;
|
||||
// Observer= 2�, Illuminant= F2 - Fluorescent
|
||||
ref_X = 99.187;
|
||||
ref_Z = 67.395;
|
||||
// Observer= 10�, Illuminant= F2 - Fluorescent
|
||||
ref_X = 103.28;
|
||||
ref_Z = 69.026;
|
||||
|
||||
// Observer= 2�, Illuminant= F7
|
||||
ref_X = 95.044;
|
||||
ref_Z = 108.755;
|
||||
// Observer= 10�, Illuminant= F7
|
||||
ref_X = 95.792;
|
||||
ref_Z = 107.678;
|
||||
// Observer= 2�, Illuminant= F7
|
||||
ref_X = 95.044;
|
||||
ref_Z = 108.755;
|
||||
// Observer= 10�, Illuminant= F7
|
||||
ref_X = 95.792;
|
||||
ref_Z = 107.678;
|
||||
|
||||
// Observer= 2�, Illuminant= F11
|
||||
ref_X = 100.966;
|
||||
ref_Z = 64.370;
|
||||
// Observer= 10�, Illuminant= F11
|
||||
ref_X = 103.866;
|
||||
ref_Z = 65.627; }
|
||||
// Observer= 2�, Illuminant= F11
|
||||
ref_X = 100.966;
|
||||
ref_Z = 64.370;
|
||||
// Observer= 10�, Illuminant= F11
|
||||
ref_X = 103.866;
|
||||
ref_Z = 65.627; }
|
||||
|
||||
type
|
||||
xyz = record
|
||||
x: real;
|
||||
y: real;
|
||||
z: real;
|
||||
end;
|
||||
xyz = record
|
||||
x: Double;
|
||||
y: Double;
|
||||
z: Double;
|
||||
end;
|
||||
|
||||
function LabToXYZ(l, a, b: real): xyz;
|
||||
function LabToXYZ(l, a, b: double): xyz;
|
||||
function XYZToRGB(space: xyz): TColor;
|
||||
function LabToRGB(l, a, b: real): TColor;
|
||||
function LabToRGB(l, a, b: double): TColor;
|
||||
function RGBToXYZ(c: TColor): xyz;
|
||||
procedure RGBToLab(clr: TColor; var l, a, b: real);
|
||||
procedure XYZToLab(space: xyz; var l, a, b: real);
|
||||
procedure LCHToLab(lum, c, h: real; var l, a, b: real);
|
||||
procedure LabToLCH(l, a, b: real; var lum, c, h: real);
|
||||
function LCHToRGB(l, c, h: real): TColor;
|
||||
procedure RGBToLCH(clr: TColor; var l, c, h: real);
|
||||
function GetCIEXValue(c: TColor): real;
|
||||
function GetCIEYValue(c: TColor): real;
|
||||
function GetCIEZValue(c: TColor): real;
|
||||
function GetCIELValue(c: TColor): real;
|
||||
function GetCIEAValue(c: TColor): real;
|
||||
function GetCIEBValue(c: TColor): real;
|
||||
function GetCIECValue(c: TColor): real;
|
||||
function GetCIEHValue(c: TColor): real;
|
||||
procedure RGBToLab(clr: TColor; var l, a, b: double);
|
||||
procedure XYZToLab(space: xyz; var l, a, b: double);
|
||||
procedure LCHToLab(lum, c, h: double; var l, a, b: double);
|
||||
procedure LabToLCH(l, a, b: double; var lum, c, h: double);
|
||||
function LCHToRGB(l, c, h: double): TColor;
|
||||
procedure RGBToLCH(clr: TColor; var l, c, h: double);
|
||||
function GetCIEXValue(c: TColor): double;
|
||||
function GetCIEYValue(c: TColor): double;
|
||||
function GetCIEZValue(c: TColor): double;
|
||||
function GetCIELValue(c: TColor): double;
|
||||
function GetCIEAValue(c: TColor): double;
|
||||
function GetCIEBValue(c: TColor): double;
|
||||
function GetCIECValue(c: TColor): double;
|
||||
function GetCIEHValue(c: TColor): double;
|
||||
|
||||
implementation
|
||||
|
||||
function LabToXYZ(l, a, b: real): xyz;
|
||||
uses
|
||||
mbUtils;
|
||||
|
||||
function LabToXYZ(l, a, b: double): xyz;
|
||||
var
|
||||
x, y, z: real;
|
||||
x, y, z: double;
|
||||
begin
|
||||
y := (l + 16)/116;
|
||||
x := a/500 + y;
|
||||
z := y - b/200;
|
||||
if y > 0.2069 then
|
||||
y := IntPower(y, 3)
|
||||
else
|
||||
y := (y - 0.138)/7.787;
|
||||
if x > 0.2069 then
|
||||
x := IntPower(x, 3)
|
||||
else
|
||||
x := (x - 0.138)/7.787;
|
||||
if z > 0.2069 then
|
||||
z := IntPower(z, 3)
|
||||
else
|
||||
z := (z - 0.138)/7.787;
|
||||
Result.x := ref_X * x;
|
||||
Result.y := 100 * y;
|
||||
Result.z := ref_Z * z;
|
||||
y := (l + 16)/116;
|
||||
x := a/500 + y;
|
||||
z := y - b/200;
|
||||
if y > 0.2069 then
|
||||
y := IntPower(y, 3)
|
||||
else
|
||||
y := (y - 0.138)/7.787;
|
||||
if x > 0.2069 then
|
||||
x := IntPower(x, 3)
|
||||
else
|
||||
x := (x - 0.138)/7.787;
|
||||
if z > 0.2069 then
|
||||
z := IntPower(z, 3)
|
||||
else
|
||||
z := (z - 0.138)/7.787;
|
||||
Result.x := ref_X * x;
|
||||
Result.y := 100 * y;
|
||||
Result.z := ref_Z * z;
|
||||
end;
|
||||
|
||||
function XYZToRGB(space: xyz): TColor;
|
||||
var
|
||||
r, g, b, x, y, z: real;
|
||||
r, g, b, x, y, z: double;
|
||||
begin
|
||||
x := space.x/100;
|
||||
y := space.y/100;
|
||||
z := space.z/100;
|
||||
r := x * 3.2406 + y * (-1.5372) + z * (-0.49);
|
||||
g := x * (-0.969) + y * 1.8758 + z * 0.0415;
|
||||
b := x * 0.0557 + y * (-0.2040) + z * 1.0570;
|
||||
if r > 0.00313 then
|
||||
r := 1.055 * Power(r, 1/2.4) - 0.055
|
||||
else
|
||||
r := 12.92 * r;
|
||||
if g > 0.00313 then
|
||||
g := 1.055 * Power(g, 1/2.4) - 0.055
|
||||
else
|
||||
g := 12.92 * g;
|
||||
if b > 0.00313 then
|
||||
b := 1.055 * Power(b, 1/2.4) - 0.055
|
||||
else
|
||||
b := 12.92 * b;
|
||||
x := space.x/100;
|
||||
y := space.y/100;
|
||||
z := space.z/100;
|
||||
r := x * 3.2406 + y * (-1.5372) + z * (-0.49);
|
||||
g := x * (-0.969) + y * 1.8758 + z * 0.0415;
|
||||
b := x * 0.0557 + y * (-0.2040) + z * 1.0570;
|
||||
if r > 0.00313 then
|
||||
r := 1.055 * Power(r, 1/2.4) - 0.055
|
||||
else
|
||||
r := 12.92 * r;
|
||||
if g > 0.00313 then
|
||||
g := 1.055 * Power(g, 1/2.4) - 0.055
|
||||
else
|
||||
g := 12.92 * g;
|
||||
if b > 0.00313 then
|
||||
b := 1.055 * Power(b, 1/2.4) - 0.055
|
||||
else
|
||||
b := 12.92 * b;
|
||||
|
||||
if r < 0 then r := 0;
|
||||
if r > 1 then r := 1;
|
||||
if g < 0 then g := 0;
|
||||
if g > 1 then g := 1;
|
||||
if b < 0 then b := 0;
|
||||
if b > 1 then b := 1;
|
||||
Result := RGB(Round(r*255), Round(g*255), Round(b*255));
|
||||
Clamp(r, 0, 1);
|
||||
Clamp(g, 0, 1);
|
||||
Clamp(b, 0, 1);
|
||||
Result := RGB(Round(r*255), Round(g*255), Round(b*255));
|
||||
end;
|
||||
|
||||
function LabToRGB(l, a, b: real): TColor;
|
||||
function LabToRGB(l, a, b: double): TColor;
|
||||
begin
|
||||
Result := XYZToRGB(LabToXYZ(l, a, b));
|
||||
Result := XYZToRGB(LabToXYZ(l, a, b));
|
||||
end;
|
||||
|
||||
function RGBToXYZ(c: TColor): xyz;
|
||||
var
|
||||
r, g, b: real;
|
||||
r, g, b: double;
|
||||
begin
|
||||
r := GetRValue(c)/255;
|
||||
g := GetGValue(c)/255;
|
||||
b := GetBValue(c)/255;
|
||||
if r > 0.04045 then
|
||||
r := Power((r + 0.055)/1.055, 2.4)
|
||||
else
|
||||
r := r/12.92;
|
||||
if g > 0.04045 then
|
||||
g := Power((g + 0.055)/1.055, 2.4)
|
||||
else
|
||||
g := g/12.92;
|
||||
if b > 0.04045 then
|
||||
b := Power((b + 0.055)/1.055, 2.4)
|
||||
else
|
||||
b := b/12.92;
|
||||
r := r * 100;
|
||||
g := g * 100;
|
||||
b := b * 100;
|
||||
// Observer= 2�, Illuminant= D65
|
||||
Result.x := r * 0.4124 + g * 0.3576 + b * 0.1805;
|
||||
Result.y := r * 0.2126 + g * 0.7152 + b * 0.0722;
|
||||
Result.z := r * 0.0193 + g * 0.1192 + b * 0.9505;
|
||||
r := GetRValue(c)/255;
|
||||
g := GetGValue(c)/255;
|
||||
b := GetBValue(c)/255;
|
||||
if r > 0.04045 then
|
||||
r := Power((r + 0.055)/1.055, 2.4)
|
||||
else
|
||||
r := r/12.92;
|
||||
if g > 0.04045 then
|
||||
g := Power((g + 0.055)/1.055, 2.4)
|
||||
else
|
||||
g := g/12.92;
|
||||
if b > 0.04045 then
|
||||
b := Power((b + 0.055)/1.055, 2.4)
|
||||
else
|
||||
b := b/12.92;
|
||||
r := r * 100;
|
||||
g := g * 100;
|
||||
b := b * 100;
|
||||
// Observer= 2�, Illuminant= D65
|
||||
Result.x := r * 0.4124 + g * 0.3576 + b * 0.1805;
|
||||
Result.y := r * 0.2126 + g * 0.7152 + b * 0.0722;
|
||||
Result.z := r * 0.0193 + g * 0.1192 + b * 0.9505;
|
||||
end;
|
||||
|
||||
procedure XYZToLab(space: xyz; var l, a, b: real);
|
||||
procedure XYZToLab(space: xyz; var l, a, b: Double);
|
||||
var
|
||||
x, y, z: real;
|
||||
x, y, z: double;
|
||||
begin
|
||||
x := space.x/ref_X;
|
||||
y := space.y/100;
|
||||
z := space.z/ref_Z;
|
||||
if x > 0.008856 then
|
||||
x := Power(x, 1/3)
|
||||
else
|
||||
x := (7.787*x) + 0.138;
|
||||
if y > 0.008856 then
|
||||
y := Power(y, 1/3)
|
||||
else
|
||||
y := (7.787*y) + 0.138;
|
||||
if z > 0.008856 then
|
||||
z := Power(z, 1/3)
|
||||
else
|
||||
z := (7.787*z) + 0.138;
|
||||
l := (116*y) - 16;
|
||||
a := 500 * (x - y);
|
||||
b := 200 * (y - z);
|
||||
if l > 100 then l := 100;
|
||||
if l < 0 then l := 0;
|
||||
if a < -128 then a := -128;
|
||||
if a > 127 then a := 127;
|
||||
if b < -128 then b := -128;
|
||||
if b > 127 then b := 127;
|
||||
x := space.x/ref_X;
|
||||
y := space.y/100;
|
||||
z := space.z/ref_Z;
|
||||
if x > 0.008856 then
|
||||
x := Power(x, 1/3)
|
||||
else
|
||||
x := (7.787*x) + 0.138;
|
||||
if y > 0.008856 then
|
||||
y := Power(y, 1/3)
|
||||
else
|
||||
y := (7.787*y) + 0.138;
|
||||
if z > 0.008856 then
|
||||
z := Power(z, 1/3)
|
||||
else
|
||||
z := (7.787*z) + 0.138;
|
||||
l := (116*y) - 16;
|
||||
a := 500 * (x - y);
|
||||
b := 200 * (y - z);
|
||||
Clamp(l, 0, 100);
|
||||
Clamp(a, -128, 127);
|
||||
Clamp(b, -128, 127);
|
||||
end;
|
||||
|
||||
procedure RGBToLab(clr: TColor; var l, a, b: real);
|
||||
procedure RGBToLab(clr: TColor; var l, a, b: Double);
|
||||
var
|
||||
s: xyz;
|
||||
s: xyz;
|
||||
begin
|
||||
s := RGBToXYZ(clr);
|
||||
XYZToLab(s, l, a, b);
|
||||
s := RGBToXYZ(clr);
|
||||
XYZToLab(s, l, a, b);
|
||||
end;
|
||||
|
||||
procedure LCHToLab(lum, c, h: real; var l, a, b: real);
|
||||
procedure LCHToLab(lum, c, h: double; var l, a, b: double);
|
||||
begin
|
||||
l := lum;
|
||||
a := cos(DegToRad(h)) * c;
|
||||
b := sin(DegToRad(h)) * c;
|
||||
l := lum;
|
||||
a := cos(DegToRad(h)) * c;
|
||||
b := sin(DegToRad(h)) * c;
|
||||
end;
|
||||
|
||||
procedure LabToLCH(l, a, b: real; var lum, c, h: real);
|
||||
procedure LabToLCH(l, a, b: double; var lum, c, h: double);
|
||||
begin
|
||||
h := ArcTan2(b, a);
|
||||
if h > 0 then
|
||||
h := (h/PI) * 180
|
||||
else
|
||||
h := 360 - (ABS(h)/PI) * 180;
|
||||
lum := l;
|
||||
c := SQRT(a*a + b*b);
|
||||
h := ArcTan2(b, a);
|
||||
if h > 0 then
|
||||
h := (h/pi) * 180
|
||||
else
|
||||
h := 360 - (abs(h)/pi) * 180;
|
||||
lum := l;
|
||||
c := SQRT(a*a + b*b);
|
||||
end;
|
||||
|
||||
procedure RGBToLCH(clr: TColor; var l, c, h: real);
|
||||
procedure RGBToLCH(clr: TColor; var l, c, h: double);
|
||||
var
|
||||
a, b: real;
|
||||
a, b: double;
|
||||
begin
|
||||
RGBToLab(clr, l, a, b);
|
||||
LabToLCH(l, a, b, l, c, h);
|
||||
RGBToLab(clr, l, a, b);
|
||||
LabToLCH(l, a, b, l, c, h);
|
||||
end;
|
||||
|
||||
function LCHToRGB(l, c, h: real): TColor;
|
||||
function LCHToRGB(l, c, h: double): TColor;
|
||||
var
|
||||
lum, a, b: real;
|
||||
lum, a, b: double;
|
||||
begin
|
||||
LCHToLab(l, c, h, lum, a, b);
|
||||
Result := LabToRGB(lum, a, b);
|
||||
LCHToLab(l, c, h, lum, a, b);
|
||||
Result := LabToRGB(lum, a, b);
|
||||
end;
|
||||
|
||||
function GetCIEXValue(c: TColor): real;
|
||||
function GetCIEXValue(c: TColor): double;
|
||||
var
|
||||
d: xyz;
|
||||
d: xyz;
|
||||
begin
|
||||
d := RGBToXYZ(c);
|
||||
Result := d.x;
|
||||
d := RGBToXYZ(c);
|
||||
Result := d.x;
|
||||
end;
|
||||
|
||||
function GetCIEYValue(c: TColor): real;
|
||||
function GetCIEYValue(c: TColor): double;
|
||||
var
|
||||
d: xyz;
|
||||
d: xyz;
|
||||
begin
|
||||
d := RGBToXYZ(c);
|
||||
Result := d.y;
|
||||
d := RGBToXYZ(c);
|
||||
Result := d.y;
|
||||
end;
|
||||
|
||||
function GetCIEZValue(c: TColor): real;
|
||||
function GetCIEZValue(c: TColor): double;
|
||||
var
|
||||
d: xyz;
|
||||
d: xyz;
|
||||
begin
|
||||
d := RGBToXYZ(c);
|
||||
Result := d.z;
|
||||
d := RGBToXYZ(c);
|
||||
Result := d.z;
|
||||
end;
|
||||
|
||||
function GetCIELValue(c: TColor): real;
|
||||
function GetCIELValue(c: TColor): double;
|
||||
var
|
||||
d: real;
|
||||
d: real;
|
||||
begin
|
||||
XYZToLab(RGBToXYZ(c), Result, d, d);
|
||||
XYZToLab(RGBToXYZ(c), Result, d, d);
|
||||
end;
|
||||
|
||||
function GetCIEAValue(c: TColor): real;
|
||||
function GetCIEAValue(c: TColor): double;
|
||||
var
|
||||
d: real;
|
||||
d: double;
|
||||
begin
|
||||
XYZToLab(RGBToXYZ(c), d, Result, d);
|
||||
end;
|
||||
|
||||
function GetCIEBValue(c: TColor): real;
|
||||
function GetCIEBValue(c: TColor): double;
|
||||
var
|
||||
d: real;
|
||||
d: double;
|
||||
begin
|
||||
XYZToLab(RGBToXYZ(c), d, d, Result);
|
||||
end;
|
||||
|
||||
function GetCIECValue(c: TColor): real;
|
||||
function GetCIECValue(c: TColor): double;
|
||||
var
|
||||
d: real;
|
||||
d: double;
|
||||
begin
|
||||
RGBToLCH(c, d, Result, d);
|
||||
end;
|
||||
|
||||
function GetCIEHValue(c: TColor): real;
|
||||
function GetCIEHValue(c: TColor): double;
|
||||
var
|
||||
d: real;
|
||||
d: double;
|
||||
begin
|
||||
RGBToLCH(c, d, d, Result);
|
||||
RGBToLCH(c, d, d, Result);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -19,58 +19,58 @@ implementation
|
||||
|
||||
function CMYtoTColor(C, M, Y: integer): TColor;
|
||||
begin
|
||||
Result := RGB(255 - C, 255 - M, 255 - Y);
|
||||
Result := RGB(255 - C, 255 - M, 255 - Y);
|
||||
end;
|
||||
|
||||
procedure RGBtoCMY(clr: TColor; var C, M, Y: integer);
|
||||
begin
|
||||
C := 255 - GetRValue(clr);
|
||||
M := 255 - GetGValue(clr);
|
||||
Y := 255 - GetBValue(clr);
|
||||
C := 255 - GetRValue(clr);
|
||||
M := 255 - GetGValue(clr);
|
||||
Y := 255 - GetBValue(clr);
|
||||
end;
|
||||
|
||||
function CMYKToTColor (C, M, Y, K: integer): TColor;
|
||||
begin
|
||||
Result := RGB(255 - (C + K), 255 - (M + K), 255 - (Y + K));
|
||||
Result := RGB(255 - (C + K), 255 - (M + K), 255 - (Y + K));
|
||||
end;
|
||||
|
||||
procedure ColorToCMYK(clr: TColor; var C, M, Y, K: integer);
|
||||
begin
|
||||
C := 255 - GetRValue(clr);
|
||||
M := 255 - GetGValue(clr);
|
||||
Y := 255 - GetBValue(clr);
|
||||
K := MinIntValue([C, M, Y]);
|
||||
C := C - K;
|
||||
M := M - K;
|
||||
Y := Y - K;
|
||||
C := 255 - GetRValue(clr);
|
||||
M := 255 - GetGValue(clr);
|
||||
Y := 255 - GetBValue(clr);
|
||||
K := MinIntValue([C, M, Y]);
|
||||
C := C - K;
|
||||
M := M - K;
|
||||
Y := Y - K;
|
||||
end;
|
||||
|
||||
function GetCValue(c: TColor): integer;
|
||||
var
|
||||
d: integer;
|
||||
d: integer;
|
||||
begin
|
||||
ColorToCMYK(c, Result, d, d, d);
|
||||
ColorToCMYK(c, Result, d, d, d);
|
||||
end;
|
||||
|
||||
function GetMValue(c: TColor): integer;
|
||||
var
|
||||
d: integer;
|
||||
d: integer;
|
||||
begin
|
||||
ColorToCMYK(c, d, Result, d, d);
|
||||
ColorToCMYK(c, d, Result, d, d);
|
||||
end;
|
||||
|
||||
function GetYValue(c: TColor): integer;
|
||||
var
|
||||
d: integer;
|
||||
d: integer;
|
||||
begin
|
||||
ColorToCMYK(c, d, d, Result, d);
|
||||
ColorToCMYK(c, d, d, Result, d);
|
||||
end;
|
||||
|
||||
function GetKValue(c: TColor): integer;
|
||||
var
|
||||
d: integer;
|
||||
d: integer;
|
||||
begin
|
||||
ColorToCMYK(c, d, d, d, Result);
|
||||
ColorToCMYK(c, d, d, d, Result);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -7,17 +7,17 @@ unit RGBHSLUtils;
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType,
|
||||
{$ELSE}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
Graphics, Math, Scanlines;
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType,
|
||||
{$ELSE}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
Graphics, Math, Scanlines;
|
||||
|
||||
var //set these variables to your needs, e.g. 360, 255, 255
|
||||
MaxHue: integer = 359; //239;
|
||||
MaxSat: integer = 100; //240;
|
||||
MaxLum: integer = 100; //240;
|
||||
MaxHue: integer = 359; //239;
|
||||
MaxSat: integer = 100; //240;
|
||||
MaxLum: integer = 100; //240;
|
||||
|
||||
function HSLtoRGB (H, S, L: double): TColor;
|
||||
function HSLRangeToRGB (H, S, L: integer): TColor;
|
||||
@ -33,138 +33,127 @@ procedure RGBTripleToHSL(RGBTriple : TRGBTriple; var h, s, l: integer);
|
||||
implementation
|
||||
|
||||
uses
|
||||
mbUtils;
|
||||
mbUtils;
|
||||
|
||||
function HSLtoRGB(H, S, L: double): TColor;
|
||||
var
|
||||
M1, M2: double;
|
||||
M1, M2: double;
|
||||
|
||||
function HueToColorValue(Hue: double): byte;
|
||||
var
|
||||
V : double;
|
||||
V : double;
|
||||
begin
|
||||
if Hue < 0 then
|
||||
Hue := Hue + 1
|
||||
else
|
||||
if Hue > 1 then
|
||||
Hue := Hue - 1;
|
||||
if 6 * Hue < 1 then
|
||||
V := M1 + (M2 - M1) * Hue * 6
|
||||
else
|
||||
if 2 * Hue < 1 then
|
||||
V := M2
|
||||
else
|
||||
if 3 * Hue < 2 then
|
||||
if Hue < 0 then
|
||||
Hue := Hue + 1
|
||||
else if Hue > 1 then
|
||||
Hue := Hue - 1;
|
||||
if 6 * Hue < 1 then
|
||||
V := M1 + (M2 - M1) * Hue * 6
|
||||
else if 2 * Hue < 1 then
|
||||
V := M2
|
||||
else if 3 * Hue < 2 then
|
||||
V := M1 + (M2 - M1) * (2/3 - Hue) * 6
|
||||
else
|
||||
else
|
||||
V := M1;
|
||||
Result := round (255 * V)
|
||||
Result := round (255 * V)
|
||||
end;
|
||||
|
||||
var
|
||||
R, G, B: byte;
|
||||
R, G, B: byte;
|
||||
begin
|
||||
if S = 0 then
|
||||
if S = 0 then
|
||||
begin
|
||||
R := round (MaxLum * L);
|
||||
G := R;
|
||||
B := R
|
||||
R := round(MaxLum * L);
|
||||
G := R;
|
||||
B := R
|
||||
end
|
||||
else
|
||||
else
|
||||
begin
|
||||
if L <= 0.5 then
|
||||
M2 := L * (1 + S)
|
||||
else
|
||||
M2 := L + S - L * S;
|
||||
M1 := 2 * L - M2;
|
||||
R := HueToColorValue (H + 1/3);
|
||||
G := HueToColorValue (H);
|
||||
B := HueToColorValue (H - 1/3)
|
||||
if L <= 0.5 then
|
||||
M2 := L * (1 + S)
|
||||
else
|
||||
M2 := L + S - L * S;
|
||||
M1 := 2 * L - M2;
|
||||
R := HueToColorValue(H + 1/3);
|
||||
G := HueToColorValue(H);
|
||||
B := HueToColorValue(H - 1/3)
|
||||
end;
|
||||
Result := RGB (R, G, B)
|
||||
Result := RGB(R, G, B)
|
||||
end;
|
||||
|
||||
function HSLRangeToRGB(H, S, L : integer): TColor;
|
||||
function HSLRangeToRGB(H, S, L: integer): TColor;
|
||||
begin
|
||||
if s > MaxSat then s := MaxSat;
|
||||
if s < 0 then s := 0;
|
||||
if l > MaxLum then l := MaxLum;
|
||||
if l < 0 then l := 0;
|
||||
Result := HSLToRGB(H / MaxHue, S / MaxSat, L / MaxLum);
|
||||
Clamp(H, 0, MaxHue);
|
||||
Clamp(S, 0, MaxSat);
|
||||
Clamp(L, 0, MaxLum);
|
||||
Result := HSLToRGB(H / MaxHue, S / MaxSat, L / MaxLum);
|
||||
end;
|
||||
|
||||
procedure RGBtoHSLRange(RGB: TColor; var H1, S1, L1 : integer);
|
||||
procedure RGBtoHSLRange(RGB: TColor; var H1, S1, L1: integer);
|
||||
var
|
||||
R, G, B, D, Cmax, Cmin, h, s, l: double;
|
||||
begin
|
||||
H := h1;
|
||||
S := s1;
|
||||
L := l1;
|
||||
R := GetRValue (RGB) / 255;
|
||||
G := GetGValue (RGB) / 255;
|
||||
B := GetBValue (RGB) / 255;
|
||||
Cmax := Max (R, Max (G, B));
|
||||
Cmin := Min (R, Min (G, B));
|
||||
L := (Cmax + Cmin) / 2;
|
||||
if Cmax = Cmin then
|
||||
H := h1;
|
||||
S := s1;
|
||||
L := l1;
|
||||
R := GetRValue(RGB) / 255;
|
||||
G := GetGValue(RGB) / 255;
|
||||
B := GetBValue(RGB) / 255;
|
||||
Cmax := Max(R, Max (G, B));
|
||||
Cmin := Min(R, Min (G, B));
|
||||
L := (Cmax + Cmin) / 2;
|
||||
if Cmax = Cmin then
|
||||
begin
|
||||
H := 0;
|
||||
S := 0;
|
||||
H := 0;
|
||||
S := 0;
|
||||
end
|
||||
else
|
||||
else
|
||||
begin
|
||||
D := Cmax - Cmin;
|
||||
//calc L
|
||||
if L < 0.5 then
|
||||
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
|
||||
D := Cmax - Cmin;
|
||||
//calc L
|
||||
if L < 0.5 then
|
||||
S := D / (Cmax + Cmin)
|
||||
else
|
||||
H := 4 + (R - G) / D;
|
||||
H := H / 6;
|
||||
if H < 0 then
|
||||
H := H + 1;
|
||||
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
|
||||
H := 4 + (R - G) / D;
|
||||
H := H / 6;
|
||||
if H < 0 then
|
||||
H := H + 1;
|
||||
end;
|
||||
H1 := round (H * MaxHue);
|
||||
S1 := round (S * MaxSat);
|
||||
L1 := round (L * MaxLum);
|
||||
H1 := round(H * MaxHue);
|
||||
S1 := round(S * MaxSat);
|
||||
L1 := round(L * MaxLum);
|
||||
end;
|
||||
|
||||
function GetHValue(AColor: TColor): integer;
|
||||
var
|
||||
d, h: integer;
|
||||
d, h: integer;
|
||||
begin
|
||||
RGBToHSLRange(AColor, h, d, d);
|
||||
Result := h;
|
||||
RGBToHSLRange(AColor, h, d, d);
|
||||
Result := h;
|
||||
end;
|
||||
|
||||
function GetSValue(AColor: TColor): integer;
|
||||
var
|
||||
d, s: integer;
|
||||
d, s: integer;
|
||||
begin
|
||||
RGBToHSLRange(AColor, d, s, d);
|
||||
Result := s;
|
||||
RGBToHSLRange(AColor, d, s, d);
|
||||
Result := s;
|
||||
end;
|
||||
|
||||
function GetLValue(AColor: TColor): integer;
|
||||
var
|
||||
d, l: integer;
|
||||
d, l: integer;
|
||||
begin
|
||||
RGBToHSLRange(AColor, d, d, l);
|
||||
Result := l;
|
||||
RGBToHSLRange(AColor, d, d, l);
|
||||
Result := l;
|
||||
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;
|
||||
const
|
||||
@ -234,44 +223,43 @@ end;
|
||||
|
||||
procedure RGBTripleToHSL(RGBTriple: TRGBTriple; var h, s, l: integer);
|
||||
|
||||
function RGBMaxValue(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 RGBMaxValue(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;
|
||||
|
||||
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
|
||||
Delta, Min: byte;
|
||||
Delta, Min: byte;
|
||||
begin
|
||||
L := RGBMaxValue(RGBTriple);
|
||||
Min := RGBMinValue(RGBTriple);
|
||||
Delta := L-Min;
|
||||
if (L = Min) then
|
||||
L := RGBMaxValue(RGBTriple);
|
||||
Min := RGBMinValue(RGBTriple);
|
||||
Delta := L-Min;
|
||||
if (L = Min) then
|
||||
begin
|
||||
H := 0;
|
||||
S := 0;
|
||||
H := 0;
|
||||
S := 0;
|
||||
end
|
||||
else
|
||||
else
|
||||
begin
|
||||
S := MulDiv(Delta, 255, L);
|
||||
with RGBTriple do
|
||||
S := MulDiv(Delta, 255, L);
|
||||
with RGBTriple do
|
||||
begin
|
||||
if (rgbtRed = L) then
|
||||
H := MulDiv(60, rgbtGreen-rgbtBlue, Delta)
|
||||
else
|
||||
if (rgbtGreen = L) then
|
||||
H := MulDiv(60, rgbtBlue-rgbtRed, Delta) + 120
|
||||
else
|
||||
if (rgbtBlue = L) then
|
||||
if (rgbtRed = L) then
|
||||
H := MulDiv(60, rgbtGreen-rgbtBlue, Delta)
|
||||
else if (rgbtGreen = L) then
|
||||
H := MulDiv(60, rgbtBlue-rgbtRed, Delta) + 120
|
||||
else if (rgbtBlue = L) then
|
||||
H := MulDiv(60, rgbtRed-rgbtGreen, Delta) + 240;
|
||||
if (H < 0) then H := H + 360;
|
||||
if (H < 0) then H := H + 360;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -7,12 +7,12 @@ unit RGBHSVUtils;
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType,
|
||||
{$ELSE}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Graphics, Math, Scanlines;
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType,
|
||||
{$ELSE}
|
||||
Windows,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Graphics, Math, Scanlines;
|
||||
|
||||
function RGBtoRGBTriple(R, G, B: byte): TRGBTriple;
|
||||
function RGBtoRGBQuad(R, G, B: byte): TRGBQuad;
|
||||
@ -29,144 +29,142 @@ implementation
|
||||
|
||||
function RGBtoRGBTriple(R, G, B: byte): TRGBTriple;
|
||||
begin
|
||||
with Result do
|
||||
with Result do
|
||||
begin
|
||||
rgbtRed := R;
|
||||
rgbtGreen := G;
|
||||
rgbtBlue := B;
|
||||
rgbtRed := R;
|
||||
rgbtGreen := G;
|
||||
rgbtBlue := B;
|
||||
end
|
||||
end;
|
||||
|
||||
function RGBtoRGBQuad(R, G, B: byte): TRGBQuad;
|
||||
begin
|
||||
with Result do
|
||||
with Result do
|
||||
begin
|
||||
rgbRed := R;
|
||||
rgbGreen := G;
|
||||
rgbBlue := B;
|
||||
rgbReserved := 0;
|
||||
rgbRed := R;
|
||||
rgbGreen := G;
|
||||
rgbBlue := B;
|
||||
rgbReserved := 0;
|
||||
end
|
||||
end;
|
||||
|
||||
function RGBTripleToColor(Triple: TRGBTriple): TColor;
|
||||
begin
|
||||
Result := TColor(RGB(Triple.rgbtRed, Triple.rgbtGreen, Triple.rgbtBlue));
|
||||
Result := RGB(Triple.rgbtRed, Triple.rgbtGreen, Triple.rgbtBlue);
|
||||
end;
|
||||
|
||||
procedure RGBToHSV(R, G, B: integer; var H, S, V: integer);
|
||||
var
|
||||
Delta, Min, H1, S1: real;
|
||||
Delta, Min, H1, S1: double;
|
||||
begin
|
||||
h1 := h;
|
||||
s1 := s;
|
||||
Min := MinIntValue([R, G, B]);
|
||||
V := MaxIntValue([R, G, B]);
|
||||
Delta := V - Min;
|
||||
if V = 0.0 then S1 := 0 else S1 := Delta / V;
|
||||
if S1 = 0.0 then
|
||||
H1 := 0
|
||||
else
|
||||
h1 := h;
|
||||
s1 := s;
|
||||
Min := MinIntValue([R, G, B]);
|
||||
V := MaxIntValue([R, G, B]);
|
||||
Delta := V - Min;
|
||||
if V = 0.0 then S1 := 0 else S1 := Delta / V;
|
||||
if S1 = 0.0 then
|
||||
H1 := 0
|
||||
else
|
||||
begin
|
||||
if R = V then
|
||||
H1 := 60.0 * (G - B) / Delta
|
||||
else
|
||||
if G = V then
|
||||
H1 := 120.0 + 60.0 * (B - R) / Delta
|
||||
else
|
||||
if B = V then
|
||||
if R = V then
|
||||
H1 := 60.0 * (G - B) / Delta
|
||||
else if G = V then
|
||||
H1 := 120.0 + 60.0 * (B - R) / Delta
|
||||
else if B = V then
|
||||
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;
|
||||
h := round(h1);
|
||||
s := round(s1*255);
|
||||
h := round(h1);
|
||||
s := round(s1*255);
|
||||
end;
|
||||
|
||||
function HSVtoRGBTriple(H, S, V: integer): TRGBTriple;
|
||||
const
|
||||
divisor: integer = 255*60;
|
||||
divisor: integer = 255*60;
|
||||
var
|
||||
f, hTemp, p, q, t, VS: integer;
|
||||
f, hTemp, p, q, t, VS: integer;
|
||||
begin
|
||||
if H > 360 then H := H - 360;
|
||||
if H < 0 then H := H + 360;
|
||||
if s = 0 then
|
||||
Result := RGBtoRGBTriple(V, V, V)
|
||||
else
|
||||
if H > 360 then H := H - 360;
|
||||
if H < 0 then H := H + 360;
|
||||
if s = 0 then
|
||||
Result := RGBtoRGBTriple(V, V, V)
|
||||
else
|
||||
begin
|
||||
if H = 360 then hTemp := 0 else hTemp := H;
|
||||
f := hTemp mod 60;
|
||||
hTemp := hTemp div 60;
|
||||
VS := V*S;
|
||||
p := V - VS div 255;
|
||||
q := V - (VS*f) div divisor;
|
||||
t := V - (VS*(60 - f)) div divisor;
|
||||
case hTemp of
|
||||
0: Result := RGBtoRGBTriple(V, t, p);
|
||||
1: Result := RGBtoRGBTriple(q, V, p);
|
||||
2: Result := RGBtoRGBTriple(p, V, t);
|
||||
3: Result := RGBtoRGBTriple(p, q, V);
|
||||
4: Result := RGBtoRGBTriple(t, p, V);
|
||||
5: Result := RGBtoRGBTriple(V, p, q);
|
||||
else Result := RGBtoRGBTriple(0,0,0)
|
||||
end;
|
||||
if H = 360 then hTemp := 0 else hTemp := H;
|
||||
f := hTemp mod 60;
|
||||
hTemp := hTemp div 60;
|
||||
VS := V*S;
|
||||
p := V - VS div 255;
|
||||
q := V - (VS*f) div divisor;
|
||||
t := V - (VS*(60 - f)) div divisor;
|
||||
case hTemp of
|
||||
0: Result := RGBtoRGBTriple(V, t, p);
|
||||
1: Result := RGBtoRGBTriple(q, V, p);
|
||||
2: Result := RGBtoRGBTriple(p, V, t);
|
||||
3: Result := RGBtoRGBTriple(p, q, V);
|
||||
4: Result := RGBtoRGBTriple(t, p, V);
|
||||
5: Result := RGBtoRGBTriple(V, p, q);
|
||||
else Result := RGBtoRGBTriple(0,0,0)
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function HSVtoRGBQuad(H, S, V: integer): TRGBQuad;
|
||||
const
|
||||
divisor: integer = 255*60;
|
||||
divisor: integer = 255*60;
|
||||
var
|
||||
f, hTemp, p, q, t, VS: integer;
|
||||
f, hTemp, p, q, t, VS: integer;
|
||||
begin
|
||||
if H > 360 then H := H - 360;
|
||||
if H < 0 then H := H + 360;
|
||||
if s = 0 then
|
||||
Result := RGBtoRGBQuad(V, V, V)
|
||||
else
|
||||
if H > 360 then H := H - 360;
|
||||
if H < 0 then H := H + 360;
|
||||
if s = 0 then
|
||||
Result := RGBtoRGBQuad(V, V, V)
|
||||
else
|
||||
begin
|
||||
if H = 360 then hTemp := 0 else hTemp := H;
|
||||
f := hTemp mod 60;
|
||||
hTemp := hTemp div 60;
|
||||
VS := V*S;
|
||||
p := V - VS div 255;
|
||||
q := V - (VS*f) div divisor;
|
||||
t := V - (VS*(60 - f)) div divisor;
|
||||
case hTemp of
|
||||
0: Result := RGBtoRGBQuad(V, t, p);
|
||||
1: Result := RGBtoRGBQuad(q, V, p);
|
||||
2: Result := RGBtoRGBQuad(p, V, t);
|
||||
3: Result := RGBtoRGBQuad(p, q, V);
|
||||
4: Result := RGBtoRGBQuad(t, p, V);
|
||||
5: Result := RGBtoRGBQuad(V, p, q);
|
||||
else Result := RGBtoRGBQuad(0,0,0)
|
||||
end;
|
||||
if H = 360 then hTemp := 0 else hTemp := H;
|
||||
f := hTemp mod 60;
|
||||
hTemp := hTemp div 60;
|
||||
VS := V*S;
|
||||
p := V - VS div 255;
|
||||
q := V - (VS*f) div divisor;
|
||||
t := V - (VS*(60 - f)) div divisor;
|
||||
case hTemp of
|
||||
0: Result := RGBtoRGBQuad(V, t, p);
|
||||
1: Result := RGBtoRGBQuad(q, V, p);
|
||||
2: Result := RGBtoRGBQuad(p, V, t);
|
||||
3: Result := RGBtoRGBQuad(p, q, V);
|
||||
4: Result := RGBtoRGBQuad(t, p, V);
|
||||
5: Result := RGBtoRGBQuad(V, p, q);
|
||||
else Result := RGBtoRGBQuad(0,0,0)
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function HSVtoColor(H, S, V: integer): TColor;
|
||||
begin
|
||||
Result := RGBTripleToColor(HSVtoRGBTriple(H, S, V));
|
||||
Result := RGBTripleToColor(HSVtoRGBTriple(H, S, V));
|
||||
end;
|
||||
|
||||
function GetHValue(Color: TColor): integer;
|
||||
var
|
||||
s, v: integer;
|
||||
s, v: integer;
|
||||
begin
|
||||
RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), Result, s, v);
|
||||
RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), Result, s, v);
|
||||
end;
|
||||
|
||||
function GetSValue(Color: TColor): integer;
|
||||
var
|
||||
h, v: integer;
|
||||
h, v: integer;
|
||||
begin
|
||||
RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), h, Result, v);
|
||||
RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), h, Result, v);
|
||||
end;
|
||||
|
||||
function GetVValue(Color: TColor): integer;
|
||||
var
|
||||
h, s: integer;
|
||||
h, s: integer;
|
||||
begin
|
||||
RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), h, s, Result);
|
||||
RGBToHSV(GetRValue(Color), GetGValue(Color), GetBValue(Color), h, s, Result);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -7,38 +7,38 @@ unit SColorPicker;
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType, LMessages,
|
||||
{$ELSE}
|
||||
Windows, Messages,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Controls, Graphics, Forms,
|
||||
RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines;
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType, LMessages,
|
||||
{$ELSE}
|
||||
Windows, Messages,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Controls, Graphics, Forms,
|
||||
RGBHSVUtils, mbTrackBarPicker, HTMLColors, Scanlines;
|
||||
|
||||
type
|
||||
TSColorPicker = class(TmbTrackBarPicker)
|
||||
private
|
||||
FVal, FHue, FSat: integer;
|
||||
function ArrowPosFromSat(s: integer): integer;
|
||||
function SatFromArrowPos(p: integer): integer;
|
||||
function GetSelectedColor: TColor;
|
||||
procedure SetSelectedColor(c: TColor);
|
||||
procedure SetHue(h: integer);
|
||||
procedure SetSat(s: integer);
|
||||
procedure SetValue(v: integer);
|
||||
protected
|
||||
procedure Execute(tbaAction: integer); override;
|
||||
function GetArrowPos: integer; override;
|
||||
function GetGradientColor(AValue: Integer): TColor; override;
|
||||
function GetSelectedValue: integer; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Hue: integer read FHue write SetHue default 0;
|
||||
property Saturation: integer read FSat write SetSat default 255;
|
||||
property Value: integer read FVal write SetValue default 255;
|
||||
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
|
||||
end;
|
||||
TSColorPicker = class(TmbTrackBarPicker)
|
||||
private
|
||||
FVal, FHue, FSat: integer;
|
||||
function ArrowPosFromSat(s: integer): integer;
|
||||
function SatFromArrowPos(p: integer): integer;
|
||||
function GetSelectedColor: TColor;
|
||||
procedure SetSelectedColor(c: TColor);
|
||||
procedure SetHue(h: integer);
|
||||
procedure SetSat(s: integer);
|
||||
procedure SetValue(v: integer);
|
||||
protected
|
||||
procedure Execute(tbaAction: integer); override;
|
||||
function GetArrowPos: integer; override;
|
||||
function GetGradientColor(AValue: Integer): TColor; override;
|
||||
function GetSelectedValue: integer; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Hue: integer read FHue write SetHue default 0;
|
||||
property Saturation: integer read FSat write SetSat default 255;
|
||||
property Value: integer read FVal write SetValue default 255;
|
||||
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
@ -92,19 +92,19 @@ end;
|
||||
|
||||
procedure TScreenForm.FormShow(Sender: TObject);
|
||||
begin
|
||||
Width := Screen.Width;
|
||||
Height := Screen.Height;
|
||||
Left := 0;
|
||||
Top := 0;
|
||||
Width := Screen.Width;
|
||||
Height := Screen.Height;
|
||||
Left := 0;
|
||||
Top := 0;
|
||||
end;
|
||||
|
||||
procedure TScreenForm.FormCreate(Sender: TObject);
|
||||
begin
|
||||
Brush.Style := bsClear;
|
||||
Screen.Cursors[crPickerCursor] := LoadCursor(HInstance, 'PickerCursor');
|
||||
Cursor := crPickerCursor;
|
||||
SelectedColor := clNone;
|
||||
FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: %h';
|
||||
Brush.Style := bsClear;
|
||||
Screen.Cursors[crPickerCursor] := LoadCursor(HInstance, 'PickerCursor');
|
||||
Cursor := crPickerCursor;
|
||||
SelectedColor := clNone;
|
||||
FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: %h';
|
||||
end;
|
||||
|
||||
procedure TScreenForm.FormKeyDown(Sender: TObject; var Key: Word;
|
||||
@ -132,7 +132,7 @@ end;
|
||||
procedure TScreenForm.FormMouseUp(Sender: TObject; Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
EndSelection(x, y, true);
|
||||
EndSelection(x, y, true);
|
||||
end;
|
||||
|
||||
procedure TScreenForm.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
|
||||
|
||||
@ -23,58 +23,58 @@ implementation
|
||||
|
||||
procedure DrawSelCross(x, y: integer; Canvas: TCanvas; Color: TColor);
|
||||
const
|
||||
w = 5;
|
||||
h = 3;
|
||||
o = 8;
|
||||
w = 5;
|
||||
h = 3;
|
||||
o = 8;
|
||||
var
|
||||
R: TRect;
|
||||
R: TRect;
|
||||
begin
|
||||
R := Rect(x-10, y-10, x+9, y+9);
|
||||
Canvas.Brush.Color := Color;
|
||||
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.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));
|
||||
R := Rect(x-10, y-10, x+9, y+9);
|
||||
Canvas.Brush.Color := Color;
|
||||
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.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));
|
||||
end;
|
||||
|
||||
procedure DrawSelCrossCirc(x, y: integer; Canvas: TCanvas; Color: TColor);
|
||||
var
|
||||
R: TRect;
|
||||
R: TRect;
|
||||
begin
|
||||
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 - 1, y - 6, x + 1, y + 6);
|
||||
Canvas.Pen.Color := Color;
|
||||
Canvas.Brush.Style := bsClear;
|
||||
InflateRect(R, -1, -1);
|
||||
Canvas.Ellipse(R);
|
||||
InflateRect(R, -1, -1);
|
||||
Canvas.Ellipse(R);
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
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 - 1, y - 6, x + 1, y + 6);
|
||||
Canvas.Pen.Color := Color;
|
||||
Canvas.Brush.Style := bsClear;
|
||||
InflateRect(R, -1, -1);
|
||||
Canvas.Ellipse(R);
|
||||
InflateRect(R, -1, -1);
|
||||
Canvas.Ellipse(R);
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
end;
|
||||
|
||||
procedure DrawSelCirc(x, y: integer; Canvas: TCanvas);
|
||||
var
|
||||
R: TRect;
|
||||
R: TRect;
|
||||
begin
|
||||
R := Rect(x - 5, y - 5, x + 5, y + 5);
|
||||
Canvas.Brush.Style := bsClear;
|
||||
Canvas.Pen.Mode := pmNot;
|
||||
Canvas.Ellipse(R);
|
||||
Canvas.Pen.Mode := pmCopy;
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
R := Rect(x - 5, y - 5, x + 5, y + 5);
|
||||
Canvas.Brush.Style := bsClear;
|
||||
Canvas.Pen.Mode := pmNot;
|
||||
Canvas.Ellipse(R);
|
||||
Canvas.Pen.Mode := pmCopy;
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
end;
|
||||
|
||||
procedure DrawSelSquare(x, y: integer; Canvas: TCanvas);
|
||||
var
|
||||
R: TRect;
|
||||
R: TRect;
|
||||
begin
|
||||
R := Rect(x - 5, y - 5, x + 5, y + 5);
|
||||
Canvas.Brush.Style := bsClear;
|
||||
Canvas.Pen.Mode := pmNot;
|
||||
Canvas.Rectangle(R);
|
||||
Canvas.Pen.Mode := pmCopy;
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
R := Rect(x - 5, y - 5, x + 5, y + 5);
|
||||
Canvas.Brush.Style := bsClear;
|
||||
Canvas.Pen.Mode := pmNot;
|
||||
Canvas.Rectangle(R);
|
||||
Canvas.Pen.Mode := pmCopy;
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -7,42 +7,41 @@ interface
|
||||
{$ENDIF}
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType, LMessages,
|
||||
{$ELSE}
|
||||
Windows, Messages,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Controls, Graphics, Forms,
|
||||
RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines;
|
||||
{$IFDEF FPC}
|
||||
LCLIntf, LCLType, LMessages,
|
||||
{$ELSE}
|
||||
Windows, Messages,
|
||||
{$ENDIF}
|
||||
SysUtils, Classes, Controls, Graphics, Forms,
|
||||
RGBCMYKUtils, mbTrackBarPicker, HTMLColors, Scanlines;
|
||||
|
||||
type
|
||||
TYColorPicker = class(TmbTrackBarPicker)
|
||||
private
|
||||
FYellow, FMagenta, FCyan, FBlack: integer;
|
||||
|
||||
function ArrowPosFromYellow(y: integer): integer;
|
||||
function YellowFromArrowPos(p: integer): integer;
|
||||
function GetSelectedColor: TColor;
|
||||
procedure SetSelectedColor(c: TColor);
|
||||
procedure SetYellow(y: integer);
|
||||
procedure SetMagenta(m: integer);
|
||||
procedure SetCyan(c: integer);
|
||||
procedure SetBlack(k: integer);
|
||||
protected
|
||||
procedure Execute(tbaAction: integer); override;
|
||||
function GetArrowPos: integer; override;
|
||||
function GetGradientColor(AValue: Integer): TColor; override;
|
||||
function GetSelectedValue: integer; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Yellow: integer read FYellow write SetYellow default 255;
|
||||
property Magenta: integer read FMagenta write SetMagenta default 0;
|
||||
property Cyan: integer read FCyan write SetCyan default 0;
|
||||
property Black: integer read FBlack write SetBlack default 0;
|
||||
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
|
||||
property Layout default lyVertical;
|
||||
end;
|
||||
TYColorPicker = class(TmbTrackBarPicker)
|
||||
private
|
||||
FYellow, FMagenta, FCyan, FBlack: integer;
|
||||
function ArrowPosFromYellow(y: integer): integer;
|
||||
function YellowFromArrowPos(p: integer): integer;
|
||||
function GetSelectedColor: TColor;
|
||||
procedure SetSelectedColor(c: TColor);
|
||||
procedure SetYellow(y: integer);
|
||||
procedure SetMagenta(m: integer);
|
||||
procedure SetCyan(c: integer);
|
||||
procedure SetBlack(k: integer);
|
||||
protected
|
||||
procedure Execute(tbaAction: integer); override;
|
||||
function GetArrowPos: integer; override;
|
||||
function GetGradientColor(AValue: Integer): TColor; override;
|
||||
function GetSelectedValue: integer; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Yellow: integer read FYellow write SetYellow default 255;
|
||||
property Magenta: integer read FMagenta write SetMagenta default 0;
|
||||
property Cyan: integer read FCyan write SetCyan default 0;
|
||||
property Black: integer read FBlack write SetBlack default 0;
|
||||
property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clRed;
|
||||
property Layout default lyVertical;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
@ -166,271 +166,264 @@ end;
|
||||
|
||||
constructor TmbColorList.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
MaxHue := 360;
|
||||
MaxSat := 255;
|
||||
MaxLum := 255;
|
||||
style := lbOwnerDrawFixed;
|
||||
SetLength(Colors, 0);
|
||||
ItemHeight := 48;
|
||||
IntegralHeight := true;
|
||||
mx := -1;
|
||||
my := -1;
|
||||
inherited;
|
||||
{
|
||||
MaxHue := 360;
|
||||
MaxSat := 255;
|
||||
MaxLum := 255;
|
||||
}
|
||||
style := lbOwnerDrawFixed;
|
||||
SetLength(Colors, 0);
|
||||
ItemHeight := 48;
|
||||
IntegralHeight := true;
|
||||
mx := -1;
|
||||
my := -1;
|
||||
end;
|
||||
|
||||
procedure TmbColorList.UpdateColors;
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
Items.Clear;
|
||||
for i := 0 to Length(Colors) - 1 do
|
||||
Items.Add(Colors[i].name);
|
||||
Items.Clear;
|
||||
for i := 0 to Length(Colors) - 1 do
|
||||
Items.Add(Colors[i].name);
|
||||
end;
|
||||
|
||||
procedure TmbColorList.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
|
||||
var
|
||||
SR, TR, R: TRect;
|
||||
itemText: string;
|
||||
SR, TR, R: TRect;
|
||||
itemText: string;
|
||||
begin
|
||||
if Length(Colors) = 0 then Exit;
|
||||
R := Rect;
|
||||
with Canvas do
|
||||
if Length(Colors) = 0 then Exit;
|
||||
R := Rect;
|
||||
with Canvas do
|
||||
begin
|
||||
//background
|
||||
Pen.Color := clWindow;
|
||||
if odSelected in State then
|
||||
Brush.Color := clHighlight
|
||||
else
|
||||
Brush.Color := self.Color; //clBtnFace;
|
||||
FillRect(R);
|
||||
MoveTo(R.Left, R.Bottom - 1);
|
||||
LineTo(R.Right, R.Bottom - 1);
|
||||
//swatches
|
||||
SR := Classes.Rect(R.Left + 6, R.Top + 6, R.Left + ItemHeight - 6, R.Top + ItemHeight - 6);
|
||||
Brush.Color := Self.Colors[Index].value;
|
||||
if odSelected in State then
|
||||
//background
|
||||
Pen.Color := clWindow;
|
||||
if odSelected in State then
|
||||
Brush.Color := clHighlight
|
||||
else
|
||||
Brush.Color := self.Color; //clBtnFace;
|
||||
FillRect(R);
|
||||
MoveTo(R.Left, R.Bottom - 1);
|
||||
LineTo(R.Right, R.Bottom - 1);
|
||||
//swatches
|
||||
SR := Classes.Rect(R.Left + 6, R.Top + 6, R.Left + ItemHeight - 6, R.Top + ItemHeight - 6);
|
||||
Brush.Color := Self.Colors[Index].value;
|
||||
if odSelected in State then
|
||||
begin
|
||||
{$IFDEF DELPHI_7_UP}
|
||||
if ThemeServices.ThemesEnabled then
|
||||
{$IFDEF DELPHI_7_UP}
|
||||
if ThemeServices.ThemesEnabled then
|
||||
begin
|
||||
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
|
||||
InflateRect(SR, -2, -2);
|
||||
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80);
|
||||
FillRect(SR);
|
||||
InflateRect(SR, -1, -1);
|
||||
Brush.Color := Blend(self.Colors[Index].value, clBlack, 90);
|
||||
FillRect(SR);
|
||||
InflateRect(SR, -1, -1);
|
||||
Brush.Color := Self.Colors[Index].value;
|
||||
FillRect(SR);
|
||||
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
|
||||
InflateRect(SR, -2, -2);
|
||||
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 80);
|
||||
FillRect(SR);
|
||||
InflateRect(SR, -1, -1);
|
||||
Brush.Color := Blend(self.Colors[Index].value, clBlack, 90);
|
||||
FillRect(SR);
|
||||
InflateRect(SR, -1, -1);
|
||||
Brush.Color := Self.Colors[Index].value;
|
||||
FillRect(SR);
|
||||
end
|
||||
else
|
||||
//windows 9x
|
||||
else
|
||||
//windows 9x
|
||||
begin
|
||||
{$ENDIF}
|
||||
Pen.Color := clBackground;
|
||||
Brush.Color := clWindow;
|
||||
Rectangle(SR);
|
||||
InflateRect(SR, -1, -1);
|
||||
FillRect(SR);
|
||||
InflateRect(SR, 1, 1);
|
||||
InflateRect(SR, -2, -2);
|
||||
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 75);
|
||||
FillRect(SR);
|
||||
InflateRect(SR, -1, -1);
|
||||
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 87);
|
||||
FillRect(SR);
|
||||
InflateRect(SR, -1, -1);
|
||||
Brush.Color := Self.Colors[Index].value;
|
||||
FillRect(SR);
|
||||
{$IFDEF DELPHI_7_UP}
|
||||
Pen.Color := clBackground;
|
||||
Brush.Color := clWindow;
|
||||
Rectangle(SR);
|
||||
InflateRect(SR, -1, -1);
|
||||
FillRect(SR);
|
||||
InflateRect(SR, 1, 1);
|
||||
InflateRect(SR, -2, -2);
|
||||
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 75);
|
||||
FillRect(SR);
|
||||
InflateRect(SR, -1, -1);
|
||||
Brush.Color := Blend(Self.Colors[Index].value, clBlack, 87);
|
||||
FillRect(SR);
|
||||
InflateRect(SR, -1, -1);
|
||||
Brush.Color := Self.Colors[Index].value;
|
||||
FillRect(SR);
|
||||
{$IFDEF DELPHI_7_UP}
|
||||
end;
|
||||
{$ENDIF}
|
||||
end
|
||||
else
|
||||
else
|
||||
//not selected
|
||||
begin
|
||||
//windows XP
|
||||
//windows XP
|
||||
{$IFDEF DELPHI_7_UP}
|
||||
if ThemeServices.ThemesEnabled then
|
||||
if ThemeServices.ThemesEnabled then
|
||||
begin
|
||||
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
|
||||
InflateRect(SR, -2, -2);
|
||||
Brush.Color := Self.Colors[Index].value;
|
||||
FillRect(SR);
|
||||
ThemeServices.DrawElement(Canvas.Handle, ThemeServices.GetElementDetails(teEditTextNormal), SR);
|
||||
InflateRect(SR, -2, -2);
|
||||
Brush.Color := Self.Colors[Index].value;
|
||||
FillRect(SR);
|
||||
end
|
||||
else
|
||||
//windows 9x
|
||||
else
|
||||
//windows 9x
|
||||
begin
|
||||
{$ENDIF}
|
||||
DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT);
|
||||
InflateRect(SR, -2, -2);
|
||||
Brush.Color := Self.Colors[Index].value;
|
||||
Pen.Color := clBlack;
|
||||
Rectangle(SR);
|
||||
InflateRect(SR, -1, -1);
|
||||
FillRect(SR);
|
||||
InflateRect(SR, 1, 1);
|
||||
DrawEdge(Canvas.Handle, SR, BDR_SUNKENOUTER, BF_RECT);
|
||||
InflateRect(SR, -2, -2);
|
||||
Brush.Color := Self.Colors[Index].value;
|
||||
Pen.Color := clBlack;
|
||||
Rectangle(SR);
|
||||
InflateRect(SR, -1, -1);
|
||||
FillRect(SR);
|
||||
InflateRect(SR, 1, 1);
|
||||
{$IFDEF DELPHI_7_UP}
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
//names
|
||||
Font.Style := [fsBold];
|
||||
if odSelected in State then
|
||||
//names
|
||||
Font.Style := [fsBold];
|
||||
if odSelected in State then
|
||||
begin
|
||||
Brush.Color := clHighlight;
|
||||
Pen.Color := clHighlightText;
|
||||
Font.Color := clHighlightText;
|
||||
Brush.Color := clHighlight;
|
||||
Pen.Color := clHighlightText;
|
||||
Font.Color := clHighlightText;
|
||||
end
|
||||
else
|
||||
else
|
||||
begin
|
||||
Brush.Color := clBtnFace;
|
||||
Pen.Color := clWindowText;
|
||||
Font.Color := clWindowText;
|
||||
Brush.Color := clBtnFace;
|
||||
Pen.Color := clWindowText;
|
||||
Font.Color := clWindowText;
|
||||
end;
|
||||
itemText := Items.Strings[Index];
|
||||
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);
|
||||
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);
|
||||
end;
|
||||
itemText := Items.Strings[Index];
|
||||
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);
|
||||
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);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorList.AddColor(Name: string; Value: TColor; refresh: boolean = true);
|
||||
var
|
||||
l: integer;
|
||||
l: integer;
|
||||
begin
|
||||
l := Length(Colors);
|
||||
SetLength(Colors, l + 1);
|
||||
Colors[l].name := Name;
|
||||
Colors[l].value := Value;
|
||||
if refresh then
|
||||
UpdateColors;
|
||||
l := Length(Colors);
|
||||
SetLength(Colors, l + 1);
|
||||
Colors[l].name := Name;
|
||||
Colors[l].value := Value;
|
||||
if refresh then
|
||||
UpdateColors;
|
||||
end;
|
||||
|
||||
procedure TmbColorList.ClearColors;
|
||||
begin
|
||||
SetLength(Colors, 0);
|
||||
UpdateColors;
|
||||
SetLength(Colors, 0);
|
||||
UpdateColors;
|
||||
end;
|
||||
|
||||
function TmbColorList.ColorCount: integer;
|
||||
begin
|
||||
Result := Length(Colors);
|
||||
Result := Length(Colors);
|
||||
end;
|
||||
|
||||
procedure TmbColorList.DeleteColor(Index: integer; refresh: boolean = true);
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
if Length(Colors) = 0 then
|
||||
begin
|
||||
raise Exception.Create('There''s nothing to delete! The length of the array is 0.');
|
||||
Exit;
|
||||
end;
|
||||
if Length(Colors) = 0 then
|
||||
raise Exception.Create('There''s nothing to delete! The length of the array is 0.');
|
||||
|
||||
if Index > Length(Colors) - 1 then
|
||||
begin
|
||||
raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
|
||||
Exit;
|
||||
end;
|
||||
if Index > Length(Colors) - 1 then
|
||||
raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
|
||||
|
||||
for i := Index to Length(Colors) - 2 do
|
||||
Colors[i] := Colors[i+1];
|
||||
SetLength(Colors, Length(Colors) - 1);
|
||||
if refresh then
|
||||
UpdateColors;
|
||||
for i := Index to Length(Colors) - 2 do
|
||||
Colors[i] := Colors[i+1];
|
||||
SetLength(Colors, Length(Colors) - 1);
|
||||
if refresh then
|
||||
UpdateColors;
|
||||
end;
|
||||
|
||||
procedure TmbColorList.DeleteColorByName(Name: string; All: boolean);
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
for i := Length(Colors) - 1 downto 0 do
|
||||
if SameText(Colors[i].name, Name) then
|
||||
begin
|
||||
DeleteColor(i, false);
|
||||
if not All then
|
||||
begin
|
||||
UpdateColors;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
UpdateColors;
|
||||
for i := Length(Colors) - 1 downto 0 do
|
||||
if SameText(Colors[i].name, Name) then
|
||||
begin
|
||||
DeleteColor(i, false);
|
||||
if not All then
|
||||
begin
|
||||
UpdateColors;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
UpdateColors;
|
||||
end;
|
||||
|
||||
procedure TmbColorList.DeleteColorByValue(Value: TColor; All: boolean);
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
for i := Length(Colors) - 1 downto 0 do
|
||||
for i := Length(Colors) - 1 downto 0 do
|
||||
if Colors[i].Value = Value then
|
||||
begin
|
||||
begin
|
||||
DeleteColor(i, false);
|
||||
if not All then
|
||||
begin
|
||||
begin
|
||||
UpdateColors;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
UpdateColors;
|
||||
end;
|
||||
end;
|
||||
UpdateColors;
|
||||
end;
|
||||
|
||||
procedure TmbColorList.InsertColor(Index: integer; Name: string; Value: TColor);
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
if Index > Length(Colors) - 1 then
|
||||
begin
|
||||
raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
|
||||
Exit;
|
||||
end;
|
||||
if Index > Length(Colors) - 1 then
|
||||
raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
|
||||
|
||||
SetLength(Colors, Length(Colors) + 1);
|
||||
for i := Length(Colors) - 1 downto Index do
|
||||
Colors[i] := Colors[i-1];
|
||||
SetLength(Colors, Length(Colors) + 1);
|
||||
for i := Length(Colors) - 1 downto Index do
|
||||
Colors[i] := Colors[i-1];
|
||||
|
||||
Colors[Index].Name := Name;
|
||||
Colors[Index].Value := Value;
|
||||
Colors[Index].Name := Name;
|
||||
Colors[Index].Value := Value;
|
||||
|
||||
UpdateColors;
|
||||
UpdateColors;
|
||||
end;
|
||||
|
||||
procedure TmbColorList.MouseMove(Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
inherited;
|
||||
mx := x;
|
||||
my := y;
|
||||
inherited;
|
||||
mx := x;
|
||||
my := y;
|
||||
end;
|
||||
|
||||
procedure TmbColorList.CMHintShow(var Message: TCMHintShow);
|
||||
var
|
||||
Handled: boolean;
|
||||
i: integer;
|
||||
Handled: boolean;
|
||||
i: integer;
|
||||
begin
|
||||
if PtInRect(ClientRect, Point(mx, my)) and ShowHint then
|
||||
begin
|
||||
i := ItemAtPos(Point(mx, my), true);
|
||||
if i > -1 then
|
||||
with TCMHintShow(Message) do
|
||||
if not ShowHint then
|
||||
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
|
||||
HintStr := Colors[i].Name;
|
||||
end;
|
||||
end;
|
||||
inherited;
|
||||
if PtInRect(ClientRect, Point(mx, my)) and ShowHint then
|
||||
begin
|
||||
i := ItemAtPos(Point(mx, my), true);
|
||||
if i > -1 then
|
||||
with TCMHintShow(Message) do
|
||||
if not ShowHint then
|
||||
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
|
||||
HintStr := Colors[i].Name;
|
||||
end;
|
||||
end;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -177,45 +177,45 @@ implementation
|
||||
|
||||
constructor TmbColorPalette.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
inherited Create(AOwner);
|
||||
// ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];
|
||||
// DoubleBuffered := true;
|
||||
// PBack := TBitmap.Create;
|
||||
// PBack.PixelFormat := pf32bit;
|
||||
FTempBmp := TBitmap.Create;
|
||||
FTempBmp := TBitmap.Create;
|
||||
//FTempBmp.PixelFormat := pf32bit;
|
||||
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
|
||||
ParentBackground := true;
|
||||
{$ENDIF} {$ENDIF}
|
||||
TabStop := true;
|
||||
ParentShowHint := true;
|
||||
ShowHint := false;
|
||||
Width := 180;
|
||||
Height := 126;
|
||||
FMouseLoc := mlNone;
|
||||
FMouseOver := false;
|
||||
FMouseDown := false;
|
||||
FColCount := 0;
|
||||
FRowCount := 0;
|
||||
FIndex := -1;
|
||||
FCheckedIndex := -1;
|
||||
FTop := 0;
|
||||
FLeft := 0;
|
||||
FCellSize := 18;
|
||||
FState := ccsNone;
|
||||
FNames := TStringList.Create;
|
||||
FColors := TStringList.Create;
|
||||
(FColors as TStringList).OnChange := ColorsChange;
|
||||
FTotalCells := 0;
|
||||
FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: %hex';
|
||||
FAutoHeight := false;
|
||||
FMinColors := 0;
|
||||
FMaxColors := 0;
|
||||
FSort := smNone;
|
||||
FOrder := soAscending;
|
||||
FOld := clNone;
|
||||
FTStyle := tsNone;
|
||||
FCellStyle := csDefault;
|
||||
{$IFDEF DELPHI_7_UP} {$IFDEF DELPHI}
|
||||
ParentBackground := true;
|
||||
{$ENDIF} {$ENDIF}
|
||||
TabStop := true;
|
||||
ParentShowHint := true;
|
||||
ShowHint := false;
|
||||
Width := 180;
|
||||
Height := 126;
|
||||
FMouseLoc := mlNone;
|
||||
FMouseOver := false;
|
||||
FMouseDown := false;
|
||||
FColCount := 0;
|
||||
FRowCount := 0;
|
||||
FIndex := -1;
|
||||
FCheckedIndex := -1;
|
||||
FTop := 0;
|
||||
FLeft := 0;
|
||||
FCellSize := 18;
|
||||
FState := ccsNone;
|
||||
FNames := TStringList.Create;
|
||||
FColors := TStringList.Create;
|
||||
(FColors as TStringList).OnChange := ColorsChange;
|
||||
FTotalCells := 0;
|
||||
FHintFormat := 'RGB(%r, %g, %b)'#13'Hex: %hex';
|
||||
FAutoHeight := false;
|
||||
FMinColors := 0;
|
||||
FMaxColors := 0;
|
||||
FSort := smNone;
|
||||
FOrder := soAscending;
|
||||
FOld := clNone;
|
||||
FTStyle := tsNone;
|
||||
FCellStyle := csDefault;
|
||||
end;
|
||||
|
||||
destructor TmbColorPalette.Destroy;
|
||||
@ -254,9 +254,9 @@ end;
|
||||
|
||||
procedure TmbColorPalette.CreateWnd;
|
||||
begin
|
||||
inherited;
|
||||
CalcAutoHeight;
|
||||
Invalidate;
|
||||
inherited;
|
||||
CalcAutoHeight;
|
||||
Invalidate;
|
||||
end;
|
||||
(*
|
||||
procedure TmbColorPalette.PaintParentBack;
|
||||
@ -578,110 +578,109 @@ end;
|
||||
|
||||
procedure TmbColorPalette.PaintTransparentGlyph(ACanvas: TCanvas; R: TRect);
|
||||
begin
|
||||
InflateRect(R, -3, -3);
|
||||
if FCellStyle = csCorel then
|
||||
InflateRect(R, -3, -3);
|
||||
if FCellStyle = csCorel then
|
||||
begin
|
||||
if FState <> ccsNone then
|
||||
InflateRect(R, -2, -2)
|
||||
else
|
||||
if FColCount > 1 then
|
||||
Inc(R.Right);
|
||||
if FState <> ccsNone then
|
||||
InflateRect(R, -2, -2)
|
||||
else if FColCount > 1 then
|
||||
Inc(R.Right);
|
||||
end;
|
||||
with ACanvas do
|
||||
case FTStyle of
|
||||
tsPhotoshop:
|
||||
begin
|
||||
if Enabled then
|
||||
Pen.Color := clBtnShadow
|
||||
else
|
||||
Pen.Color := clGray;
|
||||
Brush.Color := clWhite;
|
||||
Rectangle(R);
|
||||
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 + 1, R.Top + (R.Bottom - R.Top) div 2, R.Left + (R.Right - R.Left) div 2, R.Bottom - 1));
|
||||
with ACanvas do
|
||||
case FTStyle of
|
||||
tsPhotoshop:
|
||||
begin
|
||||
if Enabled then
|
||||
Pen.Color := clBtnShadow
|
||||
else
|
||||
Pen.Color := clGray;
|
||||
Brush.Color := clWhite;
|
||||
Rectangle(R);
|
||||
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 + 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;
|
||||
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;
|
||||
|
||||
procedure TmbColorPalette.Resize;
|
||||
begin
|
||||
inherited;
|
||||
//CalcAutoHeight; // wp: will cause a ChangedBounds endless loop
|
||||
Invalidate;
|
||||
inherited;
|
||||
//CalcAutoHeight; // wp: will cause a ChangedBounds endless loop
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.CMMouseEnter(
|
||||
var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} );
|
||||
begin
|
||||
FMouseOver := true;
|
||||
FMouseLoc := mlOver;
|
||||
Invalidate;
|
||||
inherited;
|
||||
FMouseOver := true;
|
||||
FMouseLoc := mlOver;
|
||||
Invalidate;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.CMMouseLeave(
|
||||
var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} );
|
||||
begin
|
||||
FMouseOver := false;
|
||||
FMouseLoc := mlNone;
|
||||
FIndex := -1;
|
||||
Invalidate;
|
||||
inherited;
|
||||
FMouseOver := false;
|
||||
FMouseLoc := mlNone;
|
||||
FIndex := -1;
|
||||
Invalidate;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.MouseMove(Shift: TShiftState; X, Y: Integer);
|
||||
@ -700,25 +699,25 @@ end;
|
||||
|
||||
procedure TmbColorPalette.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
if Button = mbLeft then
|
||||
begin
|
||||
SetFocus;
|
||||
FMouseDown := true;
|
||||
FMouseLoc := mlDown;
|
||||
if (y div FCellSize)* FColCount + (x div FCellSize) <= FTotalCells then
|
||||
if FCheckedIndex <> (y div FCellSize)* FColCount + (x div FCellSize) then
|
||||
begin
|
||||
FOldIndex := FCheckedIndex;
|
||||
FCheckedIndex := (y div FCellSize)* FColCount + (x div FCellSize);
|
||||
end;
|
||||
Invalidate;
|
||||
end;
|
||||
inherited;
|
||||
if Button = mbLeft then
|
||||
begin
|
||||
SetFocus;
|
||||
FMouseDown := true;
|
||||
FMouseLoc := mlDown;
|
||||
if (y div FCellSize)* FColCount + (x div FCellSize) <= FTotalCells then
|
||||
if FCheckedIndex <> (y div FCellSize)* FColCount + (x div FCellSize) then
|
||||
begin
|
||||
FOldIndex := FCheckedIndex;
|
||||
FCheckedIndex := (y div FCellSize)* FColCount + (x div FCellSize);
|
||||
end;
|
||||
Invalidate;
|
||||
end;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.Click;
|
||||
begin
|
||||
inherited;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
||||
@ -815,171 +814,173 @@ end;
|
||||
|
||||
procedure TmbColorPalette.SetCellStyle(s: TCellStyle);
|
||||
begin
|
||||
if FCellStyle <> s then
|
||||
if FCellStyle <> s then
|
||||
begin
|
||||
FCellStyle := s;
|
||||
Invalidate;
|
||||
FCellStyle := s;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.SetSelColor(k: TColor);
|
||||
var
|
||||
s: string;
|
||||
i: integer;
|
||||
s: string;
|
||||
i: integer;
|
||||
begin
|
||||
s := mbColorToString(k);
|
||||
for i:= 0 to FColors.Count - 1 do
|
||||
if SameText(s, FColors.Strings[i]) then
|
||||
begin
|
||||
FCheckedIndex := i;
|
||||
Break;
|
||||
end
|
||||
else
|
||||
FCheckedIndex := -1;
|
||||
Invalidate;
|
||||
FOld := k;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
s := mbColorToString(k);
|
||||
for i:= 0 to FColors.Count - 1 do
|
||||
if SameText(s, FColors.Strings[i]) then
|
||||
begin
|
||||
FCheckedIndex := i;
|
||||
Break;
|
||||
end
|
||||
else
|
||||
FCheckedIndex := -1;
|
||||
Invalidate;
|
||||
FOld := k;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.SetStrings(s: TStrings);
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
FColors.Clear;
|
||||
FColors.AddStrings(s);
|
||||
if FColors.Count < FMinColors then
|
||||
for i := 0 to FMinColors - FColors.Count - 1 do
|
||||
FColors.Add('clNone');
|
||||
if (FColors.Count > FMaxColors) and (FMaxColors > 0) then
|
||||
for i := FColors.Count - 1 downto FMaxColors do
|
||||
FColors.Delete(i);
|
||||
CalcAutoHeight;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
FColors.Clear;
|
||||
FColors.AddStrings(s);
|
||||
if FColors.Count < FMinColors then
|
||||
for i := 0 to FMinColors - FColors.Count - 1 do
|
||||
FColors.Add('clNone');
|
||||
if (FColors.Count > FMaxColors) and (FMaxColors > 0) then
|
||||
for i := FColors.Count - 1 downto FMaxColors do
|
||||
FColors.Delete(i);
|
||||
CalcAutoHeight;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.SetNames(n: TStrings);
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
FNames.Clear;
|
||||
FNames.AddStrings(n);
|
||||
if (FNames.Count > FMaxColors) and (FMaxColors > 0) then
|
||||
for i := FNames.Count - 1 downto FMaxColors do
|
||||
FNames.Delete(i);
|
||||
FNames.Clear;
|
||||
FNames.AddStrings(n);
|
||||
if (FNames.Count > FMaxColors) and (FMaxColors > 0) then
|
||||
for i := FNames.Count - 1 downto FMaxColors do
|
||||
FNames.Delete(i);
|
||||
end;
|
||||
|
||||
function TmbColorPalette.GetMoveCellIndex(move: TMoveDirection): integer;
|
||||
var
|
||||
FBefore: integer;
|
||||
FBefore: integer;
|
||||
begin
|
||||
Result := -1;
|
||||
case move of
|
||||
mdLeft:
|
||||
if FCheckedIndex -1 < 0 then
|
||||
Result := FTotalCells
|
||||
else
|
||||
Result := FCheckedIndex - 1;
|
||||
mdRight:
|
||||
if FCheckedIndex + 1 > FTotalCells then
|
||||
Result := 0
|
||||
else
|
||||
Result := FCheckedIndex + 1;
|
||||
mdUp:
|
||||
if FCheckedIndex - FColCount < 0 then
|
||||
begin
|
||||
FBefore := (FTotalcells div FColCount) * FColCount;
|
||||
if FBefore + FCheckedIndex - 1 > FTotalCells then Dec(FBefore, FColCount);
|
||||
Result := FBefore + FCheckedIndex - 1;
|
||||
end
|
||||
else
|
||||
Result := FCheckedIndex - FColCount;
|
||||
mdDown:
|
||||
if FCheckedIndex + FColCount > FTotalCells then
|
||||
Result := FCheckedIndex mod FColCount + 1
|
||||
else
|
||||
Result := FCheckedIndex + FColCount;
|
||||
end;
|
||||
if Result > FColors.Count - 1 then
|
||||
Result := 0;
|
||||
Result := -1;
|
||||
case move of
|
||||
mdLeft:
|
||||
if FCheckedIndex -1 < 0 then
|
||||
Result := FTotalCells
|
||||
else
|
||||
Result := FCheckedIndex - 1;
|
||||
mdRight:
|
||||
if FCheckedIndex + 1 > FTotalCells then
|
||||
Result := 0
|
||||
else
|
||||
Result := FCheckedIndex + 1;
|
||||
mdUp:
|
||||
if FCheckedIndex - FColCount < 0 then
|
||||
begin
|
||||
FBefore := (FTotalcells div FColCount) * FColCount;
|
||||
if FBefore + FCheckedIndex - 1 > FTotalCells then Dec(FBefore, FColCount);
|
||||
Result := FBefore + FCheckedIndex - 1;
|
||||
end
|
||||
else
|
||||
Result := FCheckedIndex - FColCount;
|
||||
mdDown:
|
||||
if FCheckedIndex + FColCount > FTotalCells then
|
||||
Result := FCheckedIndex mod FColCount + 1
|
||||
else
|
||||
Result := FCheckedIndex + FColCount;
|
||||
end;
|
||||
if Result > FColors.Count - 1 then
|
||||
Result := 0;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.CNKeyDown(
|
||||
var Message: {$IFDEF DELPHI}TWMKeyDown{$ELSE}TLMKeyDown{$ENDIF} );
|
||||
var
|
||||
FInherited: boolean;
|
||||
Shift: TShiftState;
|
||||
FInherited: boolean;
|
||||
Shift: TShiftState;
|
||||
begin
|
||||
Shift := KeyDataToShiftState(Message.KeyData);
|
||||
Finherited := false;
|
||||
case Message.CharCode of
|
||||
VK_LEFT:
|
||||
begin
|
||||
FCheckedIndex := GetMoveCellIndex(mdLeft);
|
||||
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
|
||||
end;
|
||||
VK_RIGHT:
|
||||
begin
|
||||
FCheckedIndex := GetMoveCellIndex(mdRight);
|
||||
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
|
||||
end;
|
||||
VK_UP:
|
||||
begin
|
||||
FCheckedIndex := GetMoveCellIndex(mdUp);
|
||||
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
|
||||
end;
|
||||
VK_DOWN:
|
||||
begin
|
||||
FCheckedIndex := GetMoveCellIndex(mdDown);
|
||||
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
|
||||
end;
|
||||
VK_SPACE, VK_RETURN: if Assigned(FOnChange) then FOnChange(Self);
|
||||
else
|
||||
begin
|
||||
FInherited := true;
|
||||
inherited;
|
||||
Shift := KeyDataToShiftState(Message.KeyData);
|
||||
Finherited := false;
|
||||
case Message.CharCode of
|
||||
VK_LEFT:
|
||||
begin
|
||||
FCheckedIndex := GetMoveCellIndex(mdLeft);
|
||||
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
|
||||
end;
|
||||
VK_RIGHT:
|
||||
begin
|
||||
FCheckedIndex := GetMoveCellIndex(mdRight);
|
||||
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
|
||||
end;
|
||||
VK_UP:
|
||||
begin
|
||||
FCheckedIndex := GetMoveCellIndex(mdUp);
|
||||
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
|
||||
end;
|
||||
VK_DOWN:
|
||||
begin
|
||||
FCheckedIndex := GetMoveCellIndex(mdDown);
|
||||
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
|
||||
end;
|
||||
VK_SPACE, VK_RETURN:
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
else
|
||||
begin
|
||||
FInherited := true;
|
||||
inherited;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
if not FInherited then
|
||||
if not FInherited then
|
||||
begin
|
||||
Invalidate;
|
||||
if Assigned(OnKeyDown) then OnKeyDown(Self, Message.CharCode, Shift);
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
Invalidate;
|
||||
if Assigned(OnKeyDown) then OnKeyDown(Self, Message.CharCode, Shift);
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.CMHintShow(
|
||||
var Message: {$IFDEF DELPHI}TMessage{$ELSE}TLMessage{$ENDIF} );
|
||||
var
|
||||
clr: TColor;
|
||||
Handled: boolean;
|
||||
clr: TColor;
|
||||
Handled: boolean;
|
||||
begin
|
||||
if (Colors.Count > 0) and (FIndex > -1) then
|
||||
with TCMHintShow(Message) do
|
||||
if (Colors.Count > 0) and (FIndex > -1) then
|
||||
with TCMHintShow(Message) do
|
||||
begin
|
||||
if not ShowHint then
|
||||
Message.Result := 1
|
||||
else
|
||||
if not ShowHint then
|
||||
Message.Result := 1
|
||||
else
|
||||
begin
|
||||
with HintInfo^ do
|
||||
with HintInfo^ do
|
||||
begin
|
||||
// show that we want a hint
|
||||
Result := 0;
|
||||
ReshowTimeout := 1;
|
||||
HideTimeout := 5000;
|
||||
clr := GetColorUnderCursor;
|
||||
//fire event
|
||||
Handled := false;
|
||||
if Assigned(FOnGetHintText) then FOnGetHintText(clr, GetIndexUnderCursor, HintStr, Handled);
|
||||
if Handled then Exit;
|
||||
//do default
|
||||
if FIndex < FNames.Count then
|
||||
HintStr := FNames.Strings[FIndex]
|
||||
else
|
||||
if SameText(FColors.Strings[GetIndexUnderCursor], 'clCustom') or SameText(FColors.Strings[GetIndexUnderCursor], 'clTransparent') then
|
||||
HintStr := StringReplace(FColors.Strings[GetIndexUnderCursor], 'cl', '', [rfReplaceAll])
|
||||
// show that we want a hint
|
||||
Result := 0;
|
||||
ReshowTimeout := 1;
|
||||
HideTimeout := 5000;
|
||||
clr := GetColorUnderCursor;
|
||||
//fire event
|
||||
Handled := false;
|
||||
if Assigned(FOnGetHintText) then
|
||||
FOnGetHintText(clr, GetIndexUnderCursor, HintStr, Handled);
|
||||
if Handled then Exit;
|
||||
//do default
|
||||
if FIndex < FNames.Count then
|
||||
HintStr := FNames.Strings[FIndex]
|
||||
else
|
||||
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;
|
||||
@ -987,181 +988,179 @@ end;
|
||||
|
||||
procedure TmbColorPalette.SetAutoHeight(auto: boolean);
|
||||
begin
|
||||
FAutoHeight := auto;
|
||||
CalcAutoHeight;
|
||||
Invalidate;
|
||||
FAutoHeight := auto;
|
||||
CalcAutoHeight;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.SetMinColors(m: integer);
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
if (FMaxColors > 0) and (m > FMaxColors) then
|
||||
m := FMaxColors;
|
||||
FMinColors := m;
|
||||
if FColors.Count < m then
|
||||
for i := 0 to m - FColors.Count - 1 do
|
||||
FColors.Add('clNone');
|
||||
CalcAutoHeight;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
if (FMaxColors > 0) and (m > FMaxColors) then
|
||||
m := FMaxColors;
|
||||
FMinColors := m;
|
||||
if FColors.Count < m then
|
||||
for i := 0 to m - FColors.Count - 1 do
|
||||
FColors.Add('clNone');
|
||||
CalcAutoHeight;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.SetMaxColors(m: integer);
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
if m < 0 then m := 0;
|
||||
FMaxColors := m;
|
||||
if (m < FMinColors) and (m > 0) then
|
||||
SetMinColors(m);
|
||||
if (FColors.Count > FMaxColors) and (FMaxColors > 0) then
|
||||
for i := FColors.Count - 1 downto FMaxColors do
|
||||
FColors.Delete(i);
|
||||
CalcAutoHeight;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
if m < 0 then m := 0;
|
||||
FMaxColors := m;
|
||||
if (m < FMinColors) and (m > 0) then
|
||||
SetMinColors(m);
|
||||
if (FColors.Count > FMaxColors) and (FMaxColors > 0) then
|
||||
for i := FColors.Count - 1 downto FMaxColors do
|
||||
FColors.Delete(i);
|
||||
CalcAutoHeight;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.SetSortMode(s: TSortMode);
|
||||
begin
|
||||
if FSort <> s then
|
||||
if FSort <> s then
|
||||
begin
|
||||
FSort := s;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
FSort := s;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.SetSortOrder(s: TSortOrder);
|
||||
begin
|
||||
if FOrder <> s then
|
||||
if FOrder <> s then
|
||||
begin
|
||||
FOrder := s;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
FOrder := s;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.ColorsChange(Sender: TObject);
|
||||
begin
|
||||
if Assigned(FOnColorsChange) then FOnColorsChange(Self);
|
||||
FTotalCells := FColors.Count - 1;
|
||||
CalcAutoHeight;
|
||||
Invalidate;
|
||||
if Assigned(FOnColorsChange) then FOnColorsChange(Self);
|
||||
FTotalCells := FColors.Count - 1;
|
||||
CalcAutoHeight;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.SetCellSize(s: integer);
|
||||
begin
|
||||
FCellSize := s;
|
||||
CalcAutoHeight;
|
||||
Invalidate;
|
||||
FCellSize := s;
|
||||
CalcAutoHeight;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
function TmbColorPalette.GetSelectedCellRect: TRect;
|
||||
var
|
||||
row, fbottom, fleft: integer;
|
||||
row, fbottom, fleft: integer;
|
||||
begin
|
||||
if FCheckedIndex > -1 then
|
||||
if FCheckedIndex > -1 then
|
||||
begin
|
||||
if FCheckedIndex mod FColCount = 0 then
|
||||
if FCheckedIndex mod FColCount = 0 then
|
||||
begin
|
||||
row := FCheckedIndex div FColCount;
|
||||
fleft := Width - FCellSize;
|
||||
row := FCheckedIndex div FColCount;
|
||||
fleft := Width - FCellSize;
|
||||
end
|
||||
else
|
||||
else
|
||||
begin
|
||||
row := FCheckedIndex div FColCount + 1;
|
||||
fleft := (FCheckedIndex mod FColCount - 1) * FCellSize;
|
||||
row := FCheckedIndex div FColCount + 1;
|
||||
fleft := (FCheckedIndex mod FColCount - 1) * FCellSize;
|
||||
end;
|
||||
fbottom := row * FCellSize;
|
||||
Result := Rect(fleft, fbottom - FCellSize, fleft + FCellSize, fbottom);
|
||||
fbottom := row * FCellSize;
|
||||
Result := Rect(fleft, fbottom - FCellSize, fleft + FCellSize, fbottom);
|
||||
end
|
||||
else
|
||||
Result := Rect(0, 0, 0, 0);
|
||||
else
|
||||
Result := Rect(0, 0, 0, 0);
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.GeneratePalette(BaseColor: TColor);
|
||||
begin
|
||||
FColors.Text := MakePalette(BaseColor, FOrder);
|
||||
CalcAutoHeight;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
FColors.Text := MakePalette(BaseColor, FOrder);
|
||||
CalcAutoHeight;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.GenerateGradientPalette(Colors: array of TColor);
|
||||
begin
|
||||
FColors.Text := MakeGradientPalette(Colors);
|
||||
CalcAutoHeight;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
FColors.Text := MakeGradientPalette(Colors);
|
||||
CalcAutoHeight;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.LoadPalette(FileName: TFileName);
|
||||
var
|
||||
supported: boolean;
|
||||
a: AcoColors;
|
||||
i: integer;
|
||||
supported: boolean;
|
||||
a: AcoColors;
|
||||
i: integer;
|
||||
begin
|
||||
supported := false;
|
||||
if SameText(ExtractFileExt(FileName), '.pal') then
|
||||
supported := false;
|
||||
if SameText(ExtractFileExt(FileName), '.pal') then
|
||||
begin
|
||||
supported := true;
|
||||
FNames.Clear;
|
||||
FColors.Text := ReadJASCPal(FileName);
|
||||
supported := true;
|
||||
FNames.Clear;
|
||||
FColors.Text := ReadJASCPal(FileName);
|
||||
end
|
||||
else
|
||||
if SameText(ExtractFileExt(FileName), '.aco') then
|
||||
begin
|
||||
else if SameText(ExtractFileExt(FileName), '.aco') then
|
||||
begin
|
||||
supported := true;
|
||||
a := ReadPhotoshopAco(FileName);
|
||||
FColors.Clear;
|
||||
for i := 0 to Length(a.Colors) - 1 do
|
||||
FColors.Add(ColorToString(a.Colors[i]));
|
||||
FColors.Add(ColorToString(a.Colors[i]));
|
||||
FNames.Clear;
|
||||
if a.HasNames then
|
||||
for i := 0 to Length(a.Names) - 1 do
|
||||
FNames.Add(a.Names[i]);
|
||||
end
|
||||
else
|
||||
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
|
||||
for i := 0 to Length(a.Names) - 1 do
|
||||
FNames.Add(a.Names[i]);
|
||||
end
|
||||
else if SameText(ExtractFileExt(FileName), '.act') then
|
||||
begin
|
||||
CalcAutoHeight;
|
||||
SortColors;
|
||||
Invalidate;
|
||||
if Assigned(FOnChange) then FOnChange(Self);
|
||||
supported := true;
|
||||
FNames.Clear;
|
||||
FColors.Text := ReadPhotoshopAct(FileName);
|
||||
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;
|
||||
|
||||
procedure TmbColorPalette.SaveColorsAsPalette(FileName: TFileName);
|
||||
begin
|
||||
if SameText(ExtractFileExt(FileName), '.pal') then
|
||||
SaveJASCPal(FColors, FileName)
|
||||
else
|
||||
raise Exception.Create('The file extension specified does not identify a supported file format!'#13'Supported files formats are: .pal .aco .act');
|
||||
if SameText(ExtractFileExt(FileName), '.pal') then
|
||||
SaveJASCPal(FColors, FileName)
|
||||
else
|
||||
raise Exception.Create('The file extension specified does not identify a supported file format!'#13'Supported files formats are: .pal .aco .act');
|
||||
end;
|
||||
|
||||
procedure TmbColorPalette.SortColors;
|
||||
var
|
||||
old: TColor;
|
||||
old: TColor;
|
||||
begin
|
||||
if FSort <> smNone then
|
||||
if FSort <> smNone then
|
||||
begin
|
||||
if FColors.Count = 0 then Exit;
|
||||
old := GetSelColor;
|
||||
SortPalColors(FColors, FSort, FOrder);
|
||||
SetSelColor(old);
|
||||
Invalidate;
|
||||
if FColors.Count = 0 then Exit;
|
||||
old := GetSelColor;
|
||||
SortPalColors(FColors, FSort, FOrder);
|
||||
SetSelColor(old);
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
@ -17,60 +17,60 @@ uses
|
||||
type
|
||||
TmbColorPreview = class(TCustomControl)
|
||||
private
|
||||
FSelColor: TColor;
|
||||
FOpacity: integer;
|
||||
FOnColorChange: TNotifyEvent;
|
||||
FOnOpacityChange: TNotifyEvent;
|
||||
FBlockSize: integer;
|
||||
FSwatchStyle: boolean;
|
||||
FSelColor: TColor;
|
||||
FOpacity: integer;
|
||||
FOnColorChange: TNotifyEvent;
|
||||
FOnOpacityChange: TNotifyEvent;
|
||||
FBlockSize: integer;
|
||||
FSwatchStyle: boolean;
|
||||
|
||||
procedure SetSwatchStyle(Value: boolean);
|
||||
procedure SetSelColor(c: TColor);
|
||||
procedure SetOpacity(o: integer);
|
||||
procedure SetBlockSize(s: integer);
|
||||
function MakeBmp: TBitmap;
|
||||
procedure SetSwatchStyle(Value: boolean);
|
||||
procedure SetSelColor(c: TColor);
|
||||
procedure SetOpacity(o: integer);
|
||||
procedure SetBlockSize(s: integer);
|
||||
function MakeBmp: TBitmap;
|
||||
protected
|
||||
procedure Paint; override;
|
||||
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
|
||||
message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
|
||||
procedure Paint; override;
|
||||
procedure WMEraseBkgnd(var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
|
||||
message {$IFDEF FPC}LM_ERASEBKGND{$ELSE}WM_ERASEBKGND{$ENDIF};
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property Color: TColor read FSelColor write SetSelColor default clWhite;
|
||||
property Opacity: integer read FOpacity write SetOpacity default 100;
|
||||
property BlockSize: integer read FBlockSize write SetBlockSize default 6;
|
||||
property SwatchStyle: boolean read FSwatchStyle write SetSwatchStyle default false;
|
||||
property Anchors;
|
||||
property Align;
|
||||
property ShowHint;
|
||||
property ParentShowHint;
|
||||
property Visible;
|
||||
property Enabled;
|
||||
property PopupMenu;
|
||||
property DragCursor;
|
||||
property DragMode;
|
||||
property DragKind;
|
||||
property Constraints;
|
||||
|
||||
property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange;
|
||||
property OnOpacityChange: TNotifyEvent read FOnOpacityChange write FOnOpacityChange;
|
||||
property OnContextPopup;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnKeyDown;
|
||||
property OnKeyPress;
|
||||
property OnKeyUp;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDrag;
|
||||
property OnEnter;
|
||||
property OnExit;
|
||||
property OnResize;
|
||||
property OnStartDrag;
|
||||
property OnDblClick;
|
||||
property Color: TColor read FSelColor write SetSelColor default clWhite;
|
||||
property Opacity: integer read FOpacity write SetOpacity default 100;
|
||||
property BlockSize: integer read FBlockSize write SetBlockSize default 6;
|
||||
property SwatchStyle: boolean read FSwatchStyle write SetSwatchStyle default false;
|
||||
property Anchors;
|
||||
property Align;
|
||||
property ShowHint;
|
||||
property ParentShowHint;
|
||||
property Visible;
|
||||
property Enabled;
|
||||
property PopupMenu;
|
||||
property DragCursor;
|
||||
property DragMode;
|
||||
property DragKind;
|
||||
property Constraints;
|
||||
property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange;
|
||||
property OnOpacityChange: TNotifyEvent read FOnOpacityChange write FOnOpacityChange;
|
||||
property OnContextPopup;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnKeyDown;
|
||||
property OnKeyPress;
|
||||
property OnKeyUp;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDrag;
|
||||
property OnEnter;
|
||||
property OnExit;
|
||||
property OnResize;
|
||||
property OnStartDrag;
|
||||
property OnDblClick;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
@ -80,162 +80,161 @@ uses
|
||||
|
||||
constructor TmbColorPreview.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
DoubleBuffered := true;
|
||||
ControlStyle := COntrolStyle - [csAcceptsControls] + [csOpaque];
|
||||
FSelColor := clWhite;
|
||||
Width := 68;
|
||||
Height := 32;
|
||||
TabStop := false;
|
||||
FOpacity := 100;
|
||||
FBlockSize := 6;
|
||||
FSwatchStyle := false;
|
||||
inherited;
|
||||
DoubleBuffered := true;
|
||||
ControlStyle := COntrolStyle - [csAcceptsControls] + [csOpaque];
|
||||
FSelColor := clWhite;
|
||||
SetInitialBounds(0, 0, 68, 32);
|
||||
TabStop := false;
|
||||
FOpacity := 100;
|
||||
FBlockSize := 6;
|
||||
FSwatchStyle := false;
|
||||
end;
|
||||
|
||||
function TmbColorPreview.MakeBmp: TBitmap;
|
||||
begin
|
||||
Result := TBitmap.Create;
|
||||
Result.Width := FBlockSize;
|
||||
Result.Height := FBlockSize;
|
||||
if (FSelColor = clNone) or (FOpacity = 0) then
|
||||
Result.Canvas.Brush.Color := clSilver
|
||||
else
|
||||
Result.Canvas.Brush.Color := Blend(FSelColor, clSilver, FOpacity);
|
||||
Result.Canvas.FillRect(Result.Canvas.ClipRect);
|
||||
begin
|
||||
Result := TBitmap.Create;
|
||||
Result.Width := FBlockSize;
|
||||
Result.Height := FBlockSize;
|
||||
if (FSelColor = clNone) or (FOpacity = 0) then
|
||||
Result.Canvas.Brush.Color := clSilver
|
||||
else
|
||||
Result.Canvas.Brush.Color := Blend(FSelColor, clSilver, FOpacity);
|
||||
Result.Canvas.FillRect(Result.Canvas.ClipRect);
|
||||
end;
|
||||
|
||||
procedure TmbColorPreview.Paint;
|
||||
var
|
||||
TempBMP, cBMP: TBitmap;
|
||||
i, j: integer;
|
||||
R: TRect;
|
||||
rgn: HRgn;
|
||||
c: TColor;
|
||||
TempBMP, cBMP: TBitmap;
|
||||
i, j: integer;
|
||||
R: TRect;
|
||||
rgn: HRgn;
|
||||
c: TColor;
|
||||
begin
|
||||
TempBMP := TBitmap.Create;
|
||||
cBMP := nil;
|
||||
rgn := 0;
|
||||
try
|
||||
TempBMP.Width := Width + FBlockSize;
|
||||
TempBMP.Height := Height + FBlockSize;
|
||||
TempBMP.PixelFormat := pf24bit;
|
||||
TempBmp.Canvas.Pen.Color := clBtnShadow;
|
||||
TempBmp.Canvas.Brush.Color := FSelColor;
|
||||
R := ClientRect;
|
||||
with TempBmp.Canvas do
|
||||
if (FSelColor <> clNone) and (FOpacity = 100) then
|
||||
begin
|
||||
if not FSwatchStyle then
|
||||
Rectangle(R)
|
||||
else
|
||||
TempBMP := TBitmap.Create;
|
||||
cBMP := nil;
|
||||
rgn := 0;
|
||||
try
|
||||
TempBMP.Width := Width + FBlockSize;
|
||||
TempBMP.Height := Height + FBlockSize;
|
||||
TempBMP.PixelFormat := pf24bit;
|
||||
TempBmp.Canvas.Pen.Color := clBtnShadow;
|
||||
TempBmp.Canvas.Brush.Color := FSelColor;
|
||||
R := ClientRect;
|
||||
with TempBmp.Canvas do
|
||||
if (FSelColor <> clNone) and (FOpacity = 100) then
|
||||
begin
|
||||
Brush.Color := clWindow;
|
||||
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
|
||||
if not FSwatchStyle then
|
||||
Rectangle(R)
|
||||
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;
|
||||
begin
|
||||
Brush.Color := clWindow;
|
||||
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
|
||||
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;
|
||||
|
||||
procedure TmbColorPreview.WMEraseBkgnd(
|
||||
var Message: {$IFDEF FPC}TLMEraseBkgnd{$ELSE}TWMEraseBkgnd{$ENDIF});
|
||||
begin
|
||||
Message.Result := 1;
|
||||
Message.Result := 1;
|
||||
end;
|
||||
|
||||
procedure TmbColorPreview.SetSelColor(c: TColor);
|
||||
begin
|
||||
if c <> FSelColor then
|
||||
if c <> FSelColor then
|
||||
begin
|
||||
FSelColor := c;
|
||||
Invalidate;
|
||||
if Assigned(FOnColorChange) then FOnColorChange(Self);
|
||||
FSelColor := c;
|
||||
Invalidate;
|
||||
if Assigned(FOnColorChange) then FOnColorChange(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorPreview.SetOpacity(o: integer);
|
||||
begin
|
||||
if FOpacity <> o then
|
||||
if FOpacity <> o then
|
||||
begin
|
||||
FOpacity := o;
|
||||
Invalidate;
|
||||
if Assigned(FOnOpacityChange) then FOnOpacityChange(Self);
|
||||
FOpacity := o;
|
||||
Invalidate;
|
||||
if Assigned(FOnOpacityChange) then FOnOpacityChange(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorPreview.SetBlockSize(s: integer);
|
||||
begin
|
||||
if (FBlockSize <> s) and (s > 0) then
|
||||
if (FBlockSize <> s) and (s > 0) then
|
||||
begin
|
||||
FBlockSize := s;
|
||||
Invalidate;
|
||||
FBlockSize := s;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorPreview.SetSwatchStyle(Value: boolean);
|
||||
begin
|
||||
if FSwatchStyle <> Value then
|
||||
if FSwatchStyle <> Value then
|
||||
begin
|
||||
FSwatchStyle := Value;
|
||||
Invalidate;
|
||||
FSwatchStyle := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
@ -25,8 +25,8 @@ type
|
||||
{$ENDIF}
|
||||
|
||||
TmbColor = record
|
||||
name: string;
|
||||
value: TColor;
|
||||
Name: string;
|
||||
Value: TColor;
|
||||
end;
|
||||
|
||||
TDrawCaptionEvent = procedure (Sender: TObject; AIndex: integer; AFont: TFont; var AText: string; Selected: boolean) of object;
|
||||
@ -35,128 +35,124 @@ type
|
||||
|
||||
TmbColorTree = class(TCustomTreeView)
|
||||
private
|
||||
dummy: TCustomImageList;
|
||||
FInfo1, FInfo2: string;
|
||||
FInfoLabel: string;
|
||||
FDraw: TDrawCaptionEvent;
|
||||
FDraw1, FDraw2, FDraw3: TDrawLabelEvent;
|
||||
mx, my: integer;
|
||||
FGetHint: TGetHintEvent;
|
||||
FOnStartDrag: TStartDragEvent;
|
||||
FOnEndDrag: TEndDragEvent;
|
||||
procedure SetInfo1(Value: string);
|
||||
procedure SetInfo2(Value: string);
|
||||
procedure SetInfoLabel(Value: string);
|
||||
FInfo1, FInfo2: string;
|
||||
FInfoLabel: string;
|
||||
FDraw: TDrawCaptionEvent;
|
||||
FDraw1, FDraw2, FDraw3: TDrawLabelEvent;
|
||||
mx, my: integer;
|
||||
FGetHint: TGetHintEvent;
|
||||
FOnStartDrag: TStartDragEvent;
|
||||
FOnEndDrag: TEndDragEvent;
|
||||
procedure SetInfo1(Value: string);
|
||||
procedure SetInfo2(Value: string);
|
||||
procedure SetInfoLabel(Value: string);
|
||||
|
||||
protected
|
||||
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||||
function CustomDrawItem(Node: TTreeNode; State: TCustomDrawState;
|
||||
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||||
function CustomDrawItem(Node: TTreeNode; State: TCustomDrawState;
|
||||
Stage: TCustomDrawStage; var PaintImages: Boolean): Boolean; override;
|
||||
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 DrawInfoItem(R: TRect; Index: integer); dynamic;
|
||||
procedure DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean);
|
||||
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 DrawInfoItem(R: TRect; Index: integer); dynamic;
|
||||
procedure DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean);
|
||||
|
||||
public
|
||||
Colors: array of TmbColor;
|
||||
Colors: array of TmbColor;
|
||||
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure UpdateColors;
|
||||
procedure AddColor(Name: string; Value: TColor; refresh: boolean = true);
|
||||
procedure ClearColors;
|
||||
procedure DeleteColor(Index: integer; refresh: boolean = true);
|
||||
procedure DeleteColorByName(Name: string; All: boolean);
|
||||
procedure DeleteColorByValue(Value: TColor; All: boolean);
|
||||
procedure InsertColor(Index: integer; Name: string; Value: TColor);
|
||||
function ColorCount: integer;
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
procedure UpdateColors;
|
||||
procedure AddColor(AName: string; AValue: TColor; ARefresh: boolean = true);
|
||||
procedure ClearColors;
|
||||
procedure DeleteColor(AIndex: integer; ARefresh: boolean = true);
|
||||
procedure DeleteColorByName(AName: string; All: boolean);
|
||||
procedure DeleteColorByValue(AValue: TColor; All: boolean);
|
||||
procedure InsertColor(AIndex: integer; AName: string; AValue: TColor);
|
||||
function ColorCount: integer;
|
||||
published
|
||||
property InfoLabelText: string read FInfoLabel write SetInfoLabel;
|
||||
property InfoDisplay1: string read FInfo1 write SetInfo1;
|
||||
property InfoDisplay2: string read FInfo2 write SetInfo2;
|
||||
property Align;
|
||||
property Anchors;
|
||||
property AutoExpand;
|
||||
property InfoLabelText: string read FInfoLabel write SetInfoLabel;
|
||||
property InfoDisplay1: string read FInfo1 write SetInfo1;
|
||||
property InfoDisplay2: string read FInfo2 write SetInfo2;
|
||||
property Align;
|
||||
property Anchors;
|
||||
property AutoExpand;
|
||||
{$IFDEF DELPHI}
|
||||
property BevelEdges;
|
||||
property BevelInner;
|
||||
property BevelOuter;
|
||||
property BevelKind default bkNone;
|
||||
property BevelWidth;
|
||||
property BevelEdges;
|
||||
property BevelInner;
|
||||
property BevelOuter;
|
||||
property BevelKind default bkNone;
|
||||
property BevelWidth;
|
||||
{$ENDIF}
|
||||
property BorderStyle;
|
||||
property BorderWidth;
|
||||
property BorderStyle;
|
||||
property BorderWidth;
|
||||
{$IFDEF DELPHI}
|
||||
property ChangeDelay;
|
||||
property Ctl3D;
|
||||
property ParentCtl3D;
|
||||
property ChangeDelay;
|
||||
property Ctl3D;
|
||||
property ParentCtl3D;
|
||||
{$ENDIF}
|
||||
property Constraints;
|
||||
property Color;
|
||||
property DragKind;
|
||||
property DragCursor;
|
||||
property DragMode;
|
||||
property Enabled;
|
||||
property Font;
|
||||
property Indent;
|
||||
property Constraints;
|
||||
property Color;
|
||||
property DragKind;
|
||||
property DragCursor;
|
||||
property DragMode;
|
||||
property Enabled;
|
||||
property Font;
|
||||
property Indent;
|
||||
{$IFDEF DELPHI_7_UP}
|
||||
property MultiSelect;
|
||||
property MultiSelectStyle;
|
||||
property MultiSelect;
|
||||
property MultiSelectStyle;
|
||||
{$ENDIF}
|
||||
property ParentColor default False;
|
||||
property ParentFont;
|
||||
property ParentShowHint;
|
||||
property PopupMenu;
|
||||
property RightClickSelect;
|
||||
property ShowHint;
|
||||
property SortType;
|
||||
property TabOrder;
|
||||
property TabStop default True;
|
||||
property ToolTips;
|
||||
property Visible;
|
||||
|
||||
property OnGetHint: TGetHintEvent read FGetHint write FGetHint;
|
||||
property OnDrawCaption: TDrawCaptionEvent read FDraw write FDraw;
|
||||
property OnDrawInfoLabel: TDrawLabelEvent read FDraw1 write FDraw1;
|
||||
property OnDrawInfoDisplay1: TDrawLabelEvent read FDraw2 write FDraw2;
|
||||
property OnDrawInfoDisplay2: TDrawLabelEvent read FDraw3 write FDraw3;
|
||||
property ParentColor default False;
|
||||
property ParentFont;
|
||||
property ParentShowHint;
|
||||
property PopupMenu;
|
||||
property RightClickSelect;
|
||||
property ShowHint;
|
||||
property SortType;
|
||||
property TabOrder;
|
||||
property TabStop default True;
|
||||
property ToolTips;
|
||||
property Visible;
|
||||
property OnGetHint: TGetHintEvent read FGetHint write FGetHint;
|
||||
property OnDrawCaption: TDrawCaptionEvent read FDraw write FDraw;
|
||||
property OnDrawInfoLabel: TDrawLabelEvent read FDraw1 write FDraw1;
|
||||
property OnDrawInfoDisplay1: TDrawLabelEvent read FDraw2 write FDraw2;
|
||||
property OnDrawInfoDisplay2: TDrawLabelEvent read FDraw3 write FDraw3;
|
||||
{$IFDEF DELPHI_7_UP}
|
||||
property OnAddition;
|
||||
property OnCreateNodeClass;
|
||||
property OnAddition;
|
||||
property OnCreateNodeClass;
|
||||
{$ENDIF}
|
||||
property OnAdvancedCustomDraw;
|
||||
property OnAdvancedCustomDrawItem;
|
||||
property OnChange;
|
||||
property OnChanging;
|
||||
property OnClick;
|
||||
property OnCollapsed;
|
||||
property OnCollapsing;
|
||||
property OnCompare;
|
||||
property OnContextPopup;
|
||||
property OnCustomDraw;
|
||||
property OnCustomDrawItem;
|
||||
property OnDblClick;
|
||||
property OnDeletion;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDock;
|
||||
property OnEndDrag: TEndDragEvent read FOnEndDrag write FOnEndDrag;
|
||||
property OnEnter;
|
||||
property OnExit;
|
||||
property OnExpanding;
|
||||
property OnExpanded;
|
||||
property OnKeyDown;
|
||||
property OnKeyPress;
|
||||
property OnKeyUp;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnStartDock;
|
||||
property OnStartDrag: TStartDragEvent read FOnStartDrag write FOnStartDrag;
|
||||
property Items;
|
||||
property OnAdvancedCustomDraw;
|
||||
property OnAdvancedCustomDrawItem;
|
||||
property OnChange;
|
||||
property OnChanging;
|
||||
property OnClick;
|
||||
property OnCollapsed;
|
||||
property OnCollapsing;
|
||||
property OnCompare;
|
||||
property OnContextPopup;
|
||||
property OnCustomDraw;
|
||||
property OnCustomDrawItem;
|
||||
property OnDblClick;
|
||||
property OnDeletion;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDock;
|
||||
property OnEndDrag: TEndDragEvent read FOnEndDrag write FOnEndDrag;
|
||||
property OnEnter;
|
||||
property OnExit;
|
||||
property OnExpanding;
|
||||
property OnExpanded;
|
||||
property OnKeyDown;
|
||||
property OnKeyPress;
|
||||
property OnKeyUp;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnStartDock;
|
||||
property OnStartDrag: TStartDragEvent read FOnStartDrag write FOnStartDrag;
|
||||
property Items;
|
||||
end;
|
||||
|
||||
implementation
|
||||
@ -203,96 +199,86 @@ end;
|
||||
|
||||
constructor TmbColorTree.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
ControlStyle := ControlStyle + [csDisplayDragImage];
|
||||
MaxHue := 360;
|
||||
MaxSat := 255;
|
||||
MaxLum := 255;
|
||||
ReadOnly := true;
|
||||
ShowButtons := false;
|
||||
ShowLines := false;
|
||||
ShowRoot := true;
|
||||
RowSelect := true;
|
||||
HotTrack := false;
|
||||
SetLength(Colors, 0);
|
||||
Images := TImageList.Create(Self);
|
||||
Images.Width := 48;
|
||||
Images.Height := 48;
|
||||
{
|
||||
dummy := TCustomImageList.Create(Self);
|
||||
dummy.Width := 48;
|
||||
dummy.Height := 48;
|
||||
Images := dummy;
|
||||
}
|
||||
FInfoLabel := 'Color Values:';
|
||||
FInfo1 := 'RGB: %r.%g.%b';
|
||||
FInfo2 := 'HEX: #%hex';
|
||||
end;
|
||||
|
||||
destructor TmbColorTree.Destroy;
|
||||
begin
|
||||
dummy.Free;
|
||||
inherited;
|
||||
inherited;
|
||||
ControlStyle := ControlStyle + [csDisplayDragImage];
|
||||
{
|
||||
MaxHue := 360;
|
||||
MaxSat := 255;
|
||||
MaxLum := 255;
|
||||
}
|
||||
ReadOnly := true;
|
||||
ShowButtons := false;
|
||||
ShowLines := false;
|
||||
ShowRoot := true;
|
||||
RowSelect := true;
|
||||
HotTrack := false;
|
||||
SetLength(Colors, 0);
|
||||
Images := TImageList.Create(Self);
|
||||
Images.Width := 48;
|
||||
Images.Height := 48;
|
||||
FInfoLabel := 'Color Values:';
|
||||
FInfo1 := 'RGB: %r.%g.%b';
|
||||
FInfo2 := 'HEX: #%hex';
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.UpdateColors;
|
||||
var
|
||||
i: integer;
|
||||
n: TTreeNode;
|
||||
i: integer;
|
||||
n: TTreeNode;
|
||||
begin
|
||||
Items.Clear;
|
||||
for i := 0 to Length(Colors) - 1 do
|
||||
Items.Clear;
|
||||
for i := 0 to Length(Colors) - 1 do
|
||||
begin
|
||||
n := Items.Add(TopItem, Colors[i].name);
|
||||
Items.AddChild(n, '');
|
||||
n := Items.Add(TopItem, Colors[i].name);
|
||||
Items.AddChild(n, '');
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
||||
var
|
||||
r: TRect;
|
||||
r: TRect;
|
||||
begin
|
||||
inherited;
|
||||
if (ssShift in Shift) or (ssCtrl in Shift) then Exit;
|
||||
if Selected <> nil then
|
||||
r := Selected.DisplayRect(false)
|
||||
else
|
||||
Exit;
|
||||
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
|
||||
begin
|
||||
if selected.Expanded then
|
||||
Selected.Collapse(false)
|
||||
else
|
||||
Selected.Expand(false);
|
||||
Invalidate;
|
||||
end;
|
||||
inherited;
|
||||
if (ssShift in Shift) or (ssCtrl in Shift) then Exit;
|
||||
if Selected <> nil then
|
||||
r := Selected.DisplayRect(false)
|
||||
else
|
||||
exit;
|
||||
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
|
||||
begin
|
||||
if selected.Expanded then
|
||||
Selected.Collapse(false)
|
||||
else
|
||||
Selected.Expand(false);
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.MouseMove(Shift: TShiftState; X, Y: Integer);
|
||||
var
|
||||
r: TRect;
|
||||
r: TRect;
|
||||
begin
|
||||
inherited;
|
||||
mx := x;
|
||||
my := y;
|
||||
if GetNodeAt(x, y) <> nil then
|
||||
r := GetNodeAt(x, y).DisplayRect(false)
|
||||
else
|
||||
inherited;
|
||||
mx := x;
|
||||
my := y;
|
||||
if GetNodeAt(x, y) <> nil then
|
||||
r := GetNodeAt(x, y).DisplayRect(false)
|
||||
else
|
||||
begin
|
||||
Cursor := crDefault;
|
||||
Exit;
|
||||
Cursor := crDefault;
|
||||
exit;
|
||||
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
|
||||
if (GetNodeAt(x, y).HasChildren) and PtInRect(r, Point(x, y)) then
|
||||
Cursor := crHandPoint
|
||||
else
|
||||
Cursor := crDefault;
|
||||
if (GetNodeAt(x, y).HasChildren) and PtInRect(r, Point(x, y)) then
|
||||
Cursor := crHandPoint
|
||||
else
|
||||
Cursor := crDefault;
|
||||
end
|
||||
else
|
||||
Cursor := crDefault;
|
||||
else
|
||||
Cursor := crDefault;
|
||||
end;
|
||||
|
||||
function TmbColorTree.CustomDrawItem(Node: TTreeNode; State: TCustomDrawState;
|
||||
@ -306,38 +292,40 @@ begin
|
||||
DrawInfoItem(Node.DisplayRect(false), node.Parent.Index);
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean);
|
||||
procedure TmbColorTree.DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint;
|
||||
sel: boolean);
|
||||
var
|
||||
b: TBitmap;
|
||||
b: TBitmap;
|
||||
begin
|
||||
b := TBitmap.Create;
|
||||
try
|
||||
b.Height := 12;
|
||||
b.Width := 12;
|
||||
if Sel then
|
||||
begin
|
||||
b.Canvas.Brush.Color := clHighlight;
|
||||
b.Canvas.Pen.Color := clHighlightText;
|
||||
end
|
||||
else
|
||||
begin
|
||||
b.Canvas.Brush.Color := clFuchsia;
|
||||
b.Canvas.Pen.Color := clWindowText;
|
||||
b.Transparent := true;
|
||||
b.TransparentColor := clFuchsia;
|
||||
end;
|
||||
b.Canvas.FillRect(B.Canvas.ClipRect);
|
||||
case dir of
|
||||
sdDown: DrawArrow(b.Canvas, dir, Point(2, 3), 3);
|
||||
sdRight: DrawArrow(b.Canvas, dir, Point(1, 2), 3);
|
||||
b := TBitmap.Create;
|
||||
try
|
||||
b.Height := 12;
|
||||
b.Width := 12;
|
||||
if Sel then
|
||||
begin
|
||||
b.Canvas.Brush.Color := clHighlight;
|
||||
b.Canvas.Pen.Color := clHighlightText;
|
||||
end
|
||||
else
|
||||
begin
|
||||
b.Canvas.Brush.Color := clFuchsia;
|
||||
b.Canvas.Pen.Color := clWindowText;
|
||||
b.Transparent := true;
|
||||
b.TransparentColor := clFuchsia;
|
||||
end;
|
||||
b.Canvas.FillRect(B.Canvas.ClipRect);
|
||||
case dir of
|
||||
sdDown : DrawArrow(b.Canvas, dir, Point(2, 3), 3);
|
||||
sdRight : DrawArrow(b.Canvas, dir, Point(1, 2), 3);
|
||||
end;
|
||||
c.Draw(p.x, p.y, b);
|
||||
finally
|
||||
b.Free;
|
||||
end;
|
||||
c.Draw(p.x, p.y, b);
|
||||
finally
|
||||
b.Free;
|
||||
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
|
||||
SR, TR: TRect;
|
||||
begin
|
||||
@ -457,224 +445,217 @@ const
|
||||
FLAGS = DT_LEFT or DT_END_ELLIPSIS or DT_NOCLIP;
|
||||
DELTA = 2;
|
||||
var
|
||||
b: TBitmap;
|
||||
BR, TR: TRect;
|
||||
i, fx: integer;
|
||||
s: string;
|
||||
h: Integer;
|
||||
b: TBitmap;
|
||||
BR, TR: TRect;
|
||||
i, fx: integer;
|
||||
s: string;
|
||||
h: Integer;
|
||||
begin
|
||||
b := TBitmap.Create;
|
||||
try
|
||||
b.Width := R.Right - R.Left;
|
||||
b.Height := R.Bottom - R.Top;
|
||||
BR := b.Canvas.ClipRect;
|
||||
with b.Canvas do
|
||||
begin
|
||||
Canvas.Font.Assign(Self.Font);
|
||||
Brush.Color := Blend(clBtnFace, clWindow, 30);
|
||||
FillRect(BR);
|
||||
BR := Rect(BR.Left + 42, BR.Top, BR.Right, BR.Bottom);
|
||||
Brush.Color := clWindow;
|
||||
FillRect(BR);
|
||||
Inc(BR.Left, 6);
|
||||
Font.Style := [];
|
||||
Font.Size := 7;
|
||||
b := TBitmap.Create;
|
||||
try
|
||||
b.Width := R.Right - R.Left;
|
||||
b.Height := R.Bottom - R.Top;
|
||||
BR := b.Canvas.ClipRect;
|
||||
with b.Canvas do
|
||||
begin
|
||||
Canvas.Font.Assign(Self.Font);
|
||||
Brush.Color := Blend(clBtnFace, clWindow, 30);
|
||||
FillRect(BR);
|
||||
BR := Rect(BR.Left + 42, BR.Top, BR.Right, BR.Bottom);
|
||||
Brush.Color := clWindow;
|
||||
FillRect(BR);
|
||||
Inc(BR.Left, 6);
|
||||
Font.Style := [];
|
||||
Font.Size := 7;
|
||||
|
||||
s := FInfoLabel;
|
||||
h := TextHeight(s);
|
||||
TR := Rect(BR.Left, BR.Top{ + 2}, BR.Right, BR.Top + {2 + }h + DELTA);
|
||||
if Assigned(FDraw1) then FDraw1(Self, Index, Canvas.Font, s);
|
||||
DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, FLAGS);
|
||||
s := FInfoLabel;
|
||||
h := TextHeight(s);
|
||||
TR := Rect(BR.Left, BR.Top{ + 2}, BR.Right, BR.Top + {2 + }h + DELTA);
|
||||
if Assigned(FDraw1) then FDraw1(Self, Index, Canvas.Font, s);
|
||||
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);
|
||||
TR.Top := TR.Bottom + 2 * DELTA;
|
||||
TR.Bottom := TR.Top + h + DELTA;
|
||||
if Assigned(FDraw2) then FDraw2(Self, Index, Canvas.Font, s);
|
||||
DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, FLAGS);
|
||||
s := FormatHint(FInfo1, Self.Colors[Index].value);
|
||||
TR.Top := TR.Bottom + 2 * DELTA;
|
||||
TR.Bottom := TR.Top + h + DELTA;
|
||||
if Assigned(FDraw2) then FDraw2(Self, Index, Canvas.Font, s);
|
||||
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);
|
||||
TR.Top := TR.Bottom + 2 * DELTA;
|
||||
TR.Bottom := TR.Top + h + DELTA;
|
||||
if Assigned(FDraw3) then FDraw3(Self, Index, Canvas.Font, s);
|
||||
DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, FLAGS);
|
||||
end;
|
||||
s := FormatHint(FInfo2, Self.Colors[Index].value);
|
||||
TR.Top := TR.Bottom + 2 * DELTA;
|
||||
TR.Bottom := TR.Top + h + DELTA;
|
||||
if Assigned(FDraw3) then FDraw3(Self, Index, Canvas.Font, s);
|
||||
DrawText(b.Canvas.Handle, PChar(s), Length(s), TR, FLAGS);
|
||||
end;
|
||||
|
||||
Canvas.Draw(R.Left, R.Top, b);
|
||||
finally
|
||||
b.Free;
|
||||
end;
|
||||
Canvas.Draw(R.Left, R.Top, b);
|
||||
finally
|
||||
b.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TmbColorTree.IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean;
|
||||
begin
|
||||
Result := true;
|
||||
Result := true;
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.SetInfoLabel(Value: string);
|
||||
begin
|
||||
if FInfoLabel <> Value then
|
||||
if FInfoLabel <> Value then
|
||||
begin
|
||||
FInfoLabel := Value;
|
||||
Invalidate;
|
||||
FInfoLabel := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.SetInfo1(Value: string);
|
||||
begin
|
||||
if FInfo1 <> Value then
|
||||
if FInfo1 <> Value then
|
||||
begin
|
||||
FInfo1 := Value;
|
||||
Invalidate;
|
||||
FInfo1 := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.SetInfo2(Value: string);
|
||||
begin
|
||||
if FInfo2 <> Value then
|
||||
if FInfo2 <> Value then
|
||||
begin
|
||||
FInfo2 := Value;
|
||||
Invalidate;
|
||||
FInfo2 := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.AddColor(Name: string; Value: TColor; refresh: boolean = true);
|
||||
procedure TmbColorTree.AddColor(AName: string; AValue: TColor;
|
||||
ARefresh: boolean = true);
|
||||
var
|
||||
L: integer;
|
||||
L: integer;
|
||||
begin
|
||||
L := Length(Colors);
|
||||
SetLength(Colors, L + 1);
|
||||
Colors[L].name := Name;
|
||||
Colors[L].value := Value;
|
||||
if refresh then
|
||||
UpdateColors;
|
||||
L := Length(Colors);
|
||||
SetLength(Colors, L + 1);
|
||||
Colors[L].Name := AName;
|
||||
Colors[L].Value := AValue;
|
||||
if ARefresh then
|
||||
UpdateColors;
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.ClearColors;
|
||||
begin
|
||||
SetLength(Colors, 0);
|
||||
UpdateColors;
|
||||
SetLength(Colors, 0);
|
||||
UpdateColors;
|
||||
end;
|
||||
|
||||
function TmbColorTree.ColorCount: integer;
|
||||
begin
|
||||
Result := Length(Colors);
|
||||
Result := Length(Colors);
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.DeleteColor(Index: integer; refresh: boolean = true);
|
||||
procedure TmbColorTree.DeleteColor(AIndex: integer; ARefresh: boolean = true);
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
if Length(Colors) = 0 then
|
||||
begin
|
||||
if Length(Colors) = 0 then
|
||||
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
|
||||
raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
|
||||
Exit;
|
||||
DeleteColor(i, false);
|
||||
if not All then
|
||||
begin
|
||||
UpdateColors;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
for i := Index to Length(Colors) - 2 do
|
||||
Colors[i] := Colors[i+1];
|
||||
SetLength(Colors, Length(Colors) - 1);
|
||||
if refresh then
|
||||
UpdateColors;
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.DeleteColorByName(Name: string; All: boolean);
|
||||
procedure TmbColorTree.DeleteColorByValue(AValue: TColor; All: boolean);
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
for i := Length(Colors) - 1 downto 0 do
|
||||
if SameText(Colors[i].name, Name) then
|
||||
begin
|
||||
DeleteColor(i, false);
|
||||
if not All then
|
||||
begin
|
||||
UpdateColors;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
UpdateColors;
|
||||
for i := Length(Colors) - 1 downto 0 do
|
||||
if Colors[i].Value = AValue then
|
||||
begin
|
||||
DeleteColor(i, false);
|
||||
if not All then
|
||||
begin
|
||||
UpdateColors;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
UpdateColors;
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.DeleteColorByValue(Value: TColor; All: boolean);
|
||||
procedure TmbColorTree.InsertColor(AIndex: integer; AName: string; AValue: TColor);
|
||||
var
|
||||
i: integer;
|
||||
i: integer;
|
||||
begin
|
||||
for i := Length(Colors) - 1 downto 0 do
|
||||
if Colors[i].Value = Value then
|
||||
begin
|
||||
DeleteColor(i, false);
|
||||
if not All then
|
||||
begin
|
||||
UpdateColors;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
UpdateColors;
|
||||
end;
|
||||
if AIndex > Length(Colors) - 1 then
|
||||
raise Exception.Create(Format('List index out of bounds (%d)', [AIndex]));
|
||||
|
||||
procedure TmbColorTree.InsertColor(Index: integer; Name: string; Value: TColor);
|
||||
var
|
||||
i: integer;
|
||||
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);
|
||||
for i := Length(Colors) - 1 downto AIndex do
|
||||
Colors[i] := Colors[i-1];
|
||||
|
||||
SetLength(Colors, Length(Colors) + 1);
|
||||
for i := Length(Colors) - 1 downto Index do
|
||||
Colors[i] := Colors[i-1];
|
||||
Colors[AIndex].Name := AName;
|
||||
Colors[AIndex].Value := AValue;
|
||||
|
||||
Colors[Index].Name := Name;
|
||||
Colors[Index].Value := Value;
|
||||
|
||||
UpdateColors;
|
||||
UpdateColors;
|
||||
end;
|
||||
|
||||
procedure TmbColorTree.CMHintShow(var Message: TCMHintShow);
|
||||
var
|
||||
Handled: boolean;
|
||||
i: integer;
|
||||
n: TTreeNode;
|
||||
Handled: boolean;
|
||||
i: integer;
|
||||
n: TTreeNode;
|
||||
begin
|
||||
if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then
|
||||
begin
|
||||
n := GetNodeAt(mx, my);
|
||||
if n <> nil then
|
||||
begin
|
||||
if not n.HasChildren then
|
||||
i := n.Parent.Index
|
||||
else
|
||||
i := n.Index;
|
||||
with TCMHintShow(Message) do
|
||||
if not ShowHint then
|
||||
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)
|
||||
if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then
|
||||
begin
|
||||
n := GetNodeAt(mx, my);
|
||||
if n <> nil then
|
||||
begin
|
||||
if not n.HasChildren then
|
||||
i := n.Parent.Index
|
||||
else
|
||||
i := n.Index;
|
||||
with TCMHintShow(Message) do
|
||||
if not ShowHint then
|
||||
Message.Result := 1
|
||||
else
|
||||
HintStr := Colors[i].Name;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
inherited;
|
||||
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
|
||||
HintStr := Colors[i].Name;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -49,33 +49,33 @@ implementation
|
||||
|
||||
constructor TmbDeskPickerButton.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
DoubleBuffered := true;
|
||||
inherited;
|
||||
// DoubleBuffered := true;
|
||||
// ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}];
|
||||
FHintFmt := 'RGB(%r, %g, %b)'#13'Hex: %h';
|
||||
FShowScreenHint := false;
|
||||
FHintFmt := 'RGB(%r, %g, %b)'#13'Hex: %h';
|
||||
FShowScreenHint := false;
|
||||
end;
|
||||
|
||||
procedure TmbDeskPickerButton.Click;
|
||||
begin
|
||||
inherited;
|
||||
StartPicking;
|
||||
inherited;
|
||||
StartPicking;
|
||||
end;
|
||||
|
||||
procedure TmbDeskPickerButton.StartPicking;
|
||||
begin
|
||||
ScreenFrm := TScreenForm.Create(Application);
|
||||
try
|
||||
ScreenFrm.OnSelColorChange := ColorPicked;
|
||||
ScreenFrm.OnScreenKeyDown := ScreenKeyDown;
|
||||
ScreenFrm.OnMouseWheelDown := WheelDown;
|
||||
ScreenFrm.OnMouseWheelUp := WheelUp;
|
||||
ScreenFrm.ShowHint := FShowScreenHint;
|
||||
ScreenFrm.FHintFormat := FHintFmt;
|
||||
ScreenFrm.ShowModal;
|
||||
finally
|
||||
ScreenFrm.Free;
|
||||
end;
|
||||
ScreenFrm := TScreenForm.Create(Application);
|
||||
try
|
||||
ScreenFrm.OnSelColorChange := ColorPicked;
|
||||
ScreenFrm.OnScreenKeyDown := ScreenKeyDown;
|
||||
ScreenFrm.OnMouseWheelDown := WheelDown;
|
||||
ScreenFrm.OnMouseWheelUp := WheelUp;
|
||||
ScreenFrm.ShowHint := FShowScreenHint;
|
||||
ScreenFrm.FHintFormat := FHintFmt;
|
||||
ScreenFrm.ShowModal;
|
||||
finally
|
||||
ScreenFrm.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TmbDeskPickerButton.ColorPicked(Sender: TObject);
|
||||
@ -86,17 +86,17 @@ end;
|
||||
|
||||
procedure TmbDeskPickerButton.ScreenKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
|
||||
begin
|
||||
if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift);
|
||||
if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift);
|
||||
end;
|
||||
|
||||
procedure TmbDeskPickerButton.WheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
|
||||
begin
|
||||
if Assigned(OnWUp) then OnWUp(Self, Shift, MousePos, Handled);
|
||||
if Assigned(OnWUp) then OnWUp(Self, Shift, MousePos, Handled);
|
||||
end;
|
||||
|
||||
procedure TmbDeskPickerButton.WheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
|
||||
begin
|
||||
if Assigned(OnWDown) then OnWDown(Self, Shift, MousePos, Handled);
|
||||
if Assigned(OnWDown) then OnWDown(Self, Shift, MousePos, Handled);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -17,16 +17,16 @@ uses
|
||||
type
|
||||
TmbOfficeColorDialog = class(TComponent)
|
||||
private
|
||||
FWin: TOfficeMoreColorsWin;
|
||||
FSelColor: TColor;
|
||||
FUseHint: boolean;
|
||||
FWin: TOfficeMoreColorsWin;
|
||||
FSelColor: TColor;
|
||||
FUseHint: boolean;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
function Execute: boolean; overload;
|
||||
function Execute(AColor: TColor): boolean; overload;
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
function Execute: boolean; overload;
|
||||
function Execute(AColor: TColor): boolean; overload;
|
||||
published
|
||||
property SelectedColor: TColor read FSelColor write FSelColor default clWhite;
|
||||
property UseHints: boolean read FUseHint write FUseHint default false;
|
||||
property SelectedColor: TColor read FSelColor write FSelColor default clWhite;
|
||||
property UseHints: boolean read FUseHint write FUseHint default false;
|
||||
end;
|
||||
|
||||
implementation
|
||||
@ -35,41 +35,41 @@ implementation
|
||||
|
||||
constructor TmbOfficeColorDialog.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
FSelColor := clWhite;
|
||||
FUseHint := false;
|
||||
inherited;
|
||||
FSelColor := clWhite;
|
||||
FUseHint := false;
|
||||
end;
|
||||
|
||||
function TmbOfficeColorDialog.Execute: boolean;
|
||||
begin
|
||||
FWin := TOfficeMoreColorsWin.Create(Application);
|
||||
try
|
||||
FWin.OldSwatch.Color := FSelColor;
|
||||
FWin.ShowHint := FUseHint;
|
||||
Result := (FWin.ShowModal = IdOK);
|
||||
if Result then
|
||||
FSelColor := FWin.NewSwatch.Color
|
||||
else
|
||||
FSelColor := clNone;
|
||||
finally
|
||||
FWin.Free;
|
||||
end;
|
||||
FWin := TOfficeMoreColorsWin.Create(Application);
|
||||
try
|
||||
FWin.OldSwatch.Color := FSelColor;
|
||||
FWin.ShowHint := FUseHint;
|
||||
Result := (FWin.ShowModal = IdOK);
|
||||
if Result then
|
||||
FSelColor := FWin.NewSwatch.Color
|
||||
else
|
||||
FSelColor := clNone;
|
||||
finally
|
||||
FWin.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TmbOfficeColorDialog.Execute(AColor: TColor): boolean;
|
||||
begin
|
||||
FWin := TOfficeMoreColorsWin.Create(Application);
|
||||
try
|
||||
FWin.OldSwatch.Color := AColor;
|
||||
FWin.ShowHint := FUseHint;
|
||||
Result := (FWin.ShowModal = IdOK);
|
||||
if Result then
|
||||
FSelColor := FWin.NewSwatch.Color
|
||||
else
|
||||
FSelColor := clNone;
|
||||
finally
|
||||
FWin.Free;
|
||||
end;
|
||||
FWin := TOfficeMoreColorsWin.Create(Application);
|
||||
try
|
||||
FWin.OldSwatch.Color := AColor;
|
||||
FWin.ShowHint := FUseHint;
|
||||
Result := (FWin.ShowModal = IdOK);
|
||||
if Result then
|
||||
FSelColor := FWin.NewSwatch.Color
|
||||
else
|
||||
FSelColor := clNone;
|
||||
finally
|
||||
FWin.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -7,7 +7,8 @@ interface
|
||||
uses
|
||||
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);
|
||||
function PointInCircle(p: TPoint; Size: integer): boolean;
|
||||
function PtInCircle(p, ctr: TPoint; Radius: Integer): Boolean;
|
||||
@ -25,6 +26,12 @@ begin
|
||||
if AValue > AMax then AValue := AMax;
|
||||
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);
|
||||
begin
|
||||
while X1 <= X2 do begin
|
||||
|
||||
Reference in New Issue
Block a user