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

mbColorLib: Apply standard code formatting

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

6
components/mbColorLib/HTMLColors.pas
View File

@ -245,8 +245,7 @@ begin
end; end;
Result := BASIC_VALUES[k]; Result := BASIC_VALUES[k];
end end
else else if IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s) then
if IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s) then
begin begin
for i := 0 to SYSTEM_COUNT - 1 do for i := 0 to SYSTEM_COUNT - 1 do
if SameText(s, SYSTEM_NAMES[i]) then if SameText(s, SYSTEM_NAMES[i]) then
@ -286,8 +285,7 @@ begin
else else
Result := clNone; Result := clNone;
end end
else else if IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) then
if IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) then
begin begin
s := GetHexFromName(s); s := GetHexFromName(s);
Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2))); Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2)));

2
components/mbColorLib/HexaColorPicker.pas
View File

@ -122,7 +122,6 @@ type
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; destructor Destroy; override;
procedure SelectCombIndex(i: integer); procedure SelectCombIndex(i: integer);
function GetSelectedCombIndex: integer; function GetSelectedCombIndex: integer;
function GetColorUnderCursor: TColor; function GetColorUnderCursor: TColor;
@ -157,7 +156,6 @@ type
property DragMode; property DragMode;
property DragKind; property DragKind;
property Constraints; property Constraints;
property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnIntensityChange: TNotifyEvent read FOnIntensityChange write FOnIntensityChange; property OnIntensityChange: TNotifyEvent read FOnIntensityChange write FOnIntensityChange;
property OnDblClick; property OnDblClick;

47
components/mbColorLib/PalUtils.pas
View File

