lazarus-ccr/components/mbColorLib/mbColorPalette.pas

unit mbColorPalette;

//{$MODE DELPHI}
{$MODE ObjFPC}{$H+}

interface

uses
  LCLIntf, LCLType, LMessages, SysUtils, Classes, Controls, Graphics,
  Forms, Dialogs, Themes,
  HTMLColors, PalUtils, mbBasicPicker;

type
  TMouseLoc = (mlNone, mlOver, mlDown);
  TTransparentStyle = (tsPhotoshop, tsPhotoshop2, tsCorel, tsMicroangelo, tsNone);
  TCellStyle = (csDefault, csCorel);
  TColorCellState = (ccsNone, ccsOver, ccsDown, ccsChecked, ccsCheckedHover);
  TMoveDirection = (mdLeft, mdRight, mdUp, mdDown);
  TPaintCellEvent = procedure (ACanvas: TCanvas; ACellRect: TRect; AColor: TColor; Index: integer; AState: TColorCellState; var AStyle: TTransparentStyle; var PaintingHandled: boolean) of object;
  TCellClickEvent = procedure (Button: TMouseButton; Shift: TShiftState; Index: integer; AColor: TColor; var DontCheck: boolean) of object;
  TGetHintTextEvent = procedure (AColor: TColor; Index: integer; var HintStr: string; var Handled: boolean) of object;
  TArrowKeyEvent = procedure (Key: Word; Shift: TShiftState) of object;

  TmbColorPalette = class(TmbBasicPicker)
  private
    FMouseLoc: TMouseLoc;
    FMouseOver, FMouseDown, FAutoHeight: boolean;
    FColCount, FRowCount, FTop, FLeft, FIndex, FCheckedIndex, FCellSize, FTotalCells: integer;
    FState: TColorCellState;
    FColors, FNames: TStrings;
    FPalette: TFileName;
    FHintFormat: string;
    FOnChange, FOnColorsChange: TNotifyEvent;
    FMinColors, FMaxColors: integer;
    FSort: TSortMode;
    FOrder: TSortOrder;
    FOld: TColor;
    FOnPaintCell: TPaintCellEvent;
    FTStyle: TTransparentStyle;
    FOnCellClick: TCellClickEvent;
    FOldIndex: integer;
    FOnGetHintText: TGetHintTextEvent;
    FCellStyle: TCellStyle;
    FOnArrowKey: TArrowKeyEvent;
    procedure CalcAutoHeight;
    function GetMoveCellIndex(move: TMoveDirection): integer;
    function GetSelColor: TColor;
    function GetTotalRowCount: integer;
    procedure LoadPalette(FileName: TFileName);
    procedure SetAutoHeight(auto: boolean);
    procedure SetCellSize(s: integer);
    procedure SetCellStyle(s: TCellStyle);
    procedure SetMaxColors(m: integer);
    procedure SetMinColors(m: integer);
    procedure SetNames(n: TStrings);
    procedure SetSelColor(k: TColor);
    procedure SetSortMode(s: TSortMode);
    procedure SetSortOrder(s: TSortOrder);
    procedure SetStrings(s: TStrings);
    procedure SetTStyle(s: TTransparentStyle);
    procedure SortColors;
  protected
    procedure ColorsChange(Sender: TObject);
    procedure DrawCell(ACanvas: TCanvas; AColor: string);
    procedure DrawCellBack(ACanvas: TCanvas; R: TRect; AIndex: integer);
    function GetColorUnderCursor: TColor; override;
    function GetHintStr(X, Y: Integer): String; override;
    function GetIndexUnderCursor: integer;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseEnter; override;
    procedure MouseLeave; override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
    procedure PaintTransparentGlyph(ACanvas: TCanvas; R: TRect);
    procedure Resize; override;
    procedure SelectCell(i: integer);
    procedure CMGotFocus(var Message: TLMessage); message CM_ENTER;
    procedure CMHintShow(var Message: TLMessage); message CM_HINTSHOW;
    procedure CMLostFocus(var Message: TLMessage); message CM_EXIT;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure GeneratePalette(BaseColor: TColor);
    procedure GenerateGradientPalette(Colors: array of TColor);
    function GetSelectedCellRect: TRect;
    procedure SaveColorsAsPalette(FileName: TFileName);
    property ColorUnderCursor;
    property RowCount: integer read GetTotalRowCount;
    property ColCount: integer read FColCount;
    property IndexUnderCursor: integer read GetIndexUnderCursor;
    property VisibleRowCount: integer read FRowCount;

  published
    property Align;
    property Anchors;
    property Enabled;
    property SortMode: TSortMode read FSort write SetSortMode default smNone;
    property SortOrder: TSortOrder read FOrder write SetSortOrder default soAscending;
    property MinColors: integer read FMinColors write SetMinColors default 0;
    property MaxColors: integer read FMaxColors write SetMaxColors default 0;
    property SelectedCell: integer read FCheckedIndex write SelectCell default -1;
    property SelectedColor: TColor read GetSelColor write SetSelColor default clNone;
    property Colors: TStrings read FColors write SetStrings;
    property Palette: TFileName read FPalette write LoadPalette;
    property HintFormat: string read FHintFormat write FHintFormat;
    property AutoHeight: boolean read FAutoHeight write SetAutoHeight default false;
    property CellSize: integer read FCellSize write SetCellSize default 18;
    property TransparentStyle: TTransparentStyle read FTStyle write SetTStyle default tsNone;
    property CellStyle: TCellStyle read FCellStyle write SetCellStyle default csDefault;
    property ColorNames: TStrings read FNames write SetNames;
    property TabStop default true;
    property TabOrder;
    property ShowHint default false;
    property Constraints;
    property ParentShowHint default true;
    property PopupMenu;
    property Visible;
    property DragCursor;
    property DragKind;
    property DragMode;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnStartDock;
    property OnStartDrag;
    property OnSelColorChange: TNotifyEvent read FOnChange write FOnChange;
    property OnColorsChange: TNotifyEvent read FOnColorsChange write FOnColorsChange;
    property OnPaintCell: TPaintCellEvent read FOnPaintCell write FOnPaintCell;
    property OnCellClick: TCellClickEvent read FOnCellClick write FOnCellClick;
    property OnGetHintText: TGetHintTextEvent read FOnGetHintText write FOnGetHintText;
    property OnArrowKey: TArrowKeyEvent read FOnArrowKey write FOnArrowKey;
    property OnContextPopup;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
    property OnKeyDown;
    property OnKeyUp;
    property OnKeyPress;
    property OnResize;
    property OnClick;
  end;

