paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ColorPalette: Some cosmetic changes. Add new event OnSelectColor (which fires if ShiftState matches, in contrast to OnColorPick which fires always now).

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4280 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz 2015-08-21 12:38:46 +00:00
parent 7f5584ad24
commit bec8c5ac86
3 changed files with 280 additions and 262 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

388
components/colorpalette/colorpalette.pas
View File

@ -53,15 +53,16 @@ uses
type type
TPickMode = ( TPickMode = (
pmDefault, // Select color at mouse-down, ColorPick event at mouse-up if at same pos pmDefault, // Select color at mouse-down, ColorPick event at mouse-up if at same pos
pmImproved, // Select color and ColorPick event at mouse-down pmImmediate, // Select color and ColorPick event at mouse-down
pmContinuous // Select color at mouse-down and mouse-move, ColorPick event at mouse-up pmContinuous // Select color at mouse-down and mouse-move, ColorPick event at mouse-up
); );
TPickShiftEnum = (ssLeft, ssRight, ssMiddle); TPickShiftEnum = (ssLeft, ssRight, ssMiddle);
TPickShift = set of TPickShiftEnum; TPickShift = set of TPickShiftEnum;
TColorMouseEvent = procedure (Sender: TObject; AColor: TColor; Shift: TShiftState) of object; TColorMouseEvent = procedure (Sender: TObject; AColor: TColor; Shift: TShiftState) of object;
TColorPaletteEvent = procedure (Sender: TObject; AColor: TColor) of object;
{ TCustomColorPalette } { TCustomColorPalette }
@ -72,9 +73,11 @@ type
FCols: Integer; FCols: Integer;
FOnColorMouseMove: TColorMouseEvent; FOnColorMouseMove: TColorMouseEvent;
FOnColorPick: TColorMouseEvent; FOnColorPick: TColorMouseEvent;
FOnSelectColor: TColorPaletteEvent;
FRows: Integer; FRows: Integer;
FColors: TList; FColors: TList;
FPickedColor: TColor; FPickedColor: TColor;
FSelectedColor: TColor; // same as PickedColor, but updated only if "IsCorrectShift"
FPickMode: TPickMode; FPickMode: TPickMode;
FPickShift: TPickShift; FPickShift: TPickShift;
FMousePt: TPoint; FMousePt: TPoint;
@ -91,7 +94,9 @@ type
procedure ColorPick(AColor: TColor; Shift: TShiftState); dynamic; procedure ColorPick(AColor: TColor; Shift: TShiftState); dynamic;
procedure ColorMouseMove(AColor: TColor; Shift: TShiftState); dynamic; procedure ColorMouseMove(AColor: TColor; Shift: TShiftState); dynamic;
procedure DoAddColor(AColor: TColor); virtual; procedure DoAddColor(AColor: TColor); virtual;
procedure DoColorPick(AColor: TColor; AShift: TShiftState); virtual;
procedure DoDeleteColor(AIndex: Integer); virtual; procedure DoDeleteColor(AIndex: Integer); virtual;
procedure DoSelectColor(AColor: TColor); virtual;
function IsCorrectShift(Shift: TShiftState): Boolean; function IsCorrectShift(Shift: TShiftState): Boolean;
procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X, Y:Integer); override; procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X, Y:Integer); override;
procedure MouseMove(Shift:TShiftState; X, Y:Integer); override; procedure MouseMove(Shift:TShiftState; X, Y:Integer); override;
@ -114,8 +119,10 @@ type
property Colors[Index: Integer]: TColor read GetColors write SetColors; property Colors[Index: Integer]: TColor read GetColors write SetColors;
property ColorCount: Integer read GetColorCount; property ColorCount: Integer read GetColorCount;
property PickedColor: TColor read FPickedColor; property PickedColor: TColor read FSelectedColor; deprecated 'Use SelectedColor';
property SelectedColor: TColor read FSelectedColor;
property OnSelectColor: TColorPaletteEvent read FOnSelectColor write FOnSelectColor;
property OnColorPick: TColorMouseEvent read FOnColorPick write FOnColorPick; property OnColorPick: TColorMouseEvent read FOnColorPick write FOnColorPick;
property OnColorMouseMove: TColorMouseEvent read FOnColorMouseMove write FOnColorMouseMove; property OnColorMouseMove: TColorMouseEvent read FOnColorMouseMove write FOnColorMouseMove;
@ -157,10 +164,12 @@ type
property OnMouseEnter; property OnMouseEnter;
property OnMouseLeave; property OnMouseLeave;
property OnResize; property OnResize;
property OnSelectColor;
end; end;
procedure Register; procedure Register;
implementation implementation
procedure Register; procedure Register;
@ -168,169 +177,20 @@ begin
RegisterComponents('Misc', [TColorPalette]); RegisterComponents('Misc', [TColorPalette]);
end; end;
{ TCustomColorPalette } { TCustomColorPalette }
procedure TCustomColorPalette.SetButtonHeight(const AValue: Integer);
begin
if FButtonHeight = AValue then Exit;
FButtonHeight := AValue;
if FButtonHeight < 1 then FButtonHeight := 1;
UpdateSize;
end;
function TCustomColorPalette.GetColorCount: Integer;
begin
Result := FColors.Count;
end;
function TCustomColorPalette.GetColors(Index: Integer): TColor;
begin
Result := TColor(PtrUInt(FColors.Items[Index]));
end;
procedure TCustomColorPalette.SetButtonWidth(const AValue: Integer);
begin
if FButtonWidth = AValue then Exit;
FButtonWidth := AValue;
if FButtonWidth < 1 then FButtonWidth := 1;
UpdateSize;
end;
procedure TCustomColorPalette.SetColors(Index: Integer; const AValue: TColor);
begin
FColors.Items[Index] := Pointer(AValue);
Invalidate;
end;
procedure TCustomColorPalette.SetCols(AValue: Integer);
begin
if AValue = FCols then
exit;
FCols := AValue;
UpdateSize;
Invalidate;
end;
procedure TCustomColorPalette.UpdateSize;
begin
if (FCols = 0) or (FColors.Count = 0) then FRows := 0
else
FRows := Ceil(FColors.Count / FCols);
SetBounds(Left, Top, FCols * FButtonWidth + 1, FRows * FButtonHeight + 1);
end;
procedure TCustomColorPalette.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
inherited;
FMousePt.X := X;
FMousePt.Y := Y;
X := X div FButtonWidth;
Y := Y div FButtonHeight;
FMouseIndex := X + Y * FCols;
FPrevMouseIndex := FMouseIndex;
if FMouseIndex < 0 then
Exit;
if (FMouseIndex < FColors.Count) then
begin
FPickedColor := GetColors(FMouseIndex);
FStoredShift := Shift; // store for usage by pmDefault at MouseUp
if FPickMode <> pmDefault then
ColorPick(FPickedColor, Shift);
end;
end;
procedure TCustomColorPalette.MouseUp(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
case FPickMode of
pmDefault:
if (FMousePt.X = X) and (FMousePt.Y = Y) then
ColorPick(FPickedColor, FStoredShift);
pmImproved, pmContinuous:
begin
X := X div FButtonWidth;
Y := Y div FButtonHeight;
FMouseIndex := X + Y * FCols;
if (FMouseIndex >= 0) and (FMouseIndex < FColors.Count) and
(FMouseIndex <> FPrevMouseIndex) then
begin
FPickedColor := GetColors(FMouseIndex);
ColorPick(FPickedColor, Shift);
end;
end;
end;
FPrevMouseIndex := -1;
inherited;
end;
procedure TCustomColorPalette.MouseMove(Shift: TShiftState; X, Y: Integer);
var
C: TColor;
begin
inherited;
X := X div FButtonWidth;
Y := Y div FButtonHeight;
FMouseIndex := X + Y * FCols;
if (FMouseIndex >= 0) and (FMouseIndex < FColors.Count) and
(FMouseIndex <> FPrevMouseIndex) then
begin
C := GetColors(FMouseIndex);
if C <> clNone then
ColorMouseMove(C, Shift);
if FPickMode = pmContinuous then begin
FPickedColor := GetColors(FMouseIndex);
ColorPick(FPickedColor, Shift);
end;
end;
FPrevMouseIndex := FMouseIndex;
end;
function TCustomColorPalette.IsCorrectShift(Shift: TShiftState): Boolean;
var
ss: TShiftState;
begin
Result := True;
if (ssLeft in FPickShift) and (Classes.ssLeft in Shift) then exit;
if (ssRight in FPickShift) and (Classes.ssRight in Shift) then exit;
if (ssMiddle in FPickShift) and (Classes.ssMiddle in Shift) then exit;
Result := false;
end;
procedure TCustomColorPalette.ColorPick(AColor: TColor; Shift: TShiftState);
begin
if IsCorrectShift(Shift) and Assigned(FOnColorPick) then
FOnColorPick(Self, AColor, Shift);
end;
procedure TCustomColorPalette.ColorMouseMove(AColor: TColor; Shift: TShiftState);
begin
if IsCorrectShift(Shift) and Assigned(FOnColorMouseMove) then
FOnColorMouseMove(Self, AColor, Shift);
end;
constructor TCustomColorPalette.Create(TheOwner: TComponent); constructor TCustomColorPalette.Create(TheOwner: TComponent);
begin begin
inherited; inherited;
ControlStyle := ControlStyle + [csFixedWidth, csFixedHeight];
FColors := TList.Create; FColors := TList.Create;
FButtonWidth := 12; FButtonWidth := 12;
FButtonHeight := 12; FButtonHeight := 12;
FPrevMouseIndex := -1; FPrevMouseIndex := -1;
FPickShift := [ssLeft]; FPickShift := [ssLeft];
ControlStyle := ControlStyle + [csFixedWidth, csFixedHeight];
FCols := 8; FCols := 8;
DoAddColor(clBlack); DoAddColor(clBlack);
@ -357,7 +217,6 @@ end;
destructor TCustomColorPalette.Destroy; destructor TCustomColorPalette.Destroy;
begin begin
FColors.Free; FColors.Free;
inherited; inherited;
end; end;
@ -368,6 +227,19 @@ begin
Invalidate; Invalidate;
end; end;
procedure TCustomColorPalette.ColorPick(AColor: TColor; Shift: TShiftState);
begin
DoColorPick(AColor, Shift);
if IsCorrectShift(Shift) then
DoSelectColor(AColor);
end;
procedure TCustomColorPalette.ColorMouseMove(AColor: TColor; Shift: TShiftState);
begin
if Assigned(FOnColorMouseMove) then
FOnColorMouseMove(Self, AColor, Shift);
end;
procedure TCustomColorPalette.DeleteColor(AIndex: Integer); procedure TCustomColorPalette.DeleteColor(AIndex: Integer);
begin begin
DoDeleteColor(AIndex); DoDeleteColor(AIndex);
@ -380,29 +252,42 @@ begin
FColors.Add(Pointer(AColor)); FColors.Add(Pointer(AColor));
end; end;
procedure TCustomColorPalette.DoColorPick(AColor: TColor; AShift: TShiftState);
begin
if Assigned(FOnColorPick) then
FOnColorPick(Self, AColor, AShift);
end;
procedure TCustomColorPalette.DoDeleteColor(AIndex: Integer); procedure TCustomColorPalette.DoDeleteColor(AIndex: Integer);
begin begin
FColors.Delete(AIndex); FColors.Delete(AIndex);
end; end;
procedure TCustomColorPalette.Paint; procedure TCustomColorPalette.DoSelectColor(AColor: TColor);
var
I, X, Y: Integer;
c: TColor;
begin begin
Canvas.Pen.Color := clBlack; FSelectedColor := AColor;
for I := 0 to Pred(FColors.Count) do if Assigned(FOnSelectColor) then FOnSelectColor(self, AColor);
begin end;
Y := I div FCols;
X := I mod FCols; function TCustomColorPalette.GetColorCount: Integer;
c := GetColors(I); begin
if c <> clNone then Result := FColors.Count;
begin end;
Canvas.Brush.Color := c;
Canvas.Rectangle(Bounds(X * FButtonWidth, Y * FButtonHeight, FButtonWidth, function TCustomColorPalette.GetColors(Index: Integer): TColor;
FButtonHeight)); begin
end; Result := TColor(PtrUInt(FColors.Items[Index]));
end; end;
function TCustomColorPalette.IsCorrectShift(Shift: TShiftState): Boolean;
var
ss: TShiftState;
begin
Result := True;
if (ssLeft in FPickShift) and (Classes.ssLeft in Shift) then exit;
if (ssRight in FPickShift) and (Classes.ssRight in Shift) then exit;
if (ssMiddle in FPickShift) and (Classes.ssMiddle in Shift) then exit;
Result := false;
end; end;
procedure TCustomColorPalette.LoadPalette(const FileName: String); procedure TCustomColorPalette.LoadPalette(const FileName: String);
@ -410,7 +295,7 @@ var
F: TextFile; F: TextFile;
Line: String; Line: String;
C: TColor; C: TColor;
function ParseColor(var S: String): TColor; function ParseColor(var S: String): TColor;
var var
R, G, B: Integer; R, G, B: Integer;
@ -420,7 +305,7 @@ var
Delete(S, 1, Pos(',', S)); Delete(S, 1, Pos(',', S));
G := StrToIntDef(Copy(S, 1, Pos(',', S) - 1), 0); G := StrToIntDef(Copy(S, 1, Pos(',', S) - 1), 0);
Delete(S, 1, Pos(',', S)); Delete(S, 1, Pos(',', S));
S := TrimLeft(S); S := TrimLeft(S);
I := 1; I := 1;
while (I <= Length(S)) and (S[I] in ['0'..'9']) do Inc(I); while (I <= Length(S)) and (S[I] in ['0'..'9']) do Inc(I);
@ -429,14 +314,14 @@ var
Result := RGBToColor(Max(0, Min(R, 255)), Max(0, Min(G, 255)), Max(0, Min(B, 255))); Result := RGBToColor(Max(0, Min(R, 255)), Max(0, Min(G, 255)), Max(0, Min(B, 255)));
end; end;
procedure BlendWBColor(Color: TColor; Steps: Integer); procedure BlendWBColor(Color: TColor; Steps: Integer);
var var
I: Integer; I: Integer;
R, G, B, NR, NG, NB: Byte; R, G, B, NR, NG, NB: Byte;
begin begin
RedGreenBlue(Color, R, G, B); RedGreenBlue(Color, R, G, B);
for I := 1 to Steps do for I := 1 to Steps do
begin begin
NR := Round((R * I + 255 * (Steps + 1 - I)) / (Steps + 1)); NR := Round((R * I + 255 * (Steps + 1 - I)) / (Steps + 1));
@ -444,9 +329,9 @@ var
NB := Round((B * I + 255 * (Steps + 1 - I)) / (Steps + 1)); NB := Round((B * I + 255 * (Steps + 1 - I)) / (Steps + 1));
DoAddColor(RGBToColor(NR, NG, NB)); DoAddColor(RGBToColor(NR, NG, NB));
end; end;
DoAddColor(Color); DoAddColor(Color);
for I := Steps downto 1 do for I := Steps downto 1 do
begin begin
NR := Round(R * I / (Steps + 1)); NR := Round(R * I / (Steps + 1));
@ -455,7 +340,7 @@ var
DoAddColor(RGBToColor(NR, NG, NB)); DoAddColor(RGBToColor(NR, NG, NB));
end; end;
end; end;
begin begin
if not FileExists(FileName) then if not FileExists(FileName) then
raise Exception.Create(Format('[TCustomColorPalette.LoadPalette] File not found: %s', [FileName])); raise Exception.Create(Format('[TCustomColorPalette.LoadPalette] File not found: %s', [FileName]));
@ -489,11 +374,108 @@ begin
finally finally
Close(F); Close(F);
end; end;
UpdateSize; UpdateSize;
Invalidate; Invalidate;
end; end;
procedure TCustomColorPalette.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
inherited;
FMousePt.X := X;
FMousePt.Y := Y;
X := X div FButtonWidth;
Y := Y div FButtonHeight;
FMouseIndex := X + Y * FCols;
FPrevMouseIndex := FMouseIndex;
if FMouseIndex < 0 then
Exit;
if (FMouseIndex < FColors.Count) then
begin
FPickedColor := GetColors(FMouseIndex);
FStoredShift := Shift; // store for usage by pmDefault at MouseUp
if FPickMode <> pmDefault then
ColorPick(FPickedColor, Shift);
end;
end;
procedure TCustomColorPalette.MouseMove(Shift: TShiftState; X, Y: Integer);
var
C: TColor;
begin
inherited;
X := X div FButtonWidth;
Y := Y div FButtonHeight;
FMouseIndex := X + Y * FCols;
if (FMouseIndex >= 0) and (FMouseIndex < FColors.Count) and
(FMouseIndex <> FPrevMouseIndex) then
begin
C := GetColors(FMouseIndex);
if C <> clNone then
ColorMouseMove(C, Shift);
if FPickMode = pmContinuous then begin
FPickedColor := GetColors(FMouseIndex);
ColorPick(FPickedColor, Shift);
end;
end;
FPrevMouseIndex := FMouseIndex;
end;
procedure TCustomColorPalette.MouseUp(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
case FPickMode of
pmDefault:
if (FMousePt.X = X) and (FMousePt.Y = Y) then
ColorPick(FPickedColor, FStoredShift);
pmImmediate, pmContinuous:
begin
X := X div FButtonWidth;
Y := Y div FButtonHeight;
FMouseIndex := X + Y * FCols;
if (FMouseIndex >= 0) and (FMouseIndex < FColors.Count) and
(FMouseIndex <> FPrevMouseIndex) then
begin
FPickedColor := GetColors(FMouseIndex);
ColorPick(FPickedColor, Shift);
end;
end;
end;
FPrevMouseIndex := -1;
inherited;
end;
procedure TCustomColorPalette.Paint;
var
I, X, Y: Integer;
c: TColor;
begin
Canvas.Pen.Color := clBlack;
for I := 0 to Pred(FColors.Count) do
begin
Y := I div FCols;
X := I mod FCols;
c := GetColors(I);
if c <> clNone then
begin
Canvas.Brush.Color := c;
Canvas.Rectangle(Bounds(X * FButtonWidth, Y * FButtonHeight, FButtonWidth,
FButtonHeight));
end;
end;
end;
procedure TCustomColorPalette.SavePalette(const Filename: String); procedure TCustomColorPalette.SavePalette(const Filename: String);
var var
i: Integer; i: Integer;
@ -519,6 +501,46 @@ begin
end; end;
end; end;
procedure TCustomColorPalette.SetButtonWidth(const AValue: Integer);
begin
if FButtonWidth = AValue then Exit;
FButtonWidth := AValue;
if FButtonWidth < 1 then FButtonWidth := 1;
UpdateSize;
end;
procedure TCustomColorPalette.SetButtonHeight(const AValue: Integer);
begin
if FButtonHeight = AValue then Exit;
FButtonHeight := AValue;
if FButtonHeight < 1 then FButtonHeight := 1;
UpdateSize;
end;
procedure TCustomColorPalette.SetColors(Index: Integer; const AValue: TColor);
begin
FColors.Items[Index] := Pointer(AValue);
Invalidate;
end;
procedure TCustomColorPalette.SetCols(AValue: Integer);
begin
if AValue = FCols then
exit;
FCols := AValue;
UpdateSize;
Invalidate;
end;
procedure TCustomColorPalette.UpdateSize;
begin
if (FCols = 0) or (FColors.Count = 0) then FRows := 0
else
FRows := Ceil(FColors.Count / FCols);
SetBounds(Left, Top, FCols * FButtonWidth + 1, FRows * FButtonHeight + 1);
end;
initialization initialization
{$I colorpalette.lrs} {$I colorpalette.lrs}

36
components/colorpalette/demo/unit1.lfm
View File

@ -19,9 +19,9 @@ object MainForm: TMainForm
ColumnCount = 8 ColumnCount = 8
PickShift = [ssLeft, ssMiddle] PickShift = [ssLeft, ssMiddle]
PopupMenu = PalettePopupMenu PopupMenu = PalettePopupMenu
OnColorPick = ColorPaletteColorPick
OnDblClick = ColorPaletteDblClick OnDblClick = ColorPaletteDblClick
OnMouseDown = ColorPaletteMouseDown OnMouseDown = ColorPaletteMouseDown
OnSelectColor = ColorPaletteSelectColor
end end
object Panel1: TPanel object Panel1: TPanel
Left = 0 Left = 0
@ -33,19 +33,19 @@ object MainForm: TMainForm
ClientHeight = 502 ClientHeight = 502
ClientWidth = 160 ClientWidth = 160
TabOrder = 0 TabOrder = 0
object curColor: TShape object ColorSample: TShape
Left = 10 Left = 10
Height = 29 Height = 29
Top = 13 Top = 13
Width = 63 Width = 63
end end
object LblInfo: TLabel object LblColorInfo: TLabel
Left = 12 Left = 12
Height = 65 Height = 65
Top = 45 Top = 45
Width = 135 Width = 135
AutoSize = False AutoSize = False
Caption = 'LblInfo' Caption = 'LblColorInfo'
Font.Color = clGreen Font.Color = clGreen
ParentColor = False ParentColor = False
ParentFont = False ParentFont = False
@ -98,13 +98,13 @@ object MainForm: TMainForm
OnClick = BtnLoadDefaultPalClick OnClick = BtnLoadDefaultPalClick
TabOrder = 4 TabOrder = 4
end end
object BtnDeleteCurrent: TButton object BtnDeleteColor: TButton
Left = 10 Left = 10
Height = 25 Height = 25
Top = 311 Top = 311
Width = 137 Width = 137
Caption = 'Delete color #0' Caption = 'Delete color #0'
OnClick = BtnDeleteCurrentClick OnClick = BtnDeleteColorClick
TabOrder = 5 TabOrder = 5
end end
object BtnLoadDefaultPal1: TButton object BtnLoadDefaultPal1: TButton
@ -115,16 +115,8 @@ object MainForm: TMainForm
Caption = 'Save palette...' Caption = 'Save palette...'
TabOrder = 6 TabOrder = 6
end end
object LblPaletteSize: TLabel
Left = 10
Height = 15
Top = 466
Width = 72
Caption = 'LblPaletteSize'
ParentColor = False
end
object EdColCount: TSpinEdit object EdColCount: TSpinEdit
Left = 12 Left = 11
Height = 23 Height = 23
Top = 432 Top = 432
Width = 66 Width = 66
@ -134,7 +126,7 @@ object MainForm: TMainForm
Value = 8 Value = 8
end end
object Label2: TLabel object Label2: TLabel
Left = 10 Left = 11
Height = 15 Height = 15
Top = 411 Top = 411
Width = 80 Width = 80
@ -142,16 +134,16 @@ object MainForm: TMainForm
ParentColor = False ParentColor = False
end end
object CbPickMode: TComboBox object CbPickMode: TComboBox
Left = 12 Left = 11
Height = 23 Height = 23
Hint = 'Defines when the picked color is determined and when the OnPickColor event is generated:'#13#10#13#10'pmDefault: '#13#10' Color selection at mouse-down, OnPickColor event at mouse-up if at same location'#13#10#13#10'pmImproved:'#13#10' Color selection and OnPickColor event at mouse-down'#13#10#13#10'pmContinuous:'#13#10' Color selection and OnPickColor event while mouse is down' Hint = 'Defines when the picked color is determined and when the OnPickColor event is generated:'#13#10#13#10'pmDefault: '#13#10' Color selection at mouse-down, OnPickColor event at mouse-up if at same location'#13#10#13#10'pmImmediate:'#13#10' Color selection and OnPickColor event at mouse-down'#13#10#13#10'pmContinuous:'#13#10' Color selection and OnPickColor event while mouse is down'
Top = 376 Top = 376
Width = 135 Width = 136
ItemHeight = 15 ItemHeight = 15
ItemIndex = 0 ItemIndex = 0
Items.Strings = ( Items.Strings = (
'default' 'default'
'improved' 'immediate'
'continuous' 'continuous'
) )
OnSelect = CbPickModeSelect OnSelect = CbPickModeSelect
@ -160,7 +152,7 @@ object MainForm: TMainForm
Text = 'default' Text = 'default'
end end
object LblPickMode: TLabel object LblPickMode: TLabel
Left = 12 Left = 11
Height = 15 Height = 15
Top = 355 Top = 355
Width = 56 Width = 56
@ -217,7 +209,7 @@ object MainForm: TMainForm
top = 136 top = 136
object MnuEditPickedColor: TMenuItem object MnuEditPickedColor: TMenuItem
Caption = 'Edit picked color...' Caption = 'Edit picked color...'
OnClick = MnuEditPickedClick OnClick = MnuEditPickedColorClick
end end
object MnuDeletePickedColor: TMenuItem object MnuDeletePickedColor: TMenuItem
Caption = 'Delete picked color' Caption = 'Delete picked color'

118
components/colorpalette/demo/unit1.pas
View File

@ -14,7 +14,7 @@ type
TMainForm = class(TForm) TMainForm = class(TForm)
Bevel1: TBevel; Bevel1: TBevel;
BtnDeleteCurrent: TButton; BtnDeleteColor: TButton;
BtnLoadDefaultPal1: TButton; BtnLoadDefaultPal1: TButton;
BtnLoadRndPalette: TButton; BtnLoadRndPalette: TButton;
BtnCreateRndPalette: TButton; BtnCreateRndPalette: TButton;
@ -25,38 +25,36 @@ type
ColorPalette: TColorPalette; ColorPalette: TColorPalette;
CbPickMode: TComboBox; CbPickMode: TComboBox;
LblPickMode: TLabel; LblPickMode: TLabel;
LblPaletteSize: TLabel;
EdColCount: TSpinEdit; EdColCount: TSpinEdit;
Label2: TLabel; Label2: TLabel;
LblInfo: TLabel; LblColorInfo: TLabel;
MnuEditPickedColor: TMenuItem; MnuEditPickedColor: TMenuItem;
MnuDeletePickedColor: TMenuItem; MnuDeletePickedColor: TMenuItem;
PalettePopupMenu: TPopupMenu; PalettePopupMenu: TPopupMenu;
Panel1: TPanel; Panel1: TPanel;
SaveDialog: TSaveDialog; SaveDialog: TSaveDialog;
curColor: TShape; ColorSample: TShape;
procedure BtnAddColorClick(Sender: TObject); procedure BtnAddColorClick(Sender: TObject);
procedure BtnCreateRndPaletteClick(Sender: TObject); procedure BtnCreateRndPaletteClick(Sender: TObject);
procedure BtnDeleteCurrentClick(Sender: TObject); procedure BtnDeleteColorClick(Sender: TObject);
procedure BtnEditColorClick(Sender: TObject);
procedure BtnLoadDefaultPalClick(Sender: TObject); procedure BtnLoadDefaultPalClick(Sender: TObject);
procedure BtnLoadRndPaletteClick(Sender: TObject); procedure BtnLoadRndPaletteClick(Sender: TObject);
procedure CbPickModeSelect(Sender: TObject); procedure CbPickModeSelect(Sender: TObject);
procedure ColorPaletteColorPick(Sender: TObject; AColor: TColor;
Shift: TShiftState);
procedure ColorPaletteDblClick(Sender: TObject); procedure ColorPaletteDblClick(Sender: TObject);
procedure ColorPaletteMouseDown(Sender: TObject; Button: TMouseButton; procedure ColorPaletteMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); Shift: TShiftState; X, Y: Integer);
procedure ColorPaletteSelectColor(Sender: TObject; AColor: TColor);
procedure EdColCountChange(Sender: TObject); procedure EdColCountChange(Sender: TObject);
procedure FormCreate(Sender: TObject); procedure FormCreate(Sender: TObject);
procedure MnuDeletePickedColorClick(Sender: TObject); procedure MnuDeletePickedColorClick(Sender: TObject);
procedure MnuEditPickedClick(Sender: TObject); procedure MnuEditPickedColorClick(Sender: TObject);
procedure BtnEditColorClick(Sender: TObject);
private private
{ private declarations } { private declarations }
curIndex: integer; curIndex: integer;
procedure EditCurColor; procedure EditCurColor;
procedure SetLabel(ATitle: string; AColor: TColor); procedure SetColorInfo(ATitle: string; AColor: TColor);
procedure UpdateColorCountInfo; procedure UpdateCaption;
procedure UpdatePalette; procedure UpdatePalette;
public public
{ public declarations } { public declarations }
@ -76,7 +74,7 @@ procedure TMainForm.BtnAddColorClick(Sender: TObject);
begin begin
if ColorDialog.Execute then if ColorDialog.Execute then
ColorPalette.AddColor(ColorDialog.Color); ColorPalette.AddColor(ColorDialog.Color);
LblPaletteSize.Caption := IntToStr(ColorPalette.ColorCount) + ' colors available'; UpdateCaption;
end; end;
procedure TMainForm.BtnCreateRndPaletteClick(Sender: TObject); procedure TMainForm.BtnCreateRndPaletteClick(Sender: TObject);
@ -103,7 +101,7 @@ begin
BtnLoadRndPalette.Enabled := true; BtnLoadRndPalette.Enabled := true;
end; end;
procedure TMainForm.BtnDeleteCurrentClick(Sender: TObject); procedure TMainForm.BtnDeleteColorClick(Sender: TObject);
begin begin
with ColorPalette do with ColorPalette do
begin begin
@ -111,12 +109,12 @@ begin
begin begin
DeleteColor(curIndex); DeleteColor(curIndex);
if curIndex = ColorCount then dec(curIndex); if curIndex = ColorCount then dec(curIndex);
curColor.Brush.Color := Colors[curIndex] ; ColorSample.Brush.Color := Colors[curIndex] ;
if Colors[curIndex] = clNone then if Colors[curIndex] = clNone then
curColor.Brush.Style := bsClear else ColorSample.Brush.Style := bsClear else
curColor.Brush.Style := bsSolid; ColorSample.Brush.Style := bsSolid;
LblPaletteSize.Caption := IntToStr(ColorCount) + ' colors available'; UpdateCaption;
SetLabel('Current', ColorPalette.Colors[curIndex]); SetColorInfo('Current', ColorPalette.Colors[curIndex]);
end; end;
end; end;
end; end;
@ -129,14 +127,14 @@ begin
exit; exit;
end; end;
ColorPalette.LoadPalette('..\default.pal'); ColorPalette.LoadPalette('..\default.pal');
LblPaletteSize.caption := IntToStr(ColorPalette.ColorCount) + ' colors available'; UpdateCaption;
EdColCount.Value := ColorPalette.ColumnCount; EdColCount.Value := ColorPalette.ColumnCount;
end; end;
procedure TMainForm.BtnLoadRndPaletteClick(Sender: TObject); procedure TMainForm.BtnLoadRndPaletteClick(Sender: TObject);
begin begin
ColorPalette.LoadPalette('random_palette.pal'); ColorPalette.LoadPalette('random_palette.pal');
LblPaletteSize.Caption := IntToStr(ColorPalette.ColorCount) + ' colors available'; UpdateCaption;
EdColCount.Value := ColorPalette.ColumnCount; EdColCount.Value := ColorPalette.ColumnCount;
end; end;
@ -153,16 +151,6 @@ begin
ColorPalette.PickMode := TPickMode(CbPickMode.ItemIndex); ColorPalette.PickMode := TPickMode(CbPickMode.ItemIndex);
end; end;
procedure TMainForm.ColorPaletteColorPick(Sender: TObject; AColor: TColor;
Shift: TShiftState);
begin
curColor.Brush.Color := ColorPalette.PickedColor;
if ColorPalette.Colors[curIndex] = clNone then
curColor.Brush.Style := bsClear else
curColor.Brush.Style := bsSolid;
SetLabel('PickedColor', ColorPalette.PickedColor);
end;
procedure TMainForm.ColorPaletteDblClick(Sender: TObject); procedure TMainForm.ColorPaletteDblClick(Sender: TObject);
begin begin
with ColorDialog do with ColorDialog do
@ -171,9 +159,9 @@ begin
if Execute then if Execute then
begin begin
ColorPalette.Colors[curIndex] := Color; ColorPalette.Colors[curIndex] := Color;
curColor.Brush.Color := Color; ColorSample.Brush.Color := Color;
curColor.Brush.Style := bsSolid; ColorSample.Brush.Style := bsSolid;
SetLabel('Current', Color); SetColorInfo('Current', Color);
with BtnEditColor do with BtnEditColor do
begin begin
Caption := 'Edit'; Caption := 'Edit';
@ -192,8 +180,17 @@ begin
Y := Y div ButtonHeight; Y := Y div ButtonHeight;
curIndex := X + Y * ColumnCount; curIndex := X + Y * ColumnCount;
end; end;
BtnDeleteCurrent.caption := 'Delete color #' + IntToStr(curIndex); BtnDeleteColor.caption := 'Delete color #' + IntToStr(curIndex);
Caption := 'CurIndex: ' + IntToStr(curIndex); UpdateCaption;
end;
procedure TMainForm.ColorPaletteSelectColor(Sender: TObject; AColor: TColor);
begin
ColorSample.Brush.Color := ColorPalette.SelectedColor;
if ColorPalette.Colors[curIndex] = clNone then
ColorSample.Brush.Style := bsClear else
ColorSample.Brush.Style := bsSolid;
SetColorInfo('SelectedColor', ColorPalette.SelectedColor);
end; end;
procedure TMainForm.EdColCountChange(Sender: TObject); procedure TMainForm.EdColCountChange(Sender: TObject);
@ -205,27 +202,26 @@ procedure TMainForm.EditCurColor;
begin begin
with ColorDialog do with ColorDialog do
begin begin
Color := curColor.Brush.color; Color := ColorSample.Brush.color;
if Execute then begin if Execute then begin
curColor.Brush.Color := Color; ColorSample.Brush.Color := Color;
curColor.Brush.Style := bsSolid; ColorSample.Brush.Style := bsSolid;
end; end;
end; end;
if curColor.Brush.Color <> ColorPalette.PickedColor then if ColorSample.Brush.Color <> ColorPalette.SelectedColor then
begin begin
BtnEditColor.caption := 'Update >'; BtnEditColor.caption := 'Update >';
BtnEditColor.hint := 'Update palette'; BtnEditColor.hint := 'Update palette';
SetLabel('New color', curColor.Brush.Color); SetColorInfo('New color', ColorSample.Brush.Color);
end; end;
end; end;
procedure TMainForm.FormCreate(Sender: TObject); procedure TMainForm.FormCreate(Sender: TObject);
begin begin
Caption := 'TColorPalette Demo';
curIndex := 0; curIndex := 0;
curColor.Brush.Color := ColorPalette.Colors[0]; ColorSample.Brush.Color := ColorPalette.Colors[0];
SetLabel('Current', ColorPalette.Colors[curIndex]); SetColorInfo('Current', ColorPalette.Colors[curIndex]);
UpdateColorCountInfo; UpdateCaption;
{ ColorPalette.PickShift must contain ssRight in order to be able to select { ColorPalette.PickShift must contain ssRight in order to be able to select
colors for the context menu. Use object inspector, or use this code: } colors for the context menu. Use object inspector, or use this code: }
@ -234,33 +230,41 @@ end;
procedure TMainForm.MnuDeletePickedColorClick(Sender: TObject); procedure TMainForm.MnuDeletePickedColorClick(Sender: TObject);
begin begin
BtnDeleteCurrentClick(self); BtnDeleteColorClick(self);
end; end;
procedure TMainForm.MnuEditPickedClick(Sender: TObject); procedure TMainForm.MnuEditPickedColorClick(Sender: TObject);
begin begin
BtnEditColorClick(self); BtnEditColorClick(self);
end; end;
procedure TMainForm.SetLabel(ATitle: string; AColor: TColor); procedure TMainForm.SetColorInfo(ATitle: string; AColor: TColor);
begin begin
LblInfo.caption := Format( if AColor = clNone then
'%s: %s'#13+ LblColorInfo.Caption := Format(
' red = %d'#13+ '%s: %s', [ATitle, ColorToString(AColor)]
' green = %d'#13+ )
' blue = %d', [ATitle, ColorToString(AColor), Red(AColor), Green(AColor), Blue(AColor)] else
); LblColorInfo.caption := Format(
'%s: %s'#13+
' red = %d'#13+
' green = %d'#13+
' blue = %d',
[ATitle, ColorToString(AColor), Red(AColor), Green(AColor), Blue(AColor)]
);
end; end;
procedure TMainForm.UpdateColorCountInfo; procedure TMainForm.UpdateCaption;
begin begin
LblPaletteSize.Caption := IntToStr(ColorPalette.ColorCount) + ' colors available'; Caption := Format('ColorPalette demo - CurIndex: %d (%d colors available)',
[curIndex, ColorPalette.ColorCount]
);
end; end;
procedure TMainForm.UpdatePalette; procedure TMainForm.UpdatePalette;
begin begin
ColorPalette.Colors[curIndex] := curColor.Brush.Color; ColorPalette.Colors[curIndex] := ColorSample.Brush.Color;
SetLabel('Current', ColorPalette.Colors[curIndex]); SetColorInfo('Current', ColorPalette.Colors[curIndex]);
with BtnEditColor do with BtnEditColor do
begin begin
Caption := 'Edit'; Caption := 'Edit';