@ -23,29 +23,41 @@ type
//replaces passed strings with passed value //replaces passed strings with passed value
function ReplaceFlags(s: string; flags: array of string; value: integer): string; function ReplaceFlags(s: string; flags: array of string; value: integer): string;
//replaces the appropriate tags with values in a hint format string //replaces the appropriate tags with values in a hint format string
function FormatHint(fmt: string; c: TColor): string; function FormatHint(fmt: string; c: TColor): string;
//converts a string value to TColor including clCustom and clTransparent //converts a string value to TColor including clCustom and clTransparent
function mbStringToColor(s: string): TColor; function mbStringToColor(s: string): TColor;
//converts a TColor to a string value including clCustom and clTransparent //converts a TColor to a string value including clCustom and clTransparent
function mbColorToString(c: TColor): string; function mbColorToString(c: TColor): string;
//blends two colors together in proportion C1 : C2 = W1 : 100 - W1, where 0 <= W1 <= 100 //blends two colors together in proportion C1 : C2 = W1 : 100 - W1, where 0 <= W1 <= 100
function Blend(C1, C2: TColor; W1: Integer): TColor; function Blend(C1, C2: TColor; W1: Integer): TColor;
//generates a white-color-black or a black-color-white gradient palette //generates a white-color-black or a black-color-white gradient palette
function MakePalette(BaseColor: TColor; SortOrder: TSortOrder): string; function MakePalette(BaseColor: TColor; SortOrder: TSortOrder): string;
//generates a gradient palette from the given colors //generates a gradient palette from the given colors
function MakeGradientPalette(Colors: array of TColor): string; function MakeGradientPalette(Colors: array of TColor): string;
//sorts colors in a string list //sorts colors in a string list
procedure SortPalColors(Colors: TStrings; SortMode: TSortMode; SortOrder: TSortOrder); procedure SortPalColors(Colors: TStrings; SortMode: TSortMode; SortOrder: TSortOrder);
//reads JASC .pal file //reads JASC .pal file
function ReadJASCPal(PalFile: TFileName): string; function ReadJASCPal(PalFile: TFileName): string;
//saves a string list to a JASC .pal file //saves a string list to a JASC .pal file
procedure SaveJASCPal(pal: TStrings; FileName: TFileName); procedure SaveJASCPal(pal: TStrings; FileName: TFileName);
//reads Photoshop .aco file into an Aco record //reads Photoshop .aco file into an Aco record
function ReadPhotoshopAco(PalFile: TFileName): AcoColors; function ReadPhotoshopAco(PalFile: TFileName): AcoColors;
//reads Photoshop .act file //reads Photoshop .act file
function ReadPhotoshopAct(PalFile: TFileName): string; function ReadPhotoshopAct(PalFile: TFileName): string;
implementation implementation
function ReplaceFlags(s: string; flags: array of string; value: integer): string; function ReplaceFlags(s: string; flags: array of string; value: integer): string;
@ -162,10 +174,13 @@ function IsMember(sl: TStrings; s: string): boolean;
var var
i: integer; i: integer;
begin begin
Result := false;
for i := 0 to sl.count -1 do for i := 0 to sl.count -1 do
if sl.Strings[i] = s then if sl.Strings[i] = s then
begin
Result := true; Result := true;
exit;
end;
Result := false;
end; end;
function MakePalette(BaseColor: TColor; SortOrder: TSortOrder): string; function MakePalette(BaseColor: TColor; SortOrder: TSortOrder): string;
@ -468,6 +483,7 @@ begin
if Colors.Count = 0 then Exit; if Colors.Count = 0 then Exit;
m := 0; m := 0;
s := TStringList.Create; s := TStringList.Create;
try
s.AddStrings(Colors); s.AddStrings(Colors);
Colors.Clear; Colors.Clear;
for i := s.Count - 1 downto 0 do for i := s.Count - 1 downto 0 do
@ -479,9 +495,11 @@ begin
Colors.Add(s.Strings[m]); Colors.Add(s.Strings[m]);
s.Delete(m); s.Delete(m);
end; end;
finally
s.Free; s.Free;
end; end;
end; end;
end;
function ReadJASCPal(PalFile: TFileName): string; function ReadJASCPal(PalFile: TFileName): string;
var var
@ -489,10 +507,8 @@ var
i: integer; i: integer;
begin begin
if not FileExists(PalFile) then if not FileExists(PalFile) then
begin
raise Exception.Create('File not found'); raise Exception.Create('File not found');
Exit;
end;
p := TStringList.Create; p := TStringList.Create;
t := TStringList.Create; t := TStringList.Create;
c := TStringList.Create; c := TStringList.Create;
@ -521,10 +537,8 @@ var
c: TColor; c: TColor;
begin begin
if not FileExists(FileName) then if not FileExists(FileName) then
begin
raise Exception.Create('File not found'); raise Exception.Create('File not found');
Exit;
end;
p := TStringList.Create; p := TStringList.Create;
try try
p.Add('JASC-PAL'); p.Add('JASC-PAL');
@ -598,12 +612,12 @@ var
begin begin
if not FileExists(PalFile) then if not FileExists(PalFile) then
begin begin
raise Exception.Create('File not found');
SetLength(Result.Colors, 0); SetLength(Result.Colors, 0);
SetLength(Result.Names, 0); SetLength(Result.Names, 0);
Result.HasNames := false; Result.HasNames := false;
Exit; raise Exception.Create('File not found');
end; end;
AssignFile(f, PalFile); AssignFile(f, PalFile);
Reset(f, 1); Reset(f, 1);
//read version //read version
@ -612,9 +626,9 @@ begin
if not (ver in [0, 1, 2]) then if not (ver in [0, 1, 2]) then
begin begin
CloseFile(f); 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'); 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');
Exit;
end; end;
//read number of colors //read number of colors
BlockRead(f, num, sizeof(num)); BlockRead(f, num, sizeof(num));
ExchangeBytes(num); ExchangeBytes(num);
@ -645,16 +659,14 @@ begin
ExchangeBytes(z); ExchangeBytes(z);
Result.Colors[i] := GetAcoColor(space, w, x, y, z); Result.Colors[i] := GetAcoColor(space, w, x, y, z);
case ver of case ver of
0: 0: begin
begin
BlockRead(f, v0Length, SizeOf(v0Length)); BlockRead(f, v0Length, SizeOf(v0Length));
SetLength(v0Name, v0Length); SetLength(v0Name, v0Length);
if v0Length > 0 then if v0Length > 0 then
BlockRead(f, PChar(v0Name)^, v0Length); BlockRead(f, PChar(v0Name)^, v0Length);
Result.Names[i] := v0Name; Result.Names[i] := v0Name;
end; end;
2: 2: begin
begin
BlockRead(f, dummy, sizeof(dummy)); BlockRead(f, dummy, sizeof(dummy));
BlockRead(f, v2Length, SizeOf(v2Length)); BlockRead(f, v2Length, SizeOf(v2Length));
ExchangeBytes(v2Length); ExchangeBytes(v2Length);
@ -680,11 +692,8 @@ var
i: integer; i: integer;
begin begin
if not FileExists(PalFile) then if not FileExists(PalFile) then
begin
raise Exception.Create('File not found'); raise Exception.Create('File not found');
Result := '';
Exit;
end;
s := TStringList.Create; s := TStringList.Create;
try try
AssignFile(f, PalFile); AssignFile(f, PalFile);

115
components/mbColorLib/RGBCIEUtils.pas
View File