implementation

uses
  mbUtils;

{ TmbColorPalette }

constructor TmbColorPalette.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
//  ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];

  TabStop := true;
  ParentShowHint := true;
  ShowHint := false;
  SetInitialBounds(0, 0, 180, 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;
begin
  //FBufferBmp.Free;      -- is destroy by TmbBasicPicker
  FNames.Free;
  FColors.Free;
  inherited Destroy;
end;

procedure TmbColorPalette.CalcAutoHeight;
begin
  if Parent = nil then
    exit;
  FColCount := Width div FCellSize;
  FRowCount := Height div FCellSize;
end;

procedure TmbColorPalette.CMGotFocus(var Message: TLMessage);
begin
  inherited;
  Invalidate;
end;

procedure TmbColorPalette.CMHintShow(var Message: TLMessage);
var
  clr: TColor;
  Handled: boolean;
  cp: TPoint;
begin
  if (Colors.Count > 0) and (FIndex > -1) then
  with TCMHintShow(Message) do
  begin
    if not ShowHint then
      Message.Result := 1
    else
    begin
      with HintInfo^ do
      begin
        // show that we want a hint
        Result := 0;
        ReshowTimeout := 0; //1;
        cp := CursorPos;
        HintInfo^.CursorRect := Rect(cp.X, cp.Y, cp.X+1, cp.Y+1);
        HideTimeout := Application.HintHidePause; // was: 5000
        clr := GetColorUnderCursor;
        //fire event
        Handled := false;
        if Assigned(FOnGetHintText) then
          FOnGetHintText(clr, GetIndexUnderCursor, HintStr, Handled);
        //do default
        if not Handled then
          HintStr := GetHintStr(CursorPos.X, CursorPos.Y);
      end;
    end;
  end;
end;

procedure TmbColorPalette.CMLostFocus(var Message: TLMessage);
begin
  inherited;
  if FMouseOver then
    FMouseLoc := mlOver
  else
    FMouseLoc := mlNone;
  Invalidate;
end;

procedure TmbColorPalette.ColorsChange(Sender: TObject);
begin
  if Assigned(FOnColorsChange) then
    FOnColorsChange(Self);
  FTotalCells := FColors.Count - 1;
  CalcAutoHeight;
  Invalidate;
end;

procedure TmbColorPalette.DrawCell(ACanvas: TCanvas; AColor: string);
var
  R: Trect;
  FCurrentIndex: integer;
  c: TColor;
  Handled: boolean;
begin
  // set props
  if (FLeft + 1) * FCellSize > Width then
  begin
    Inc(FTop);
    FLeft := 0;
  end;

  FCurrentIndex := FTop * FColCount + FLeft;
  R := Rect(FLeft * FCellSize, FTop * FCellSize, (FLeft + 1) * FCellSize, (FTop + 1) * FCellSize);

  //start drawing

  //get current state
  if FCurrentIndex = FCheckedIndex then
  begin
    if FCheckedIndex = FIndex then
    begin
      if FMouseDown then
        FState := ccsDown
      else
        FState := ccsCheckedHover;
    end
    else
      FState := ccsChecked;
  end
  else
  if FIndex = FCurrentIndex then
    case FMouseLoc of
      mlNone: FState := ccsNone;
      mlOver: FState := ccsOver;
    end
  else
    FState := ccsNone;

  //paint
  DrawCellBack(ACanvas, R, FCurrentIndex);

  // fire the event
  Handled := false;
  c := mbStringToColor(AColor);
  if Assigned(FOnPaintCell) then
    case FCellStyle of
      csDefault:
        FOnPaintCell(ACanvas, R, c, FCurrentIndex, FState, FTStyle, Handled);
      csCorel:
        if FColCount = 1 then
          FOnPaintCell(ACanvas, R, c, FCurrentIndex, FState, FTStyle, Handled)
        else
          FOnPaintCell(ACanvas, Rect(R.Left, R.Top, R.Right + 1, R.Bottom), c,
            FCurrentIndex, FState, FTStyle, Handled);
    end;

  if not Handled then
  begin
    // if standard colors draw the rect
    if not SameText(AColor, 'clCustom') and not SameText(AColor, 'clTransparent') then
      case FCellStyle of
        csDefault:
          begin
            InflateRect(R, -3, -3);
            if Enabled then
            begin
              ACanvas.Brush.Color := c;
              ACanvas.Pen.Color := clBtnShadow;
            end
            else
            begin
              ACanvas.Brush.Color := clGray;
              ACanvas.Pen.Color := clGray;
            end;
            ACanvas.Rectangle(R);
            Exit;
          end;

        csCorel:
          begin
            if (FState <> ccsNone) then
              InflateRect(R, -2, -2)
            else
            begin
              Inc(R.Left);
              Dec(R.Bottom);
              if R.Top <= 1 then
                Inc(R.Top);
              if R.Right = Width then
                Dec(R.Right);
            end;
            if Enabled then
              ACanvas.Brush.Color := c
            else
              ACanvas.Brush.Color := clGray;
            ACanvas.FillRect(R);
            Exit;
          end;
      end;

    //if transparent draw the glyph
    if SameText(AColor, 'clTransparent') then
      PaintTransparentGlyph(ACanvas, R);
  end;
end;

procedure TmbColorPalette.DrawCellBack(ACanvas: TCanvas; R: TRect; AIndex: integer);
begin
  case FCellStyle of
    csDefault:
      begin
        if ThemeServices.ThemesEnabled then
        begin
          with ThemeServices do
            if Enabled then
              case FState of
                ccsNone: ; //PaintParentBack(ACanvas, R);
//              ccsNone: ACanvas.CopyRect(R, PBack.Canvas, R);
                ccsOver: DrawElement(ACanvas.Handle, GetElementDetails(ttbButtonHot), R);
                ccsDown: DrawElement(ACanvas.Handle, GetElementDetails(ttbButtonPressed), R);
                ccsChecked: DrawElement(ACanvas.Handle, GetElementDetails(ttbButtonChecked), R);
                ccsCheckedHover: DrawElement(ACanvas.Handle, GetElementDetails(ttbButtonCheckedHot), R);
              end
            else
              DrawElement(ACanvas.Handle, GetElementDetails(ttbButtonDisabled), R);
        end
        else
        if Enabled then
          case FState of
            ccsNone: ACanvas.FillRect(R);
            ccsOver: DrawEdge(ACanvas.Handle, R, BDR_RAISEDINNER, BF_RECT);
            ccsDown, ccsChecked, ccsCheckedHover: DrawEdge(ACanvas.Handle, R, BDR_SUNKENOUTER, BF_RECT);
          end
        else
          DrawFrameControl(ACanvas.Handle, R, DFC_BUTTON, 0 or DFCS_BUTTONPUSH or DFCS_FLAT or DFCS_INACTIVE);
      end;

    csCorel:
      begin
        if Enabled then
        begin
          if ThemeServices.ThemesEnabled then
            case FState of
              ccsNone:
                begin
                  ACanvas.Brush.Color := clWhite;
                  ACanvas.Pen.Color := clBlack;
                  //left
                  ACanvas.MoveTo(R.Left, R.Top);
                  ACanvas.LineTo(R.Left, R.Bottom-1);
                  //bottom
                  ACanvas.MoveTo(R.Left, R.Bottom-1);
                  ACanvas.LineTo(R.Right, R.Bottom-1);
                  //top
                  if R.Top = 0 then
                  begin
                    ACanvas.MoveTo(R.Left, R.Top);
                    ACanvas.LineTo(R.Right, R.Top);
                  end;
                  //right
                  if (R.Right = Width) then
                  begin
                    ACanvas.MoveTo(R.Right-1, R.Top);
                    ACanvas.LineTo(R.Right-1, R.Bottom-1);
                  end
                  else
                  if (AIndex = FTotalCells) then
                  begin
                    ACanvas.MoveTo(R.Right, R.Top);
                    ACanvas.LineTo(R.Right, R.Bottom);
                  end;
                end;

              ccsOver:
                ThemeServices.DrawElement(ACanvas.Handle, ThemeServices.GetElementDetails(ttbButtonHot), R);

              ccsDown:
                ThemeServices.DrawElement(ACanvas.Handle, ThemeServices.GetElementDetails(ttbButtonPressed), R);

              ccsChecked:
                ThemeServices.DrawElement(ACanvas.Handle, ThemeServices.GetElementDetails(ttbButtonChecked), R);

              ccsCheckedHover:
                ThemeServices.DrawElement(ACanvas.Handle, ThemeServices.GetElementDetails(ttbButtonCheckedHot), R);
            end  // case
          else  // if Themeservices.ThemesEnables...
            case FState of
              ccsNone:
                begin
                  ACanvas.Brush.Color := clWhite;
                  ACanvas.Pen.Color := clBlack;
                  ACanvas.Brush.Color := clWhite;
                  ACanvas.Pen.Color := clBlack;
                  //left
                  ACanvas.MoveTo(R.Left, R.Top);
                  ACanvas.LineTo(R.Left, R.Bottom-1);
                  //bottom
                  ACanvas.MoveTo(R.Left, R.Bottom-1);
                  ACanvas.LineTo(R.Right, R.Bottom-1);
                  //top
                  if R.Top = 0 then
                  begin
                    ACanvas.MoveTo(R.Left, R.Top);
                    ACanvas.LineTo(R.Right, R.Top);
                  end;
                  //right
                  if (R.Right = Width) then
                  begin
                    ACanvas.MoveTo(R.Right-1, R.Top);
                    ACanvas.LineTo(R.Right-1, R.Bottom-1);
                  end
                  else
                  if (AIndex = FTotalCells) then
                  begin
                    ACanvas.MoveTo(R.Right, R.Top);
                    ACanvas.LineTo(R.Right, R.Bottom);
                  end;
                end;

              ccsOver:
                begin
                  OffsetRect(R, 1,1);
                  DrawEdge(ACanvas.Handle, R, BDR_RAISED, BF_RECT);
                end;

              ccsDown, ccsChecked, ccsCheckedHover:
                DrawEdge(ACanvas.Handle, R, BDR_SUNKENOUTER, BF_RECT);
            end;  // case
        end  // if Enabled ...
        else
          if ThemeServices.ThemesEnabled then
            ThemeServices.DrawElement(ACanvas.Handle, ThemeServices.GetElementDetails(ttbButtonDisabled), R)
          else
          begin
            if Color = clDefault then
              ACanvas.Brush.Color := GetDefaultColor(dctBrush)
            else
              ACanvas.Brush.Color := Color;
            ACanvas.FillRect(R);
          end;
      end;  // bsCorel

  end;  // case FCellStyle
end;

procedure TmbColorPalette.GenerateGradientPalette(Colors: array of TColor);
begin
  FColors.Text := MakeGradientPalette(Colors);
  CalcAutoHeight;
  SortColors;
  Invalidate;
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TmbColorPalette.GeneratePalette(BaseColor: TColor);
begin
  FColors.Text := MakePalette(BaseColor, FOrder);
  CalcAutoHeight;
  SortColors;
  Invalidate;
  if Assigned(FOnChange) then FOnChange(Self);
end;

function TmbColorPalette.GetColorUnderCursor: TColor;
begin
  Result := clNone;
  if FIndex > -1 then
    if FIndex < FColors.Count then
      Result := mbStringToColor(FColors.Strings[FIndex]);
end;

function TmbColorPalette.GetHintStr(X, Y: Integer): String;
var
  idx: Integer;
begin
  idx := GetIndexUnderCursor;
  if FIndex < FNames.Count then
    Result := FNames.Strings[FIndex]
  else
  if SameText(FColors.Strings[idx], 'clCustom') or
     SameText(FColors.Strings[idx], 'clTransparent')
  then
    Result := StringReplace(FColors.Strings[idx], 'cl', '', [rfReplaceAll])
  else
    Result := FormatHint(FHintFormat, ColorUnderCursor);
end;

function TmbColorPalette.GetIndexUnderCursor: integer;
begin
  Result := -1;
  if FIndex > -1 then
    if FIndex < FColors.Count then
      Result := FIndex;
end;

function TmbColorPalette.GetMoveCellIndex(move: TMoveDirection): integer;
var
  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;
end;

function TmbColorPalette.GetSelColor: TColor;
begin
  if (FCheckedIndex > -1) and (FCheckedIndex <= FTotalCells) then
    Result := mbStringToColor(FColors.Strings[FCheckedIndex])
  else
    Result := FOld;
end;

function TmbColorPalette.GetSelectedCellRect: TRect;
var
  row, lBottom, lLeft: integer;
begin
  if FCheckedIndex > -1 then
  begin
    if FCheckedIndex mod FColCount = 0 then
    begin
      row := FCheckedIndex div FColCount;
      lLeft := Width - FCellSize;
    end
    else
    begin
      row := FCheckedIndex div FColCount + 1;
      lLeft := (FCheckedIndex mod FColCount - 1) * FCellSize;
    end;
    lBottom := row * FCellSize;
    Result := Rect(lLeft, lBottom - FCellSize, lLeft + FCellSize, lBottom);
  end
  else
    Result := Rect(0, 0, 0, 0);
end;

function TmbColorPalette.GetTotalRowCount: integer;
begin
  if FColCount <> 0 then
    Result := FTotalCells div FColCount
  else
    Result := 0;
end;

procedure TmbColorPalette.KeyDown(var Key: Word; Shift: TShiftState);
begin
  case Key of
    VK_LEFT:
      begin
        FCheckedIndex := GetMoveCellIndex(mdLeft);
        if Assigned(FOnArrowKey) then FOnArrowKey(Key, Shift);
      end;
    VK_RIGHT:
      begin
        FCheckedIndex := GetMoveCellIndex(mdRight);
        if Assigned(FOnArrowKey) then FOnArrowKey(Key, Shift);
      end;
    VK_UP:
      begin
        FCheckedIndex := GetMoveCellIndex(mdUp);
        if Assigned(FOnArrowKey) then FOnArrowKey(Key, Shift);
      end;
    VK_DOWN:
      begin
        FCheckedIndex := GetMoveCellIndex(mdDown);
        if Assigned(FOnArrowKey) then FOnArrowKey(Key, Shift);
      end;
    VK_SPACE, VK_RETURN:
      ;  // fire OnChange event below

    else
      Key := 0;
      inherited;
      exit;
  end;

  Invalidate;
  if Assigned(FOnChange) then FOnChange(Self);

  inherited;
end;

procedure TmbColorPalette.LoadPalette(FileName: TFileName);
var
  supported: boolean;
  a: AcoColors;
  i: integer;
begin
  supported := false;
  if SameText(ExtractFileExt(FileName), '.pal') then
  begin
    supported := true;
    FNames.Clear;
    FColors.Text := ReadJASCPal(FileName);
  end
  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]));
    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
    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.MouseEnter;
