TColorPalette: New methods AddColor and DeleteColor. Add demo project. (see discussion in http://forum.lazarus.freepascal.org/index.php/topic,29400.msg185669.htm)

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4274 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2015-08-19 14:23:23 +00:00 · 2015-08-19 14:23:23 +00:00 · 94124c6bb7
commit 94124c6bb7
parent 2a0d2f2e0c
6 changed files with 388 additions and 30 deletions
--- a/components/colorpalette/colorpalette.pas
+++ b/components/colorpalette/colorpalette.pas
@ -66,6 +66,7 @@ type
    FRows: Integer;
    FColors: TList;
    MX, MY: integer;
+    function GetColorCount: Integer;
    function GetColors(Index: Integer): TColor;
    procedure SetButtonHeight(const AValue: Integer);
    procedure SetButtonWidth(const AValue: Integer);
@ -77,6 +78,7 @@ type
    procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X, Y:Integer); override;
    procedure ColorPick(AColor: TColor; Shift: TShiftState); dynamic;
    procedure ColorMouseMove(AColor: TColor; Shift: TShiftState); dynamic;
+    procedure DoAddColor(AColor: TColor);
  public
    PickedColor: TColor;
    PickShift: TShiftState;
@ -84,11 +86,14 @@ type
    destructor Destroy; override;
    procedure Paint; override;
  public
+    procedure AddColor(AColor: TColor);
+    procedure DeleteColor(AIndex: Integer);
    procedure LoadPalette(const FileName: String);
  
    property ButtonWidth: Integer read FButtonWidth write SetButtonWidth;
    property ButtonHeight: Integer read FButtonHeight write SetButtonHeight;
    property Colors[Index: Integer]: TColor read GetColors write SetColors;
+    property ColorCount: Integer read GetColorCount;
    
    property OnColorPick: TColorMouseEvent read FOnColorPick write FOnColorPick;
    property OnColorMouseMove: TColorMouseEvent read FOnColorMouseMove write FOnColorMouseMove;
@ -149,9 +154,14 @@ begin
  UpdateSize;
 end;

+function TCustomColorPalette.GetColorCount: Integer;
+begin
+  Result := FColors.Count;
+end;
+
 function TCustomColorPalette.GetColors(Index: Integer): TColor;
 begin
-  Result := TColor(FColors.Items[Index]);
+  Result := TColor(PtrUInt(FColors.Items[Index]));
 end;

 procedure TCustomColorPalette.SetButtonWidth(const AValue: Integer);
@ -173,7 +183,7 @@ begin
  else
    FRows := Ceil(FColors.Count / FCols);