@ -73,35 +73,38 @@ const
type type
xyz = record xyz = record
x: real; x: Double;
y: real; y: Double;
z: real; z: Double;
end; end;
function LabToXYZ(l, a, b: real): xyz; function LabToXYZ(l, a, b: double): xyz;
function XYZToRGB(space: xyz): TColor; function XYZToRGB(space: xyz): TColor;
function LabToRGB(l, a, b: real): TColor; function LabToRGB(l, a, b: double): TColor;
function RGBToXYZ(c: TColor): xyz; function RGBToXYZ(c: TColor): xyz;
procedure RGBToLab(clr: TColor; var l, a, b: real); procedure RGBToLab(clr: TColor; var l, a, b: double);
procedure XYZToLab(space: xyz; var l, a, b: real); procedure XYZToLab(space: xyz; var l, a, b: double);
procedure LCHToLab(lum, c, h: real; var l, a, b: real); procedure LCHToLab(lum, c, h: double; var l, a, b: double);
procedure LabToLCH(l, a, b: real; var lum, c, h: real); procedure LabToLCH(l, a, b: double; var lum, c, h: double);
function LCHToRGB(l, c, h: real): TColor; function LCHToRGB(l, c, h: double): TColor;
procedure RGBToLCH(clr: TColor; var l, c, h: real); procedure RGBToLCH(clr: TColor; var l, c, h: double);
function GetCIEXValue(c: TColor): real; function GetCIEXValue(c: TColor): double;
function GetCIEYValue(c: TColor): real; function GetCIEYValue(c: TColor): double;
function GetCIEZValue(c: TColor): real; function GetCIEZValue(c: TColor): double;
function GetCIELValue(c: TColor): real; function GetCIELValue(c: TColor): double;
function GetCIEAValue(c: TColor): real; function GetCIEAValue(c: TColor): double;
function GetCIEBValue(c: TColor): real; function GetCIEBValue(c: TColor): double;
function GetCIECValue(c: TColor): real; function GetCIECValue(c: TColor): double;
function GetCIEHValue(c: TColor): real; function GetCIEHValue(c: TColor): double;
implementation implementation
function LabToXYZ(l, a, b: real): xyz; uses
mbUtils;
function LabToXYZ(l, a, b: double): xyz;
var var
x, y, z: real; x, y, z: double;
begin begin
y := (l + 16)/116; y := (l + 16)/116;
x := a/500 + y; x := a/500 + y;
@ -125,7 +128,7 @@ end;
function XYZToRGB(space: xyz): TColor; function XYZToRGB(space: xyz): TColor;
var var
r, g, b, x, y, z: real; r, g, b, x, y, z: double;
begin begin
x := space.x/100; x := space.x/100;
y := space.y/100; y := space.y/100;
@ -146,23 +149,20 @@ begin
else else
b := 12.92 * b; b := 12.92 * b;
if r < 0 then r := 0; Clamp(r, 0, 1);
if r > 1 then r := 1; Clamp(g, 0, 1);
if g < 0 then g := 0; Clamp(b, 0, 1);
if g > 1 then g := 1;
if b < 0 then b := 0;
if b > 1 then b := 1;
Result := RGB(Round(r*255), Round(g*255), Round(b*255)); Result := RGB(Round(r*255), Round(g*255), Round(b*255));
end; end;
function LabToRGB(l, a, b: real): TColor; function LabToRGB(l, a, b: double): TColor;
begin begin
Result := XYZToRGB(LabToXYZ(l, a, b)); Result := XYZToRGB(LabToXYZ(l, a, b));
end; end;
function RGBToXYZ(c: TColor): xyz; function RGBToXYZ(c: TColor): xyz;
var var
r, g, b: real; r, g, b: double;
begin begin
r := GetRValue(c)/255; r := GetRValue(c)/255;
g := GetGValue(c)/255; g := GetGValue(c)/255;
@ -188,9 +188,9 @@ begin
Result.z := r * 0.0193 + g * 0.1192 + b * 0.9505; Result.z := r * 0.0193 + g * 0.1192 + b * 0.9505;
end; end;
procedure XYZToLab(space: xyz; var l, a, b: real); procedure XYZToLab(space: xyz; var l, a, b: Double);
var var
x, y, z: real; x, y, z: double;
begin begin
x := space.x/ref_X; x := space.x/ref_X;
y := space.y/100; y := space.y/100;
@ -210,15 +210,12 @@ begin
l := (116*y) - 16; l := (116*y) - 16;
a := 500 * (x - y); a := 500 * (x - y);
b := 200 * (y - z); b := 200 * (y - z);
if l > 100 then l := 100; Clamp(l, 0, 100);
if l < 0 then l := 0; Clamp(a, -128, 127);
if a < -128 then a := -128; Clamp(b, -128, 127);
if a > 127 then a := 127;
if b < -128 then b := -128;
if b > 127 then b := 127;
end; end;
procedure RGBToLab(clr: TColor; var l, a, b: real); procedure RGBToLab(clr: TColor; var l, a, b: Double);
var var
s: xyz; s: xyz;
begin begin
@ -226,41 +223,41 @@ begin
XYZToLab(s, l, a, b); XYZToLab(s, l, a, b);
end; end;
procedure LCHToLab(lum, c, h: real; var l, a, b: real); procedure LCHToLab(lum, c, h: double; var l, a, b: double);
begin begin
l := lum; l := lum;
a := cos(DegToRad(h)) * c; a := cos(DegToRad(h)) * c;
b := sin(DegToRad(h)) * c; b := sin(DegToRad(h)) * c;
end; end;
procedure LabToLCH(l, a, b: real; var lum, c, h: real); procedure LabToLCH(l, a, b: double; var lum, c, h: double);
begin begin
h := ArcTan2(b, a); h := ArcTan2(b, a);
if h > 0 then if h > 0 then
h := (h/PI) * 180 h := (h/pi) * 180
else else
h := 360 - (ABS(h)/PI) * 180; h := 360 - (abs(h)/pi) * 180;
lum := l; lum := l;
c := SQRT(a*a + b*b); c := SQRT(a*a + b*b);
end; end;
procedure RGBToLCH(clr: TColor; var l, c, h: real); procedure RGBToLCH(clr: TColor; var l, c, h: double);
var var
a, b: real; a, b: double;
begin begin
RGBToLab(clr, l, a, b); RGBToLab(clr, l, a, b);
LabToLCH(l, a, b, l, c, h); LabToLCH(l, a, b, l, c, h);
end; end;
function LCHToRGB(l, c, h: real): TColor; function LCHToRGB(l, c, h: double): TColor;
var var
lum, a, b: real; lum, a, b: double;
begin begin
LCHToLab(l, c, h, lum, a, b); LCHToLab(l, c, h, lum, a, b);
Result := LabToRGB(lum, a, b); Result := LabToRGB(lum, a, b);
end; end;
function GetCIEXValue(c: TColor): real; function GetCIEXValue(c: TColor): double;
var var
d: xyz; d: xyz;
begin begin
@ -268,7 +265,7 @@ begin
Result := d.x; Result := d.x;
end; end;
function GetCIEYValue(c: TColor): real; function GetCIEYValue(c: TColor): double;
var var
d: xyz; d: xyz;
begin begin
@ -276,7 +273,7 @@ begin
Result := d.y; Result := d.y;
end; end;
function GetCIEZValue(c: TColor): real; function GetCIEZValue(c: TColor): double;
var var
d: xyz; d: xyz;
begin begin
@ -284,37 +281,37 @@ begin
Result := d.z; Result := d.z;
end; end;
function GetCIELValue(c: TColor): real; function GetCIELValue(c: TColor): double;
var var
d: real; d: real;
begin begin
XYZToLab(RGBToXYZ(c), Result, d, d); XYZToLab(RGBToXYZ(c), Result, d, d);
end; end;
function GetCIEAValue(c: TColor): real; function GetCIEAValue(c: TColor): double;
var var
d: real; d: double;
begin begin
XYZToLab(RGBToXYZ(c), d, Result, d); XYZToLab(RGBToXYZ(c), d, Result, d);
end; end;
function GetCIEBValue(c: TColor): real; function GetCIEBValue(c: TColor): double;
var var
d: real; d: double;
begin begin
XYZToLab(RGBToXYZ(c), d, d, Result); XYZToLab(RGBToXYZ(c), d, d, Result);
end; end;
function GetCIECValue(c: TColor): real; function GetCIECValue(c: TColor): double;
var var
d: real; d: double;
begin begin
RGBToLCH(c, d, Result, d); RGBToLCH(c, d, Result, d);
end; end;
function GetCIEHValue(c: TColor): real; function GetCIEHValue(c: TColor): double;
var var
d: real; d: double;
begin begin
RGBToLCH(c, d, d, Result); RGBToLCH(c, d, d, Result);
end; end;