begin
  FMouseOver := true;
  FMouseLoc := mlOver;
  Invalidate;
  inherited;
end;

procedure TmbColorPalette.MouseLeave;
begin
  FMouseOver := false;
  FMouseLoc := mlNone;
  FIndex := -1;
  Invalidate;
  inherited;
end;

procedure TmbColorPalette.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  newIndex: Integer;
begin
  newIndex := (y div FCellSize) * FColCount + (x div FCellSize);
  if FIndex <> newIndex then
  begin
    FIndex := newIndex;
    if FIndex > FTotalCells then FIndex := -1;
    Invalidate;
  end;
  inherited;
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;
end;

procedure TmbColorPalette.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  DontCheck: boolean;
  AColor: TColor;
begin
  FMouseDown := false;
  if FMouseOver then
    FMouseLoc := mlOver
  else
    FMouseLoc := mlNone;
  DontCheck := false;
  if (FCheckedIndex > -1) and (FCheckedIndex < FColors.Count) then
    AColor := mbStringToColor(FColors.Strings[FCheckedIndex])
  else
    AColor := clNone;
  if (Button = mbLeft) and PtInRect(ClientRect, Point(x, y)) then
    if Assigned(FOnCellClick) then
      FOnCellClick(Button, Shift, FCheckedIndex, AColor, DontCheck);
  if DontCheck then FCheckedIndex := FOldIndex;
  Invalidate;
  inherited;
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TmbColorPalette.Paint;
var
  i: integer;
  bmp: TBitmap;
