diff --git a/components/mbColorLib/HTMLColors.pas b/components/mbColorLib/HTMLColors.pas index a5a8bf5af..4726fb277 100644 --- a/components/mbColorLib/HTMLColors.pas +++ b/components/mbColorLib/HTMLColors.pas @@ -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. diff --git a/components/mbColorLib/HexaColorPicker.pas b/components/mbColorLib/HexaColorPicker.pas index f715294cb..ea356d42e 100644 --- a/components/mbColorLib/HexaColorPicker.pas +++ b/components/mbColorLib/HexaColorPicker.pas @@ -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 diff --git a/components/mbColorLib/PalUtils.pas b/components/mbColorLib/PalUtils.pas index e6c22bc1e..216396006 100644 --- a/components/mbColorLib/PalUtils.pas +++ b/components/mbColorLib/PalUtils.pas @@ -23,29 +23,41 @@ type //replaces passed strings with passed value function ReplaceFlags(s: string; flags: array of string; value: integer): string; + //replaces the appropriate tags with values in a hint format string function FormatHint(fmt: string; c: TColor): string; + //converts a string value to TColor including clCustom and clTransparent function mbStringToColor(s: string): TColor; + //converts a TColor to a string value including clCustom and clTransparent function mbColorToString(c: TColor): string; + //blends two colors together in proportion C1 : C2 = W1 : 100 - W1, where 0 <= W1 <= 100 function Blend(C1, C2: TColor; W1: Integer): TColor; + //generates a white-color-black or a black-color-white gradient palette function MakePalette(BaseColor: TColor; SortOrder: TSortOrder): string; + //generates a gradient palette from the given colors function MakeGradientPalette(Colors: array of TColor): string; + //sorts colors in a string list procedure SortPalColors(Colors: TStrings; SortMode: TSortMode; SortOrder: TSortOrder); + //reads JASC .pal file function ReadJASCPal(PalFile: TFileName): string; + //saves a string list to a JASC .pal file procedure SaveJASCPal(pal: TStrings; FileName: TFileName); + //reads Photoshop .aco file into an Aco record function ReadPhotoshopAco(PalFile: TFileName): AcoColors; + //reads Photoshop .act file function ReadPhotoshopAct(PalFile: TFileName): string; + implementation function ReplaceFlags(s: string; flags: array of string; value: integer): string; @@ -73,59 +85,59 @@ end; function FormatHint(fmt: string; c: TColor): string; var - h: string; + h: string; begin - h := AnsiReplaceText(fmt, '%hex', ColorToHex(c)); - h := AnsiReplaceText(h, '%cieL', IntToStr(Round(GetCIElValue(c)))); - h := AnsiReplaceText(h, '%cieA', IntToStr(Round(GetCIEaValue(c)))); - h := AnsiReplaceText(h, '%cieB', IntToStr(Round(GetCIEbValue(c)))); - h := AnsiReplaceText(h, '%cieX', IntToStr(Round(GetCIExValue(c)))); - h := AnsiReplaceText(h, '%cieY', IntToStr(Round(GetCIEyValue(c)))); - h := AnsiReplaceText(h, '%cieZ', IntToStr(Round(GetCIEzValue(c)))); - h := AnsiReplaceText(h, '%cieC', IntToStr(Round(GetCIEcValue(c)))); - h := AnsiReplaceText(h, '%cieH', IntToStr(Round(GetCIEhValue(c)))); - h := AnsiReplaceText(h, '%hslH', IntToStr(RGBHSLUtils.GetHValue(c))); - h := AnsiReplaceText(h, '%hslS', IntToStr(RGBHSLUtils.GetSValue(c))); - h := AnsiReplaceText(h, '%hslL', IntToStr(RGBHSLUtils.GetLValue(c))); - h := AnsiReplaceText(h, '%hsvH', IntToStr(RGBHSVUtils.GetHValue(c))); - h := AnsiReplaceText(h, '%hsvS', IntToStr(RGBHSVUtils.GetSValue(c))); - h := AnsiReplaceText(h, '%hsvV', IntToStr(RGBHSVUtils.GetVValue(c))); - h := AnsiReplaceText(h, '%r', IntToStr(GetRValue(c))); - h := AnsiReplaceText(h, '%g', IntToStr(GetGValue(c))); - h := AnsiReplaceText(h, '%b', IntToStr(GetBValue(c))); - h := AnsiReplaceText(h, '%c', IntToStr(GetCValue(c))); - h := AnsiReplaceText(h, '%m', IntToStr(GetMValue(c))); - h := AnsiReplaceText(h, '%y', IntToStr(GetYValue(c))); - h := AnsiReplaceText(h, '%k', IntToStr(GetKValue(c))); - h := AnsiReplaceText(h, '%h', IntToStr(RGBHSLUtils.GetHValue(c))); - h := AnsiReplaceText(h, '%s', IntToStr(RGBHSLUtils.GetSValue(c))); - h := AnsiReplaceText(h, '%l', IntToStr(RGBHSLUtils.GetLValue(c))); - h := AnsiReplaceText(h, '%v', IntToStr(RGBHSVUtils.GetVValue(c))); - Result := h; + h := AnsiReplaceText(fmt, '%hex', ColorToHex(c)); + h := AnsiReplaceText(h, '%cieL', IntToStr(Round(GetCIElValue(c)))); + h := AnsiReplaceText(h, '%cieA', IntToStr(Round(GetCIEaValue(c)))); + h := AnsiReplaceText(h, '%cieB', IntToStr(Round(GetCIEbValue(c)))); + h := AnsiReplaceText(h, '%cieX', IntToStr(Round(GetCIExValue(c)))); + h := AnsiReplaceText(h, '%cieY', IntToStr(Round(GetCIEyValue(c)))); + h := AnsiReplaceText(h, '%cieZ', IntToStr(Round(GetCIEzValue(c)))); + h := AnsiReplaceText(h, '%cieC', IntToStr(Round(GetCIEcValue(c)))); + h := AnsiReplaceText(h, '%cieH', IntToStr(Round(GetCIEhValue(c)))); + h := AnsiReplaceText(h, '%hslH', IntToStr(RGBHSLUtils.GetHValue(c))); + h := AnsiReplaceText(h, '%hslS', IntToStr(RGBHSLUtils.GetSValue(c))); + h := AnsiReplaceText(h, '%hslL', IntToStr(RGBHSLUtils.GetLValue(c))); + h := AnsiReplaceText(h, '%hsvH', IntToStr(RGBHSVUtils.GetHValue(c))); + h := AnsiReplaceText(h, '%hsvS', IntToStr(RGBHSVUtils.GetSValue(c))); + h := AnsiReplaceText(h, '%hsvV', IntToStr(RGBHSVUtils.GetVValue(c))); + h := AnsiReplaceText(h, '%r', IntToStr(GetRValue(c))); + h := AnsiReplaceText(h, '%g', IntToStr(GetGValue(c))); + h := AnsiReplaceText(h, '%b', IntToStr(GetBValue(c))); + h := AnsiReplaceText(h, '%c', IntToStr(GetCValue(c))); + h := AnsiReplaceText(h, '%m', IntToStr(GetMValue(c))); + h := AnsiReplaceText(h, '%y', IntToStr(GetYValue(c))); + h := AnsiReplaceText(h, '%k', IntToStr(GetKValue(c))); + h := AnsiReplaceText(h, '%h', IntToStr(RGBHSLUtils.GetHValue(c))); + h := AnsiReplaceText(h, '%s', IntToStr(RGBHSLUtils.GetSValue(c))); + h := AnsiReplaceText(h, '%l', IntToStr(RGBHSLUtils.GetLValue(c))); + h := AnsiReplaceText(h, '%v', IntToStr(RGBHSVUtils.GetVValue(c))); + Result := h; end; function mbStringToColor(s: string): TColor; begin - //remove spaces - s := AnsiReplaceText(s, ' ', ''); - if SameText(s, 'clCustom') then - Result := clCustom - else - if SameText(s, 'clTransparent') then - Result := clTransparent + //remove spaces + s := AnsiReplaceText(s, ' ', ''); + if SameText(s, 'clCustom') then + Result := clCustom else - Result := StringToColor(s); + if SameText(s, 'clTransparent') then + Result := clTransparent + else + Result := StringToColor(s); end; function mbColorToString(c: TColor): string; begin - if c = clCustom then - Result := 'clCustom' - else - if c = clTransparent then - Result := 'clTransparent' + if c = clCustom then + Result := 'clCustom' else - Result := ColorToString(c); + if c = clTransparent then + Result := 'clTransparent' + else + Result := ColorToString(c); end; //taken from TBXUtils, TBX Package © Alex Denisov (www.g32.org) @@ -160,34 +172,37 @@ end; function IsMember(sl: TStrings; s: string): boolean; var - i: integer; + i: integer; begin - Result := false; - for i := 0 to sl.count -1 do - if sl.Strings[i] = s then - Result := true; + for i := 0 to sl.count -1 do + if sl.Strings[i] = s then + begin + Result := true; + exit; + end; + Result := false; end; function MakePalette(BaseColor: TColor; SortOrder: TSortOrder): string; var - i: integer; - s: TStrings; + i: integer; + s: TStrings; begin - Result := ''; - s := TStringList.Create; - try - case SortOrder of - soAscending: - for i := 239 downto 0 do - s.Add(ColorToString(HSLRangeToRGB(GetHValue(BaseColor), GetSValue(BaseColor), 240 - i))); - soDescending: - for i := 0 to 239 do - s.Add(ColorToString(HSLRangeToRGB(GetHValue(BaseColor), GetSValue(BaseColor), 240 - i))); + Result := ''; + s := TStringList.Create; + try + case SortOrder of + soAscending: + for i := 239 downto 0 do + s.Add(ColorToString(HSLRangeToRGB(GetHValue(BaseColor), GetSValue(BaseColor), 240 - i))); + soDescending: + for i := 0 to 239 do + s.Add(ColorToString(HSLRangeToRGB(GetHValue(BaseColor), GetSValue(BaseColor), 240 - i))); + end; + Result := s.Text; + finally + s.Free; end; - Result := s.Text; - finally - s.Free; - end; end; function MakeGradientPalette(Colors: array of TColor): string; @@ -201,345 +216,344 @@ var a: RGBArray; b: array of RGBArray; begin - Result := ''; - Span := 300; - s := TStringList.Create; - try - SetLength(b, High(Colors) + 1); - for i := 0 to High(Colors) do - begin - Colors[i] := ColorToRGB(Colors[i]); - b[i, 0] := GetRValue(Colors[i]); - b[i, 1] := GetGValue(Colors[i]); - b[i, 2] := GetBValue(Colors[i]); - end; - for i := 0 to High(Colors) - 1 do - for j := 0 to Span do + Result := ''; + Span := 300; + s := TStringList.Create; + try + SetLength(b, High(Colors) + 1); + for i := 0 to High(Colors) do begin - Faktor := j / Span; - for k := 0 to 3 do - a[k] := Trunc(b[i, k] + ((b[i + 1, k] - b[i, k]) * Faktor)); - Scolor := ColorToString(RGB(a[0], a[1], a[2])); - if not IsMember(s, Scolor) then - s.add(Scolor); + Colors[i] := ColorToRGB(Colors[i]); + b[i, 0] := GetRValue(Colors[i]); + b[i, 1] := GetGValue(Colors[i]); + b[i, 2] := GetBValue(Colors[i]); end; - Result := s.Text; - finally - s.Free; - end; + for i := 0 to High(Colors) - 1 do + for j := 0 to Span do + begin + Faktor := j / Span; + for k := 0 to 3 do + a[k] := Trunc(b[i, k] + ((b[i + 1, k] - b[i, k]) * Faktor)); + Scolor := ColorToString(RGB(a[0], a[1], a[2])); + if not IsMember(s, Scolor) then + s.add(Scolor); + end; + Result := s.Text; + finally + s.Free; + end; end; procedure SortPalColors(Colors: TStrings; SortMode: TSortMode; SortOrder: TSortOrder); - function MaxPos(s: TStrings; sm: TSortMode): integer; - var - i: integer; - first: TColor; - begin - Result := 0; - first := clBlack; - for i := 0 to s.Count - 1 do - case sm of - smRed: - if GetRValue(first) < GetRValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; + function MaxPos(s: TStrings; sm: TSortMode): integer; + var + i: integer; + first: TColor; + begin + Result := 0; + first := clBlack; + for i := 0 to s.Count - 1 do + case sm of + smRed: + if GetRValue(first) < GetRValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smGreen: + if GetGValue(first) < GetGValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smBlue: + if GetBValue(first) < GetBValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smHue: + if GetHValue(first) < GetHValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smSaturation: + if GetSValue(first) < GetSValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smLuminance: + if GetLValue(first) < GetLValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smValue: + if GetVValue(first) < GetVValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCyan: + if GetCValue(first) < GetCValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smMagenta: + if GetMValue(first) < GetMValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smYellow: + if GetYValue(first) < GetYValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smBlacK: + if GetKValue(first) < GetKValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEx: + if GetCIEXValue(first) < GetCIEXValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEy: + if GetCIEYValue(first) < GetCIEYValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEz: + if GetCIEZValue(first) < GetCIEZValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEl: + if GetCIELValue(first) < GetCIELValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEa: + if GetCIEAValue(first) < GetCIEAValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEb: + if GetCIEBValue(first) < GetCIEBValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; end; - smGreen: - if GetGValue(first) < GetGValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smBlue: - if GetBValue(first) < GetBValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smHue: - if GetHValue(first) < GetHValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smSaturation: - if GetSValue(first) < GetSValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smLuminance: - if GetLValue(first) < GetLValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smValue: - if GetVValue(first) < GetVValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCyan: - if GetCValue(first) < GetCValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smMagenta: - if GetMValue(first) < GetMValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smYellow: - if GetYValue(first) < GetYValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smBlacK: - if GetKValue(first) < GetKValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCIEx: - if GetCIEXValue(first) < GetCIEXValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCIEy: - if GetCIEYValue(first) < GetCIEYValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCIEz: - if GetCIEZValue(first) < GetCIEZValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCIEl: - if GetCIELValue(first) < GetCIELValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCIEa: - if GetCIEAValue(first) < GetCIEAValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCIEb: - if GetCIEBValue(first) < GetCIEBValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - end; - end; + end; - function MinPos(s: TStrings; sm: TSortMode): integer; - var - i: integer; - first: TColor; - begin - Result := 0; - first := clWhite; - for i := 0 to s.Count - 1 do - case sm of - smRed: - if GetRValue(first) > GetRValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; + function MinPos(s: TStrings; sm: TSortMode): integer; + var + i: integer; + first: TColor; + begin + Result := 0; + first := clWhite; + for i := 0 to s.Count - 1 do + case sm of + smRed: + if GetRValue(first) > GetRValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smGreen: + if GetGValue(first) > GetGValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smBlue: + if GetBValue(first) > GetBValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smHue: + if GetHValue(first) > GetHValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smSaturation: + if GetSValue(first) > GetSValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smLuminance: + if GetLValue(first) > GetLValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smValue: + if GetVValue(first) > GetVValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCyan: + if GetCValue(first) > GetCValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smMagenta: + if GetMValue(first) > GetMValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smYellow: + if GetYValue(first) > GetYValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smBlacK: + if GetKValue(first) > GetKValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEx: + if GetCIEXValue(first) > GetCIEXValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEy: + if GetCIEYValue(first) > GetCIEYValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEz: + if GetCIEZValue(first) > GetCIEZValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEl: + if GetCIELValue(first) > GetCIELValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEa: + if GetCIEAValue(first) > GetCIEAValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; + smCIEb: + if GetCIEBValue(first) > GetCIEBValue(mbStringToColor(s.Strings[i])) then + begin + first := mbStringToColor(s.Strings[i]); + Result := i; + end; end; - smGreen: - if GetGValue(first) > GetGValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smBlue: - if GetBValue(first) > GetBValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smHue: - if GetHValue(first) > GetHValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smSaturation: - if GetSValue(first) > GetSValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smLuminance: - if GetLValue(first) > GetLValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smValue: - if GetVValue(first) > GetVValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCyan: - if GetCValue(first) > GetCValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smMagenta: - if GetMValue(first) > GetMValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smYellow: - if GetYValue(first) > GetYValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smBlacK: - if GetKValue(first) > GetKValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCIEx: - if GetCIEXValue(first) > GetCIEXValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCIEy: - if GetCIEYValue(first) > GetCIEYValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCIEz: - if GetCIEZValue(first) > GetCIEZValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCIEl: - if GetCIELValue(first) > GetCIELValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCIEa: - if GetCIEAValue(first) > GetCIEAValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - smCIEb: - if GetCIEBValue(first) > GetCIEBValue(mbStringToColor(s.Strings[i])) then - begin - first := mbStringToColor(s.Strings[i]); - Result := i; - end; - end; - end; + end; var - i, m: integer; - s: TStrings; + i, m: integer; + s: TStrings; begin - if SortMode <> smNone then + if SortMode <> smNone then begin - if Colors.Count = 0 then Exit; - m := 0; - s := TStringList.Create; - s.AddStrings(Colors); - Colors.Clear; - for i := s.Count - 1 downto 0 do - begin - case SortOrder of - soAscending: m := MinPos(s, SortMode); - soDescending: m := MaxPos(s, SortMode); - end; - Colors.Add(s.Strings[m]); - s.Delete(m); + if Colors.Count = 0 then Exit; + m := 0; + s := TStringList.Create; + try + s.AddStrings(Colors); + Colors.Clear; + for i := s.Count - 1 downto 0 do + begin + case SortOrder of + soAscending : m := MinPos(s, SortMode); + soDescending : m := MaxPos(s, SortMode); + end; + Colors.Add(s.Strings[m]); + s.Delete(m); + end; + finally + s.Free; end; - s.Free; end; end; function ReadJASCPal(PalFile: TFileName): string; var - p, t, c: TStrings; - i: integer; + p, t, c: TStrings; + i: integer; begin - if not FileExists(PalFile) then - begin - raise Exception.Create('File not found'); - Exit; + if not FileExists(PalFile) then + raise Exception.Create('File not found'); + + p := TStringList.Create; + t := TStringList.Create; + c := TStringList.Create; + try + p.LoadFromFile(PalFile); + for i := 0 to p.Count - 1 do + if p.strings[i] <> '' then + begin + t.Clear; + ExtractStrings([' '], [], PChar(p.strings[i]), t); + if t.Count = 3 then + c.Add(ColorToString(RGB(StrToInt(t.strings[0]), StrToInt(t.strings[1]), StrToInt(t.strings[2])))); + end; + Result := c.Text; + finally + c.Free; + t.Free; + p.Free; end; - p := TStringList.Create; - t := TStringList.Create; - c := TStringList.Create; - try - p.LoadFromFile(PalFile); - for i := 0 to p.Count - 1 do - if p.strings[i] <> '' then - begin - t.Clear; - ExtractStrings([' '], [], PChar(p.strings[i]), t); - if t.Count = 3 then - c.Add(ColorToString(RGB(StrToInt(t.strings[0]), StrToInt(t.strings[1]), StrToInt(t.strings[2])))); - end; - Result := c.Text; - finally - c.Free; - t.Free; - p.Free; - end; end; procedure SaveJASCPal(pal: TStrings; FileName: TFileName); var - i: integer; - p: TStringList; - c: TColor; + i: integer; + p: TStringList; + c: TColor; begin - if not FileExists(FileName) then - begin - raise Exception.Create('File not found'); - Exit; + if not FileExists(FileName) then + raise Exception.Create('File not found'); + + p := TStringList.Create; + try + p.Add('JASC-PAL'); + p.Add('0100'); + p.Add('256'); + for i := 0 to pal.Count - 1 do + if (pal.Strings[i] <> '') and not SameText(pal.Strings[i], 'clCustom') and not SameText(pal.Strings[i], 'clTransparent') then + begin + c := StringToColor(pal.Strings[i]); + p.Add(IntToStr(GetRValue(c)) + ' ' + IntToStr(GetGValue(c)) + ' ' + IntToStr(GetBValue(c))); + end; + p.SaveToFile(FileName); + finally + p.Free; end; - p := TStringList.Create; - try - p.Add('JASC-PAL'); - p.Add('0100'); - p.Add('256'); - for i := 0 to pal.Count - 1 do - if (pal.Strings[i] <> '') and not SameText(pal.Strings[i], 'clCustom') and not SameText(pal.Strings[i], 'clTransparent') then - begin - c := StringToColor(pal.Strings[i]); - p.Add(IntToStr(GetRValue(c)) + ' ' + IntToStr(GetGValue(c)) + ' ' + IntToStr(GetBValue(c))); - end; - p.SaveToFile(FileName); - finally - p.Free; - end; end; procedure ExchangeBytes(var w: Word); @@ -555,152 +569,147 @@ end; procedure ExchangeChars(var s: WideString); var - i: Integer; - w: Word; + i: Integer; + w: Word; begin - for i := 1 to Length(s) do + for i := 1 to Length(s) do begin - w := Word(s[i]); - ExchangeBytes(w); - s[i] := WideChar(w); + w := Word(s[i]); + ExchangeBytes(w); + s[i] := WideChar(w); end; end; function GetAcoColor(space,w,x,y,z: word): TColor; begin - case space of - 0: //RGB - Result := RGB(w div 256, x div 256, y div 256); - 1: //HSB - HSV - Result := HSVToColor(Round(w/182.04), Round(x/655.35), Round(y/655.35)); - 2: //CMYK - Result := CMYKToTColor(Round(100-w/55.35), Round(100-x/655.35), Round(100-y/655.35), Round(100-z/655.35)); - 7: //Lab - Result := LabToRGB(w/100, x/100, y/100); - 8: //Grayscale - Result := RGB(Round(w/39.0625), Round(w/39.0625), Round(w/39.0625)); - 9: //Wide CMYK - Result := CMYKToTColor(w div 100, x div 100, y div 100, z div 100) - else //unknown - Result := RGB(w div 256, x div 256, y div 256); - end; + case space of + 0: //RGB + Result := RGB(w div 256, x div 256, y div 256); + 1: //HSB - HSV + Result := HSVToColor(Round(w/182.04), Round(x/655.35), Round(y/655.35)); + 2: //CMYK + Result := CMYKToTColor(Round(100-w/55.35), Round(100-x/655.35), Round(100-y/655.35), Round(100-z/655.35)); + 7: //Lab + Result := LabToRGB(w/100, x/100, y/100); + 8: //Grayscale + Result := RGB(Round(w/39.0625), Round(w/39.0625), Round(w/39.0625)); + 9: //Wide CMYK + Result := CMYKToTColor(w div 100, x div 100, y div 100, z div 100) + else //unknown + Result := RGB(w div 256, x div 256, y div 256); + end; end; function ReadPhotoshopAco(PalFile: TFileName): AcoColors; var - f: file; - ver, num, space, w, x, y, z, dummy: Word; - i: integer; - v0Length: byte; - v0Name: string; - v2Length: Word; - v2Name: WideString; + f: file; + ver, num, space, w, x, y, z, dummy: Word; + i: integer; + v0Length: byte; + v0Name: string; + v2Length: Word; + v2Name: WideString; begin - if not FileExists(PalFile) then + if not FileExists(PalFile) then begin - raise Exception.Create('File not found'); - SetLength(Result.Colors, 0); - SetLength(Result.Names, 0); - Result.HasNames := false; - Exit; + SetLength(Result.Colors, 0); + SetLength(Result.Names, 0); + Result.HasNames := false; + raise Exception.Create('File not found'); end; - AssignFile(f, PalFile); - Reset(f, 1); - //read version - BlockRead(f, ver, sizeof(ver)); - ExchangeBytes(ver); - if not (ver in [0, 1, 2]) then + + AssignFile(f, PalFile); + Reset(f, 1); + //read version + BlockRead(f, ver, sizeof(ver)); + ExchangeBytes(ver); + if not (ver in [0, 1, 2]) then begin - CloseFile(f); - Exception.Create('The file you are trying to load is not (yet) supported.'#13'Please submit the file for testing to MXS so loading of this version will be supported too'); - Exit; + CloseFile(f); + raise Exception.Create('The file you are trying to load is not (yet) supported.'#13'Please submit the file for testing to MXS so loading of this version will be supported too'); end; - //read number of colors - BlockRead(f, num, sizeof(num)); - ExchangeBytes(num); - //read names - if (ver = 0) or (ver = 2) then + + //read number of colors + BlockRead(f, num, sizeof(num)); + ExchangeBytes(num); + //read names + if (ver = 0) or (ver = 2) then begin - SetLength(Result.Names, num); - Result.HasNames := true; + SetLength(Result.Names, num); + Result.HasNames := true; end - else + else begin - SetLength(Result.Names, 0); - Result.HasNames := false; + SetLength(Result.Names, 0); + Result.HasNames := false; end; - //read colors - SetLength(Result.Colors, num); - for i := 0 to num - 1 do + //read colors + SetLength(Result.Colors, num); + for i := 0 to num - 1 do begin - BlockRead(f, space, sizeof(space)); - ExchangeBytes(space); - BlockRead(f, w, sizeof(w)); - ExchangeBytes(w); - BlockRead(f, x, sizeof(x)); - ExchangeBytes(x); - BlockRead(f, y, sizeof(y)); - ExchangeBytes(y); - BlockRead(f, z, sizeof(z)); - ExchangeBytes(z); - Result.Colors[i] := GetAcoColor(space, w, x, y, z); - case ver of - 0: - begin - BlockRead(f, v0Length, SizeOf(v0Length)); - SetLength(v0Name, v0Length); - if v0Length > 0 then - BlockRead(f, PChar(v0Name)^, v0Length); - Result.Names[i] := v0Name; - end; - 2: - begin - BlockRead(f, dummy, sizeof(dummy)); - BlockRead(f, v2Length, SizeOf(v2Length)); - ExchangeBytes(v2Length); - SetLength(v2Name, v2Length - 1); - if v2Length > 0 then - begin - BlockRead(f, PWideChar(v2Name)^, 2*(v2Length - 1)); - ExchangeChars(v2Name); - end; - Result.Names[i] := v2Name; - BlockRead(f, dummy, sizeof(dummy)); - end; - end; + BlockRead(f, space, sizeof(space)); + ExchangeBytes(space); + BlockRead(f, w, sizeof(w)); + ExchangeBytes(w); + BlockRead(f, x, sizeof(x)); + ExchangeBytes(x); + BlockRead(f, y, sizeof(y)); + ExchangeBytes(y); + BlockRead(f, z, sizeof(z)); + ExchangeBytes(z); + Result.Colors[i] := GetAcoColor(space, w, x, y, z); + case ver of + 0: begin + BlockRead(f, v0Length, SizeOf(v0Length)); + SetLength(v0Name, v0Length); + if v0Length > 0 then + BlockRead(f, PChar(v0Name)^, v0Length); + Result.Names[i] := v0Name; + end; + 2: begin + BlockRead(f, dummy, sizeof(dummy)); + BlockRead(f, v2Length, SizeOf(v2Length)); + ExchangeBytes(v2Length); + SetLength(v2Name, v2Length - 1); + if v2Length > 0 then + begin + BlockRead(f, PWideChar(v2Name)^, 2*(v2Length - 1)); + ExchangeChars(v2Name); + end; + Result.Names[i] := v2Name; + BlockRead(f, dummy, sizeof(dummy)); + end; + end; end; - CloseFile(f); + CloseFile(f); end; function ReadPhotoshopAct(PalFile: TFileName): string; var - f: file; - r, g, b: byte; - s: TStringList; - i: integer; + f: file; + r, g, b: byte; + s: TStringList; + i: integer; begin - if not FileExists(PalFile) then - begin - raise Exception.Create('File not found'); - Result := ''; - Exit; + if not FileExists(PalFile) then + raise Exception.Create('File not found'); + + s := TStringList.Create; + try + AssignFile(f, PalFile); + Reset(f, 1); + for i := 0 to 255 do + begin + BlockRead(f, r, sizeof(r)); + BlockRead(f, g, sizeof(g)); + BlockRead(f, b, sizeof(b)); + s.Add(ColorToString(RGB(r, g, b))); + end; + Result := s.Text; + finally + s.Free; end; - s := TStringList.Create; - try - AssignFile(f, PalFile); - Reset(f, 1); - for i := 0 to 255 do - begin - BlockRead(f, r, sizeof(r)); - BlockRead(f, g, sizeof(g)); - BlockRead(f, b, sizeof(b)); - s.Add(ColorToString(RGB(r, g, b))); - end; - Result := s.Text; - finally - s.Free; - end; - CloseFile(f); + CloseFile(f); end; end. diff --git a/components/mbColorLib/RColorPicker.pas b/components/mbColorLib/RColorPicker.pas index 0eecfa830..4b3174cbf 100644 --- a/components/mbColorLib/RColorPicker.pas +++ b/components/mbColorLib/RColorPicker.pas @@ -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 diff --git a/components/mbColorLib/RGBCIEUtils.pas b/components/mbColorLib/RGBCIEUtils.pas index 9b395c8e6..fc3a18b34 100644 --- a/components/mbColorLib/RGBCIEUtils.pas +++ b/components/mbColorLib/RGBCIEUtils.pas @@ -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. diff --git a/components/mbColorLib/RGBCMYKUtils.pas b/components/mbColorLib/RGBCMYKUtils.pas index a08407593..4a7a457c7 100644 --- a/components/mbColorLib/RGBCMYKUtils.pas +++ b/components/mbColorLib/RGBCMYKUtils.pas @@ -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. diff --git a/components/mbColorLib/RGBHSLUtils.pas b/components/mbColorLib/RGBHSLUtils.pas index 98010bfa8..dd8c291df 100644 --- a/components/mbColorLib/RGBHSLUtils.pas +++ b/components/mbColorLib/RGBHSLUtils.pas @@ -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; diff --git a/components/mbColorLib/RGBHSVUtils.pas b/components/mbColorLib/RGBHSVUtils.pas index c9bd95f75..38fad1c5c 100644 --- a/components/mbColorLib/RGBHSVUtils.pas +++ b/components/mbColorLib/RGBHSVUtils.pas @@ -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. diff --git a/components/mbColorLib/SColorPicker.pas b/components/mbColorLib/SColorPicker.pas index 14d487d82..d5007b308 100644 --- a/components/mbColorLib/SColorPicker.pas +++ b/components/mbColorLib/SColorPicker.pas @@ -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 diff --git a/components/mbColorLib/ScreenWin.pas b/components/mbColorLib/ScreenWin.pas index 9a67761e6..5a6ab4dd0 100644 --- a/components/mbColorLib/ScreenWin.pas +++ b/components/mbColorLib/ScreenWin.pas @@ -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, diff --git a/components/mbColorLib/SelPropUtils.pas b/components/mbColorLib/SelPropUtils.pas index 8e2d00da7..7639a2a1e 100644 --- a/components/mbColorLib/SelPropUtils.pas +++ b/components/mbColorLib/SelPropUtils.pas @@ -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. diff --git a/components/mbColorLib/YColorPicker.pas b/components/mbColorLib/YColorPicker.pas index 13255498b..0278f2936 100644 --- a/components/mbColorLib/YColorPicker.pas +++ b/components/mbColorLib/YColorPicker.pas @@ -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 diff --git a/components/mbColorLib/mbColorList.pas b/components/mbColorLib/mbColorList.pas index 53b79e4e2..6ae5aa055 100644 --- a/components/mbColorLib/mbColorList.pas +++ b/components/mbColorLib/mbColorList.pas @@ -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. diff --git a/components/mbColorLib/mbColorPalette.pas b/components/mbColorLib/mbColorPalette.pas index d5010dded..7b9e652db 100644 --- a/components/mbColorLib/mbColorPalette.pas +++ b/components/mbColorLib/mbColorPalette.pas @@ -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; diff --git a/components/mbColorLib/mbColorPreview.pas b/components/mbColorLib/mbColorPreview.pas index 8241405a8..081511e3e 100644 --- a/components/mbColorLib/mbColorPreview.pas +++ b/components/mbColorLib/mbColorPreview.pas @@ -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; diff --git a/components/mbColorLib/mbColorTree.pas b/components/mbColorLib/mbColorTree.pas index a66819cd1..04f028eef 100644 --- a/components/mbColorLib/mbColorTree.pas +++ b/components/mbColorLib/mbColorTree.pas @@ -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. diff --git a/components/mbColorLib/mbDeskPickerButton.pas b/components/mbColorLib/mbDeskPickerButton.pas index 35cae17e2..77c99d992 100644 --- a/components/mbColorLib/mbDeskPickerButton.pas +++ b/components/mbColorLib/mbDeskPickerButton.pas @@ -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. diff --git a/components/mbColorLib/mbOfficeColorDialog.pas b/components/mbColorLib/mbOfficeColorDialog.pas index 9329c321f..9de4e6674 100644 --- a/components/mbColorLib/mbOfficeColorDialog.pas +++ b/components/mbColorLib/mbOfficeColorDialog.pas @@ -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. diff --git a/components/mbColorLib/mbutils.pas b/components/mbColorLib/mbutils.pas index 7aab5f44f..1da1abbb0 100644 --- a/components/mbColorLib/mbutils.pas +++ b/components/mbColorLib/mbutils.pas @@ -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