32
components/mbColorLib/RGBHSLUtils.pas
View File

@ -45,16 +45,13 @@ var
begin begin
if Hue < 0 then if Hue < 0 then
Hue := Hue + 1 Hue := Hue + 1
else else if Hue > 1 then
if Hue > 1 then
Hue := Hue - 1; Hue := Hue - 1;
if 6 * Hue < 1 then if 6 * Hue < 1 then
V := M1 + (M2 - M1) * Hue * 6 V := M1 + (M2 - M1) * Hue * 6
else else if 2 * Hue < 1 then
if 2 * Hue < 1 then
V := M2 V := M2
else else if 3 * Hue < 2 then
if 3 * Hue < 2 then
V := M1 + (M2 - M1) * (2/3 - Hue) * 6 V := M1 + (M2 - M1) * (2/3 - Hue) * 6
else else
V := M1; V := M1;
@ -86,10 +83,9 @@ end;
function HSLRangeToRGB(H, S, L: integer): TColor; function HSLRangeToRGB(H, S, L: integer): TColor;
begin begin
if s > MaxSat then s := MaxSat; Clamp(H, 0, MaxHue);
if s < 0 then s := 0; Clamp(S, 0, MaxSat);
if l > MaxLum then l := MaxLum; Clamp(L, 0, MaxLum);
if l < 0 then l := 0;
Result := HSLToRGB(H / MaxHue, S / MaxSat, L / MaxLum); Result := HSLToRGB(H / MaxHue, S / MaxSat, L / MaxLum);
end; end;
@ -122,8 +118,7 @@ begin
//calc H //calc H
if R = Cmax then if R = Cmax then
H := (G - B) / D H := (G - B) / D
else else if G = Cmax then
if G = Cmax then
H := 2 + (B - R) /D H := 2 + (B - R) /D
else else
H := 4 + (R - G) / D; H := 4 + (R - G) / D;
@ -159,12 +154,6 @@ begin
RGBToHSLRange(AColor, d, d, l); RGBToHSLRange(AColor, d, d, l);
Result := l; Result := l;
end; end;
{
procedure Clamp(var Input: integer; Min, Max: integer);
begin
if (Input < Min) then Input := Min;
if (Input > Max) then Input := Max;
end; }
function HSLToRGBTriple(H, S, L: integer): TRGBTriple; function HSLToRGBTriple(H, S, L: integer): TRGBTriple;
const const
@ -247,6 +236,7 @@ procedure RGBTripleToHSL(RGBTriple: TRGBTriple; var h, s, l: integer);
if (Result > RGB.rgbtGreen) then Result := RGB.rgbtGreen; if (Result > RGB.rgbtGreen) then Result := RGB.rgbtGreen;
if (Result > RGB.rgbtBlue) then Result := RGB.rgbtBlue; if (Result > RGB.rgbtBlue) then Result := RGB.rgbtBlue;
end; end;
var var
Delta, Min: byte; Delta, Min: byte;
begin begin
@ -265,11 +255,9 @@ begin
begin begin
if (rgbtRed = L) then if (rgbtRed = L) then
H := MulDiv(60, rgbtGreen-rgbtBlue, Delta) H := MulDiv(60, rgbtGreen-rgbtBlue, Delta)
else else if (rgbtGreen = L) then
if (rgbtGreen = L) then
H := MulDiv(60, rgbtBlue-rgbtRed, Delta) + 120 H := MulDiv(60, rgbtBlue-rgbtRed, Delta) + 120
else else if (rgbtBlue = L) then
if (rgbtBlue = L) then
H := MulDiv(60, rgbtRed-rgbtGreen, Delta) + 240; H := MulDiv(60, rgbtRed-rgbtGreen, Delta) + 240;
if (H < 0) then H := H + 360; if (H < 0) then H := H + 360;
end; end;