begin
  //make bmp
  if FBufferBmp = nil then
    FBufferBmp := TBitmap.Create;
  FBufferBmp.Width := Width;
  FBufferBmp.Height := Height;
  PaintParentBack(FBufferBmp);
  FBufferBmp.Transparent := false;  // a transparent bitmap does not show the selection ?!

  //reset counters
  FTotalCells := FColors.Count - 1;
  FTop := 0;
  FLeft := 0;

  //draw the cells
  for i := 0 to FColors.Count - 1 do
  begin
    if FColors.Strings[i] <> '' then
      DrawCell(FBufferBmp.Canvas, FColors.Strings[i]);
    Inc(FLeft);
  end;

  //draw the bmp
  if Color = clDefault then
  begin
    // Use temporary bitmap to draw the buffer bitmap transparently
    bmp := TBitmap.Create;
    try
      bmp.SetSize(Width, Height);
      if Color = clDefault then begin
        bmp.Transparent := true;
        bmp.TransparentColor := clForm;
      end;
      bmp.Canvas.Draw(0, 0, FBufferBmp);
      Canvas.Draw(0, 0, bmp);
    finally
      bmp.Free;
    end;
  end
  else
    Canvas.Draw(0, 0, FBufferBmp);

  //csDesiging border
  if csDesigning in ComponentState then
  begin
    Canvas.Brush.Style := bsClear;
    Canvas.Pen.Style := psDot;
    Canvas.Pen.Color := clBtnShadow;
    Canvas.Rectangle(ClientRect);
    Canvas.Brush.Style := bsSolid;
    Canvas.Pen.Style := psSolid;
  end;