-  SetBounds(Left, Top, FCols * FButtonWidth + 1, FRows * FButtonHeight + 1)
+  SetBounds(Left, Top, FCols * FButtonWidth + 1, FRows * FButtonHeight + 1);
 end;

 procedure TCustomColorPalette.MouseDown(Button: TMouseButton;
@ -192,7 +202,7 @@ begin

  if X + Y * FCols < FColors.Count then
  begin
-    PickedColor := TColor(FColors.Items[X + Y * FCols]);
+    PickedColor := GetColors(X + Y * FCols);
    PickShift := Shift;
  end;
 end;
@ -218,7 +228,7 @@ begin
    Exit;
  if X + Y * FCols < FColors.Count then
  begin
-    C := TColor(FColors.Items[X + Y * FCols]);
+    C := GetColors(X + Y * FCols);
    if C <> clNone then ColorMouseMove(C, Shift);
  end;
 end;
@ -243,25 +253,25 @@ begin
  ControlStyle := ControlStyle + [csFixedWidth, csFixedHeight];
  
  FCols := 8;
-  
-  FColors.Add(Pointer(clBlack));
-  FColors.Add(Pointer(clGray));
-  FColors.Add(Pointer(clMaroon));
-  FColors.Add(Pointer(clOlive));
-  FColors.Add(Pointer(clGreen));
-  FColors.Add(Pointer(clTeal));
-  FColors.Add(Pointer(clNavy));
-  FColors.Add(Pointer(clPurple));
-  
-  FColors.Add(Pointer(clWhite));
-  FColors.Add(Pointer(clSilver));
-  FColors.Add(Pointer(clRed));
-  FColors.Add(Pointer(clYellow));
-  FColors.Add(Pointer(clLime));
-  FColors.Add(Pointer(clAqua));
-  FColors.Add(Pointer(clBlue));
-  FColors.Add(Pointer(clFuchsia));
-  
+
+  DoAddColor(clBlack);
+  DoAddColor(clGray);
+  DoAddColor(clMaroon);
+  DoAddColor(clOlive);
+  DoAddColor(clGreen);
+  DoAddColor(clTeal);
+  DoAddColor(clNavy);
+  DoAddColor(clPurple);
+
+  DoAddColor(clWhite);
+  DoAddColor(clSilver);
+  DoAddColor(clRed);
+  DoAddColor(clYellow);
+  DoAddColor(clLime);
+  DoAddColor(clAqua);
+  DoAddColor(clBlue);
+  DoAddColor(clFuchsia);
+
  UpdateSize;
 end;

@ -272,18 +282,39 @@ begin
  inherited;
 end;

+procedure TCustomColorPalette.AddColor(AColor: TColor);
+begin
+  DoAddColor(AColor);
+  UpdateSize;
+  Invalidate;
+end;
+
+procedure TCustomColorPalette.DoAddColor(AColor: TColor);
+begin
+  FColors.Add(Pointer(AColor));
+end;
+
+procedure TCustomColorPalette.DeleteColor(AIndex: Integer);
+begin
+  FColors.Delete(AIndex);
+  UpdateSize;
+  Invalidate;
+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;
-    if TColor(FColors.Items[I]) <> clNone then
+    c := GetColors(I);
+    if c <> clNone then
    begin
-      Canvas.Brush.Color := TColor(FColors.Items[I]);
+      Canvas.Brush.Color := c;
      Canvas.Rectangle(Bounds(X * FButtonWidth, Y * FButtonHeight, FButtonWidth,
        FButtonHeight));
    end;
@ -327,17 +358,17 @@ var
      NR := Round((R * I + 255 * (Steps + 1 - I)) / (Steps + 1));
      NG := Round((G * I + 255 * (Steps + 1 - I)) / (Steps + 1));
      NB := Round((B * I + 255 * (Steps + 1 - I)) / (Steps + 1));
-      FColors.Add(Pointer(RGBToColor(NR, NG, NB)));
+      DoAddColor(RGBToColor(NR, NG, NB));
    end;
    
-    FColors.Add(Pointer(Color));
+    DoAddColor(Color);
    
    for I := Steps downto 1 do
    begin
      NR := Round(R * I / (Steps + 1));
      NG := Round(G * I / (Steps + 1));
      NB := Round(B * I / (Steps + 1));
-      FColors.Add(Pointer(RGBToColor(NR, NG, NB)));
+      DoAddColor(RGBToColor(NR, NG, NB));
    end;
  end;
  
@ -359,7 +390,7 @@ begin
      if Line[1] = '#' then Continue;
      if Line[1] = '$' then
      begin
-        if Copy(Line, 2, 4) = 'NONE' then FColors.Add(Pointer(clNone));
+        if Copy(Line, 2, 4) = 'NONE' then DoAddColor(clNone);
        if Copy(Line, 2, 4) = 'COLS' then FCols := StrToIntDef(Copy(Line, 6, MaxInt), 8);
        if Copy(Line, 2, 7) = 'BLENDWB' then
        begin
@ -369,13 +400,14 @@ begin
        end;
      end
      else
-        if Pos(',', Line) > 0 then FColors.Add(Pointer(ParseColor(Line)));
+        if Pos(',', Line) > 0 then DoAddColor(ParseColor(Line));
    end;
  finally
    Close(F);
  end;
  
  UpdateSize;
+  Invalidate;
 end;

 initialization
--- a/components/colorpalette/demo/project1.ico
+++ b/components/colorpalette/demo/project1.ico
--- a/components/colorpalette/demo/project1.lpi
+++ b/components/colorpalette/demo/project1.lpi
@ -0,0 +1,84 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <PathDelim Value="\"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="project1"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <Icon Value="0"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <VersionInfo>
+      <StringTable ProductVersion=""/>
+    </VersionInfo>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="2">
+      <Item1>
+        <PackageName Value="LazColorPalette"/>
+      </Item1>
+      <Item2>
+        <PackageName Value="LCL"/>
+      </Item2>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="project1.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="unit1.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="Form1"/>
+        <ResourceBaseClass Value="Form"/>
+        <UnitName Value="Unit1"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="project1"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>
--- a/components/colorpalette/demo/project1.lpr
+++ b/components/colorpalette/demo/project1.lpr
@ -0,0 +1,21 @@
+program project1;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms, Unit1, lazcolorpalette
+  { you can add units after this };
+
+{$R *.res}
+
+begin
+  RequireDerivedFormResource:=True;
+  Application.Initialize;
+  Application.CreateForm(TForm1, Form1);
+  Application.Run;
+end.
+
--- a/components/colorpalette/demo/unit1.lfm
+++ b/components/colorpalette/demo/unit1.lfm
@ -0,0 +1,100 @@
+object Form1: TForm1
+  Left = 290
+  Height = 502
+  Top = 157
+  Width = 331
+  Caption = 'Form1'
+  ClientHeight = 502
+  ClientWidth = 331
+  LCLVersion = '1.5'
+  object ColorPalette1: TColorPalette
+    Left = 22
+    Height = 33
+    Top = 19
+    Width = 129
+    ButtonWidth = 16
+    ButtonHeight = 16
+    OnColorPick = ColorPalette1ColorPick
+  end
+  object BtnLoadRndPalette: TButton
+    Left = 176
+    Height = 25
+    Top = 344
+    Width = 139
+    Caption = 'Load random palette'
+    Enabled = False
+    OnClick = BtnLoadRndPaletteClick
+    TabOrder = 0
+  end
+  object BtnCreateRndPalette: TButton
+    Left = 176
+    Height = 25
+    Top = 312
+    Width = 139
+    Caption = 'Create random palette'
+    OnClick = BtnCreateRndPaletteClick
+    TabOrder = 1
+  end
+  object BtnAddColor: TButton
+    Left = 176
+    Height = 25
+    Top = 400
+    Width = 139
+    Caption = 'Add color'
+    OnClick = BtnAddColorClick
+    TabOrder = 2
+  end
+  object BtnLoadDefaultPal: TButton
+    Left = 176
+    Height = 25
+    Top = 264
+    Width = 139
+    Caption = 'Load Default.pal'
+    OnClick = BtnLoadDefaultPalClick
+    TabOrder = 3
+  end
+  object Label1: TLabel
+    Left = 176
+    Height = 15
+    Top = 464
+    Width = 34
+    Caption = 'Label1'
+    ParentColor = False
+  end
+  object BtnDeleteColor0: TButton
+    Left = 176
+    Height = 25
+    Top = 432
+    Width = 139
+    Caption = 'Delete color #0'
+    OnClick = BtnDeleteColor0Click
+    TabOrder = 4
+  end
+  object ColorDialog1: TColorDialog
+    Color = clBlack
+    CustomColors.Strings = (
+      'ColorA=000000'
+      'ColorB=000080'
+      'ColorC=008000'
+      'ColorD=008080'
+      'ColorE=800000'
+      'ColorF=800080'
+      'ColorG=808000'
+      'ColorH=808080'
+      'ColorI=C0C0C0'
+      'ColorJ=0000FF'
+      'ColorK=00FF00'
+      'ColorL=00FFFF'
+      'ColorM=FF0000'
+      'ColorN=FF00FF'
+      'ColorO=FFFF00'
+      'ColorP=FFFFFF'
+      'ColorQ=C0DCC0'
+      'ColorR=F0CAA6'
+      'ColorS=F0FBFF'
+      'ColorT=A4A0A0'
+    )
+    left = 163
+    top = 51
+  end
+end
--- a/components/colorpalette/demo/unit1.pas
+++ b/components/colorpalette/demo/unit1.pas
@ -0,0 +1,121 @@
+unit Unit1;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
+  ColorPalette;
+
+type
+
+  { TForm1 }
+
+  TForm1 = class(TForm)
+    BtnDeleteColor0: TButton;
+    BtnLoadRndPalette: TButton;
+    BtnCreateRndPalette: TButton;
+    BtnAddColor: TButton;
+    BtnLoadDefaultPal: TButton;
+    ColorDialog1: TColorDialog;
+    ColorPalette1: TColorPalette;
+    Label1: TLabel;
+    procedure BtnDeleteColor0Click(Sender: TObject);
+    procedure Button1Click(Sender: TObject);
+    procedure BtnLoadRndPaletteClick(Sender: TObject);
+    procedure BtnCreateRndPaletteClick(Sender: TObject);
+    procedure BtnAddColorClick(Sender: TObject);
+    procedure BtnLoadDefaultPalClick(Sender: TObject);
+    procedure ColorPalette1ColorPick(Sender: TObject; AColor: TColor;
+      Shift: TShiftState);
+  private
+    { private declarations }
+  public
+    { public declarations }
+  end;
+
+var
+  Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+{ TForm1 }
+
+procedure TForm1.ColorPalette1ColorPick(Sender: TObject; AColor: TColor;
+  Shift: TShiftState);
+begin
+  ShowMessage(Format(
+    'Color %s picked.'+#13+
+    '  red = %d'#13+
+    '  green = %d'#13+
+    '  blue = %d', [ColorToString(AColor), Red(AColor), Green(AColor), Blue(AColor)]));
+end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+begin
+  ColorPalette1.LoadPalette('palette1.txt');
+  Label1.caption := IntToStr(ColorPalette1.ColorCount) + ' colors available';
+end;
+
+procedure TForm1.BtnDeleteColor0Click(Sender: TObject);
+begin
+  if ColorPalette1.ColorCount > 0 then
+  begin
+    ColorPalette1.DeleteColor(0);
+    Label1.Caption := IntToStr(ColorPalette1.ColorCount) + ' colors available';
+  end;
+end;
+
+procedure TForm1.BtnLoadRndPaletteClick(Sender: TObject);
+begin
+  ColorPalette1.LoadPalette('random_palette.pal');
+  Label1.Caption := IntToStr(ColorPalette1.ColorCount) + ' colors available';
+end;
+
+procedure TForm1.BtnCreateRndPaletteClick(Sender: TObject);
+const
+  N = 64;
+var
+  i: Integer;
+  R,G,B: Byte;
+  L: TStringList;
+begin
+  L := TStringList.Create;
+  try
+    L.Add('$COLS 16');
+    for i:=1 to N do begin
+      R := Random(256);
+      G := Random(256);
+      B := Random(256);
+      L.Add(Format('%d, %d, %d', [R, G, B]));
+    end;
+    L.SaveToFile('random_palette.pal');
+  finally
+    L.Free;
+  end;
+  BtnLoadRndPalette.Enabled := true;
+end;
+
+procedure TForm1.BtnAddColorClick(Sender: TObject);
+begin
+  if ColorDialog1.Execute then
+    ColorPalette1.AddColor(ColorDialog1.Color);
+  Label1.caption := IntToStr(ColorPalette1.ColorCount) + ' colors available';
+end;
+
+procedure TForm1.BtnLoadDefaultPalClick(Sender: TObject);
+begin
+  if not FileExists('..\default.pal') then
+  begin
+    ShowMessage('File "default.pal" not found. Copy it from the TColorPalette folder to the current exe folder.');
+    exit;
+  end;
+  ColorPalette1.LoadPalette('..\default.pal');
+  Label1.caption := IntToStr(ColorPalette1.ColorCount) + ' colors available';
+end;
+
+end.
+