10
components/mbColorLib/RGBHSVUtils.pas
View File

@ -50,12 +50,12 @@ end;
function RGBTripleToColor(Triple: TRGBTriple): TColor; function RGBTripleToColor(Triple: TRGBTriple): TColor;
begin begin
Result := TColor(RGB(Triple.rgbtRed, Triple.rgbtGreen, Triple.rgbtBlue)); Result := RGB(Triple.rgbtRed, Triple.rgbtGreen, Triple.rgbtBlue);
end; end;
procedure RGBToHSV(R, G, B: integer; var H, S, V: integer); procedure RGBToHSV(R, G, B: integer; var H, S, V: integer);
var var
Delta, Min, H1, S1: real; Delta, Min, H1, S1: double;
begin begin
h1 := h; h1 := h;
s1 := s; s1 := s;
@ -69,11 +69,9 @@ begin
begin begin
if R = V then if R = V then
H1 := 60.0 * (G - B) / Delta H1 := 60.0 * (G - B) / Delta
else else if G = V then
if G = V then
H1 := 120.0 + 60.0 * (B - R) / Delta H1 := 120.0 + 60.0 * (B - R) / Delta
else else if B = V then
if B = V then
H1 := 240.0 + 60.0 * (R - G) / Delta; H1 := 240.0 + 60.0 * (R - G) / Delta;
if H1 < 0.0 then H1 := H1 + 360.0; if H1 < 0.0 then H1 := H1 + 360.0;
end; end;

1
components/mbColorLib/YColorPicker.pas
View File

@ -19,7 +19,6 @@ type
TYColorPicker = class(TmbTrackBarPicker) TYColorPicker = class(TmbTrackBarPicker)
private private
FYellow, FMagenta, FCyan, FBlack: integer; FYellow, FMagenta, FCyan, FBlack: integer;
function ArrowPosFromYellow(y: integer): integer; function ArrowPosFromYellow(y: integer): integer;
function YellowFromArrowPos(p: integer): integer; function YellowFromArrowPos(p: integer): integer;
function GetSelectedColor: TColor; function GetSelectedColor: TColor;

11
components/mbColorLib/mbColorList.pas
View File

@ -167,9 +167,11 @@ end;
constructor TmbColorList.Create(AOwner: TComponent); constructor TmbColorList.Create(AOwner: TComponent);
begin begin
inherited; inherited;
{
MaxHue := 360; MaxHue := 360;
MaxSat := 255; MaxSat := 255;
MaxLum := 255; MaxLum := 255;
}
style := lbOwnerDrawFixed; style := lbOwnerDrawFixed;
SetLength(Colors, 0); SetLength(Colors, 0);
ItemHeight := 48; ItemHeight := 48;
@ -325,16 +327,10 @@ var
i: integer; i: integer;
begin begin
if Length(Colors) = 0 then if Length(Colors) = 0 then
begin
raise Exception.Create('There''s nothing to delete! The length of the array is 0.'); raise Exception.Create('There''s nothing to delete! The length of the array is 0.');
Exit;
end;
if Index > Length(Colors) - 1 then if Index > Length(Colors) - 1 then
begin
raise Exception.Create(Format('List index out of bounds (%d)', [Index])); raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
Exit;
end;
for i := Index to Length(Colors) - 2 do for i := Index to Length(Colors) - 2 do
Colors[i] := Colors[i+1]; Colors[i] := Colors[i+1];
@ -382,10 +378,7 @@ var
i: integer; i: integer;
begin begin
if Index > Length(Colors) - 1 then if Index > Length(Colors) - 1 then
begin
raise Exception.Create(Format('List index out of bounds (%d)', [Index])); raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
Exit;
end;
SetLength(Colors, Length(Colors) + 1); SetLength(Colors, Length(Colors) + 1);
for i := Length(Colors) - 1 downto Index do for i := Length(Colors) - 1 downto Index do