end;

procedure TmbColorPalette.PaintTransparentGlyph(ACanvas: TCanvas; R: TRect);
begin
  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);
  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));
        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;
  Invalidate;
end;

procedure TmbColorPalette.SelectCell(i: integer);
begin
  if i < FColors.Count - 1 then
    FCheckedIndex := i
  else
    FCheckedIndex := -1;
  Invalidate;
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TmbColorPalette.SetTStyle(s: TTransparentStyle);
begin
  if FTStyle <> s then
  begin
    FTStyle := s;
    Invalidate;
  end;
end;

procedure TmbColorPalette.SetCellStyle(s: TCellStyle);
begin
  if FCellStyle <> s then
  begin
    FCellStyle := s;
    Invalidate;
  end;
end;

procedure TmbColorPalette.SetSelColor(k: TColor);
var
  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);
end;

procedure TmbColorPalette.SetStrings(s: TStrings);
var
  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;
end;

procedure TmbColorPalette.SetNames(n: TStrings);
var
  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);
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');
end;

procedure TmbColorPalette.SetAutoHeight(auto: boolean);
begin
  FAutoHeight := auto;
  CalcAutoHeight;
  Invalidate;
end;

procedure TmbColorPalette.SetCellSize(s: integer);
begin
  FCellSize := s;
  CalcAutoHeight;
  Invalidate;
end;

procedure TmbColorPalette.SetMaxColors(m: integer);
var
  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;
end;

procedure TmbColorPalette.SetMinColors(m: integer);
var
  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;
end;

procedure TmbColorPalette.SetSortMode(s: TSortMode);
begin
  if FSort <> s then
  begin
    FSort := s;
    SortColors;
    Invalidate;
  end;
end;

procedure TmbColorPalette.SetSortOrder(s: TSortOrder);
begin
  if FOrder <> s then
  begin
    FOrder := s;
    SortColors;
    Invalidate;
  end;
end;

procedure TmbColorPalette.SortColors;
var
  old: TColor;
begin
  if FSort <> smNone then
  begin
    if FColors.Count = 0 then Exit;
    old := GetSelColor;
    SortPalColors(FColors, FSort, FOrder);
    SetSelColor(old);
    Invalidate;
  end;
end;

end.