17
components/mbColorLib/mbColorPalette.pas
View File

@ -583,8 +583,7 @@ begin
begin begin
if FState <> ccsNone then if FState <> ccsNone then
InflateRect(R, -2, -2) InflateRect(R, -2, -2)
else else if FColCount > 1 then
if FColCount > 1 then
Inc(R.Right); Inc(R.Right);
end; end;
with ACanvas do with ACanvas do
@ -933,7 +932,8 @@ begin
FCheckedIndex := GetMoveCellIndex(mdDown); FCheckedIndex := GetMoveCellIndex(mdDown);
if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift); if Assigned(FOnArrowKey) then FOnArrowKey(Message.CharCode, Shift);
end; end;
VK_SPACE, VK_RETURN: if Assigned(FOnChange) then FOnChange(Self); VK_SPACE, VK_RETURN:
if Assigned(FOnChange) then FOnChange(Self);
else else
begin begin
FInherited := true; FInherited := true;
@ -970,7 +970,8 @@ if (Colors.Count > 0) and (FIndex > -1) then
clr := GetColorUnderCursor; clr := GetColorUnderCursor;
//fire event //fire event
Handled := false; Handled := false;
if Assigned(FOnGetHintText) then FOnGetHintText(clr, GetIndexUnderCursor, HintStr, Handled); if Assigned(FOnGetHintText) then
FOnGetHintText(clr, GetIndexUnderCursor, HintStr, Handled);
if Handled then Exit; if Handled then Exit;
//do default //do default
if FIndex < FNames.Count then if FIndex < FNames.Count then
@ -1112,8 +1113,7 @@ begin
FNames.Clear; FNames.Clear;
FColors.Text := ReadJASCPal(FileName); FColors.Text := ReadJASCPal(FileName);
end end
else else if SameText(ExtractFileExt(FileName), '.aco') then
if SameText(ExtractFileExt(FileName), '.aco') then
begin begin
supported := true; supported := true;
a := ReadPhotoshopAco(FileName); a := ReadPhotoshopAco(FileName);
@ -1125,15 +1125,14 @@ begin
for i := 0 to Length(a.Names) - 1 do for i := 0 to Length(a.Names) - 1 do
FNames.Add(a.Names[i]); FNames.Add(a.Names[i]);
end end
else else if SameText(ExtractFileExt(FileName), '.act') then
if SameText(ExtractFileExt(FileName), '.act') then
begin begin
supported := true; supported := true;
FNames.Clear; FNames.Clear;
FColors.Text := ReadPhotoshopAct(FileName); FColors.Text := ReadPhotoshopAct(FileName);
end end
else 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'); 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 if supported then
begin begin
CalcAutoHeight; CalcAutoHeight;

5
components/mbColorLib/mbColorPreview.pas
View File

@ -51,7 +51,6 @@ type
property DragMode; property DragMode;
property DragKind; property DragKind;
property Constraints; property Constraints;
property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange; property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange;
property OnOpacityChange: TNotifyEvent read FOnOpacityChange write FOnOpacityChange; property OnOpacityChange: TNotifyEvent read FOnOpacityChange write FOnOpacityChange;
property OnContextPopup; property OnContextPopup;
@ -71,6 +70,7 @@ type
property OnDblClick; property OnDblClick;
end; end;
implementation implementation
uses uses
@ -84,8 +84,7 @@ begin
DoubleBuffered := true; DoubleBuffered := true;
ControlStyle := COntrolStyle - [csAcceptsControls] + [csOpaque]; ControlStyle := COntrolStyle - [csAcceptsControls] + [csOpaque];
FSelColor := clWhite; FSelColor := clWhite;
Width := 68; SetInitialBounds(0, 0, 68, 32);
Height := 32;
TabStop := false; TabStop := false;
FOpacity := 100; FOpacity := 100;
FBlockSize := 6; FBlockSize := 6;

93
components/mbColorLib/mbColorTree.pas
View File

@ -25,8 +25,8 @@ type
{$ENDIF} {$ENDIF}
TmbColor = record TmbColor = record
name: string; Name: string;
value: TColor; Value: TColor;
end; end;
TDrawCaptionEvent = procedure (Sender: TObject; AIndex: integer; AFont: TFont; var AText: string; Selected: boolean) of object; TDrawCaptionEvent = procedure (Sender: TObject; AIndex: integer; AFont: TFont; var AText: string; Selected: boolean) of object;
@ -35,7 +35,6 @@ type
TmbColorTree = class(TCustomTreeView) TmbColorTree = class(TCustomTreeView)
private private
dummy: TCustomImageList;
FInfo1, FInfo2: string; FInfo1, FInfo2: string;
FInfoLabel: string; FInfoLabel: string;
FDraw: TDrawCaptionEvent; FDraw: TDrawCaptionEvent;
@ -63,15 +62,13 @@ type
Colors: array of TmbColor; Colors: array of TmbColor;
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure UpdateColors; procedure UpdateColors;
procedure AddColor(Name: string; Value: TColor; refresh: boolean = true); procedure AddColor(AName: string; AValue: TColor; ARefresh: boolean = true);
procedure ClearColors; procedure ClearColors;
procedure DeleteColor(Index: integer; refresh: boolean = true); procedure DeleteColor(AIndex: integer; ARefresh: boolean = true);
procedure DeleteColorByName(Name: string; All: boolean); procedure DeleteColorByName(AName: string; All: boolean);
procedure DeleteColorByValue(Value: TColor; All: boolean); procedure DeleteColorByValue(AValue: TColor; All: boolean);
procedure InsertColor(Index: integer; Name: string; Value: TColor); procedure InsertColor(AIndex: integer; AName: string; AValue: TColor);
function ColorCount: integer; function ColorCount: integer;
published published
property InfoLabelText: string read FInfoLabel write SetInfoLabel; property InfoLabelText: string read FInfoLabel write SetInfoLabel;
@ -117,7 +114,6 @@ type
property TabStop default True; property TabStop default True;
property ToolTips; property ToolTips;
property Visible; property Visible;
property OnGetHint: TGetHintEvent read FGetHint write FGetHint; property OnGetHint: TGetHintEvent read FGetHint write FGetHint;
property OnDrawCaption: TDrawCaptionEvent read FDraw write FDraw; property OnDrawCaption: TDrawCaptionEvent read FDraw write FDraw;
property OnDrawInfoLabel: TDrawLabelEvent read FDraw1 write FDraw1; property OnDrawInfoLabel: TDrawLabelEvent read FDraw1 write FDraw1;
@ -205,9 +201,11 @@ constructor TmbColorTree.Create(AOwner: TComponent);
begin begin
inherited; inherited;
ControlStyle := ControlStyle + [csDisplayDragImage]; ControlStyle := ControlStyle + [csDisplayDragImage];
{
MaxHue := 360; MaxHue := 360;
MaxSat := 255; MaxSat := 255;
MaxLum := 255; MaxLum := 255;
}
ReadOnly := true; ReadOnly := true;
ShowButtons := false; ShowButtons := false;
ShowLines := false; ShowLines := false;
@ -218,23 +216,11 @@ begin
Images := TImageList.Create(Self); Images := TImageList.Create(Self);
Images.Width := 48; Images.Width := 48;
Images.Height := 48; Images.Height := 48;
{
dummy := TCustomImageList.Create(Self);
dummy.Width := 48;
dummy.Height := 48;
Images := dummy;
}
FInfoLabel := 'Color Values:'; FInfoLabel := 'Color Values:';
FInfo1 := 'RGB: %r.%g.%b'; FInfo1 := 'RGB: %r.%g.%b';
FInfo2 := 'HEX: #%hex'; FInfo2 := 'HEX: #%hex';
end; end;
destructor TmbColorTree.Destroy;
begin
dummy.Free;
inherited;
end;
procedure TmbColorTree.UpdateColors; procedure TmbColorTree.UpdateColors;
var var
i: integer; i: integer;
@ -257,7 +243,7 @@ begin
if Selected <> nil then if Selected <> nil then
r := Selected.DisplayRect(false) r := Selected.DisplayRect(false)
else else
Exit; exit;
if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then
if (Selected.HasChildren) and PtInRect(r, Point(x, y)) then if (Selected.HasChildren) and PtInRect(r, Point(x, y)) then
begin begin
@ -281,7 +267,7 @@ begin
else else
begin begin
Cursor := crDefault; Cursor := crDefault;
Exit; exit;
end; end;
if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then if (x > r.Right - 15) and (x < r.Right - 3) and (y > r.Top + 13) and (y < r.Top + 30) then
@ -306,7 +292,8 @@ begin
DrawInfoItem(Node.DisplayRect(false), node.Parent.Index); DrawInfoItem(Node.DisplayRect(false), node.Parent.Index);
end; end;
procedure TmbColorTree.DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint; sel: boolean); procedure TmbColorTree.DoArrow(c: TCanvas; dir: TScrollDirection; p: TPoint;
sel: boolean);
var var
b: TBitmap; b: TBitmap;
begin begin
@ -337,7 +324,8 @@ begin
end; end;
end; end;
procedure TmbColorTree.DrawColorItem(R: TRect; Selected: boolean; Index: integer; itemText: string; Expanded: boolean); procedure TmbColorTree.DrawColorItem(R: TRect; Selected: boolean; Index: integer;
itemText: string; Expanded: boolean);
var var
SR, TR: TRect; SR, TR: TRect;
begin begin
@ -541,15 +529,16 @@ begin
end; end;
end; end;
procedure TmbColorTree.AddColor(Name: string; Value: TColor; refresh: boolean = true); procedure TmbColorTree.AddColor(AName: string; AValue: TColor;
ARefresh: boolean = true);
var var
L: integer; L: integer;
begin begin
L := Length(Colors); L := Length(Colors);
SetLength(Colors, L + 1); SetLength(Colors, L + 1);
Colors[L].name := Name; Colors[L].Name := AName;
Colors[L].value := Value; Colors[L].Value := AValue;
if refresh then if ARefresh then
UpdateColors; UpdateColors;
end; end;
@ -564,35 +553,29 @@ begin
Result := Length(Colors); Result := Length(Colors);
end; end;
procedure TmbColorTree.DeleteColor(Index: integer; refresh: boolean = true); procedure TmbColorTree.DeleteColor(AIndex: integer; ARefresh: boolean = true);
var var
i: integer; i: integer;
begin begin
if Length(Colors) = 0 then if Length(Colors) = 0 then
begin
raise Exception.Create('There''s nothing to delete! The length of the array is 0.'); raise Exception.Create('There''s nothing to delete! The length of the array is 0.');
Exit;
end;
if Index > Length(Colors) - 1 then if AIndex > Length(Colors) - 1 then
begin raise Exception.Create(Format('List index out of bounds (%d)', [AIndex]));
raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
Exit;
end;
for i := Index to Length(Colors) - 2 do for i := AIndex to Length(Colors) - 2 do
Colors[i] := Colors[i+1]; Colors[i] := Colors[i+1];
SetLength(Colors, Length(Colors) - 1); SetLength(Colors, Length(Colors) - 1);
if refresh then if ARefresh then
UpdateColors; UpdateColors;
end; end;
procedure TmbColorTree.DeleteColorByName(Name: string; All: boolean); procedure TmbColorTree.DeleteColorByName(AName: string; All: boolean);
var var
i: integer; i: integer;
begin begin
for i := Length(Colors) - 1 downto 0 do for i := Length(Colors) - 1 downto 0 do
if SameText(Colors[i].name, Name) then if SameText(Colors[i].Name, AName) then
begin begin
DeleteColor(i, false); DeleteColor(i, false);
if not All then if not All then
@ -604,12 +587,12 @@ begin
UpdateColors; UpdateColors;
end; end;
procedure TmbColorTree.DeleteColorByValue(Value: TColor; All: boolean); procedure TmbColorTree.DeleteColorByValue(AValue: TColor; All: boolean);
var var
i: integer; i: integer;
begin begin
for i := Length(Colors) - 1 downto 0 do for i := Length(Colors) - 1 downto 0 do
if Colors[i].Value = Value then if Colors[i].Value = AValue then
begin begin
DeleteColor(i, false); DeleteColor(i, false);
if not All then if not All then
@ -621,22 +604,19 @@ begin
UpdateColors; UpdateColors;
end; end;
procedure TmbColorTree.InsertColor(Index: integer; Name: string; Value: TColor); procedure TmbColorTree.InsertColor(AIndex: integer; AName: string; AValue: TColor);
var var
i: integer; i: integer;
begin begin
if Index > Length(Colors) - 1 then if AIndex > Length(Colors) - 1 then
begin raise Exception.Create(Format('List index out of bounds (%d)', [AIndex]));
raise Exception.Create(Format('List index out of bounds (%d)', [Index]));
Exit;
end;
SetLength(Colors, Length(Colors) + 1); SetLength(Colors, Length(Colors) + 1);
for i := Length(Colors) - 1 downto Index do for i := Length(Colors) - 1 downto AIndex do
Colors[i] := Colors[i-1]; Colors[i] := Colors[i-1];
Colors[Index].Name := Name; Colors[AIndex].Name := AName;
Colors[Index].Value := Value; Colors[AIndex].Value := AValue;
UpdateColors; UpdateColors;
end; end;
@ -666,7 +646,8 @@ if PtInRect(ClientRect, Point(mx, my)) and ShowHint and not Dragging then
ReshowTimeout := 2000; ReshowTimeout := 2000;
HideTimeout := 1000; HideTimeout := 1000;
Handled := false; Handled := false;
if Assigned(FGetHint) then FGetHint(i, HintStr, Handled); if Assigned(FGetHint) then
FGetHint(i, HintStr, Handled);
if Handled then if Handled then
HintStr := FormatHint(HintStr, Colors[i].Value) HintStr := FormatHint(HintStr, Colors[i].Value)
else else

2
components/mbColorLib/mbDeskPickerButton.pas
View File

@ -50,7 +50,7 @@ implementation
constructor TmbDeskPickerButton.Create(AOwner: TComponent); constructor TmbDeskPickerButton.Create(AOwner: TComponent);
begin begin
inherited; inherited;
DoubleBuffered := true; // DoubleBuffered := true;
// ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}]; // ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque{$IFDEF DELPHI_7_UP}, csParentBackground{$ENDIF}];
FHintFmt := 'RGB(%r, %g, %b)'#13'Hex: %h'; FHintFmt := 'RGB(%r, %g, %b)'#13'Hex: %h';
FShowScreenHint := false; FShowScreenHint := false;

9
components/mbColorLib/mbutils.pas
View File

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