TColorPickerButton组件

http://files.cnblogs.com/xe2011/VCL_TColorPB12.rar

在DELPHI7中可以正常使用在DELPHI XE5中下面会有些问题

安装方法

打开 DELPHI
新建 - Package
选中Package.BPL，右键 ADD找到本并添加.PAS源文件
选中Package.BPL，右键 Compile
选中Package.BPL，右键 Instal

卸载这个组件的时候，找到这个安装包
选中Package.BPL，右键 UnInstal

说明

TColorPickerButton is a special speed button which can be used to let the user select

a specific color. The control does not use the standard Windows color dialog, but uses

a popup window very similar to the one in Office97, which has been improved a lot

to support the task of picking one color out of millions. Included is also the

ability to pick one of the predefined system colors (e.g. clBtnFace).

TColorPickerButton works only with D4 and BCB!

(BCB check by Josue Andrade Gomes [email protected])

product (free or commercial) under the condition that I'm given proper credit

(titel, name and eMail address in the documentation or the About box of the

product this control is used in).

Portions copyright by Borland. The implementation of the speed button has been

taken from Delphi sources.

The use of the new control is quite simple. Just install the ColorPickerButton.pas into your component palette. By default the target

component page is "Tools". That's all.

Here's a list of methods and properties which differ from TSpeedButton:

public

property DroppedDown: Boolean;

Read to get the drop down state of the color popup or write to set it.

published

property CustomText: String;

Determines the text of the second special button on the popup. If empty this button is neither shown nor is it then possible to select a color

from the color comb. If set then the button is shown and the user can click on it to show the color comb (accelerator allowed).

property DefaultText: String;

Determines the text of the first special button on the popup. If empty this button is not shown, else it is used to select the default color (clDefault)

(accelerator allowed).

property DropDownArrowColor: TColor;

Determines the color of the small triangle on the right of the button.

property DropDownWidth: Integer;

Determines the size of the area on the right which can be clicked to drop down the picker window.

property IndicatorBorder: TIndicatorBorder;

Set one of four border styles the color preview rectangle is drawn in (none, flat, sunken, raised)

property PopupSpacing: Integer;

Denotes the spacing within the color popup window (>= 0, this is the place left on the left and right side of the popup)

property SelectionColor: TColor;

Contains the currently selected color .

property ShowSystemColors: Boolean;

Determines whether predefined system colors like clBtnFace or clWindow should be shown.

property OnChange: TNotifyEvent;

Triggered when the selection color of the button changes.

property OnDefaultSelect;

Triggered when the user selected the default color (either with the mouse or by accelerator key).

property OnDropChanged: TNotifyEvent;

Triggered after the visibility state of the picker window has changed. DroppedDown is already set according to the state.

property OnDropChanging: TDropChangingEvent;

Triggered just before the visibility state of the picker window changes. DroppedDown is still in the old state and you can reject dropping down

or hiding the window by setting Allowed to False.

property OnHint: THintEvent;

For each color in the picker window a hint window appears when the mouse is over the belonging button or comb. If the mouse is not over any button

or hovers over the default text or the custom text, respectively, then a hint is requested from the application by this event. There's a Cell paramter to

tell what cell is meant. It can be NoCell, CustomCell or DefaultCell. BTW: By setting ShowHint to False all hints are disabled, even

those of the color and comb buttons. If you don't supply an OnHint event then the hint string of the color picker button is shown.

As you can see there's nothing special with the control. Just use it and show the world what really amazing applications can be produced with Delphi.

Have fun and

TColorPickerButton组件

unit ColorPickerButton;



// This unit contains a special speed button which can be used to let the user select

// a specific color. The control does not use the standard Windows color dialog, but

// a popup window very similar to the one in Office97, which has been improved a lot

// to support the task of picking one color out of millions. Included is also the

// ability to pick one of the predefined system colors (e.g. clBtnFace).

// Note: The layout is somewhat optimized to look pretty with the predefined box size

// of 18 pixels (the size of one little button in the predefined color area) and

// the number of color comb levels. It is easily possible to change this, but

// if you want to do so then you have probably to make some additional

// changes to the overall layout.

//

// TColorPickerButton works only with D4 and BCB!

// (BCB check by Josue Andrade Gomes [email protected])

//

// (c) 1999, written by Dipl. Ing. Mike Lischke ([email protected])

// All rights reserved. This unit is freeware and may be used in any software

// product (free or commercial) under the condition that I'm given proper credit

// (Titel, Name and eMail address in the documentation or the About box of the

// product this source code is used in).

// Portions copyright by Borland. The implementation of the speed button has been

// taken from Delphi sources.

//

// 22-JUN-99 ml: a few improvements for the overall layout (mainly indicator rectangle

// does now draw in four different styles and considers the layout

// property of the button (changed to version 1.2, BCB compliance is

// now proved by Josue Andrade Gomes)

// 18-JUN-99 ml: message redirection bug removed (caused an AV under some circumstances)

// and accelerator key handling bug removed (wrong flag for EndSelection)

// (changed to version 1.1)

// 16-JUN-99 ml: initial release



interface



uses Windows, Messages, SysUtils, Classes, Controls, Forms, Graphics, StdCtrls,

  ExtCtrls, CommCtrl;



const // constants used in OnHint and internally to indicate a specific cell

  DefaultCell = -3;

  CustomCell = -2;

  NoCell = -1;



type

  TButtonLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);

  TButtonState = (bsUp, bsDisabled, bsDown, bsExclusive);

  TButtonStyle = (bsAutoDetect, bsWin31, bsNew);

  TNumGlyphs = 1 .. 4;



  TIndicatorBorder = (ibNone, ibFlat, ibSunken, ibRaised);



  THintEvent = procedure(Sender: TObject; Cell: Integer; var Hint: String)

    of object;

  TDropChangingEvent = procedure(Sender: TObject; var Allowed: Boolean)

    of object;



  TColorPickerButton = class(TGraphicControl)

  private

    FGroupIndex: Integer;

    FGlyph: Pointer;

    FDown: Boolean;

    FDragging: Boolean;

    FAllowAllUp: Boolean;

    FLayout: TButtonLayout;

    FSpacing: Integer;

    FMargin: Integer;

    FFlat: Boolean;

    FMouseInControl: Boolean;

    FTransparent: Boolean;

    FIndicatorBorder: TIndicatorBorder;



    FDropDownArrowColor: TColor;

    FDropDownWidth: Integer;

    FDropDownZone: Boolean;

    FDroppedDown: Boolean;

    FSelectionColor: TColor;

    FState: TButtonState;

    FColorPopup: TWinControl;

    FPopupWnd: HWND;



    FOnChange, FOnDefaultSelect, FOnDropChanged: TNotifyEvent;

    FOnDropChanging: TDropChangingEvent;

    FOnHint: THintEvent;

    procedure GlyphChanged(Sender: TObject);

    procedure UpdateExclusive;

    function GetGlyph: TBitmap;

    procedure SetDropDownArrowColor(Value: TColor);

    procedure SetDropDownWidth(Value: Integer);

    procedure SetGlyph(Value: TBitmap);

    function GetNumGlyphs: TNumGlyphs;

    procedure SetNumGlyphs(Value: TNumGlyphs);

    procedure SetDown(Value: Boolean);

    procedure SetFlat(Value: Boolean);

    procedure SetAllowAllUp(Value: Boolean);

    procedure SetGroupIndex(Value: Integer);

    procedure SetLayout(Value: TButtonLayout);

    procedure SetSpacing(Value: Integer);

    procedure SetMargin(Value: Integer);

    procedure UpdateTracking;

    procedure CMEnabledChanged(var Message: TMessage);

      message CM_ENABLEDCHANGED;

    procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;

    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;

    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;

    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;

    procedure CMSysColorChange(var Message: TMessage);

      message CM_SYSCOLORCHANGE;

    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;

    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;

    procedure WMLButtonDblClk(var Message: TWMLButtonDown);

      message WM_LBUTTONDBLCLK;



    procedure DrawButtonSeperatorUp(Canvas: TCanvas);

    procedure DrawButtonSeperatorDown(Canvas: TCanvas);

    procedure DrawTriangle(Canvas: TCanvas; Top, Left, Width: Integer);

    procedure SetDroppedDown(const Value: Boolean);

    procedure SetSelectionColor(const Value: TColor);

    procedure PopupWndProc(var Msg: TMessage);

    function GetCustomText: String;

    procedure SetCustomText(const Value: String);

    function GetDefaultText: String;

    procedure SetDefaultText(const Value: String);

    procedure SetShowSystemColors(const Value: Boolean);

    function GetShowSystemColors: Boolean;

    procedure SetTransparent(const Value: Boolean);

    procedure SetIndicatorBorder(const Value: TIndicatorBorder);

    function GetPopupSpacing: Integer;

    procedure SetPopupSpacing(const Value: Integer);

  protected

    procedure DoDefaultEvent; virtual;

    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;

    function GetPalette: HPALETTE; override;

    procedure Loaded; override;

    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;

      X, Y: Integer); override;

    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;

    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;

      X, Y: Integer); override;

    procedure Paint; override;

  public

    constructor Create(AOwner: TComponent); override;

    destructor Destroy; override;



    procedure Click; override;



    property DroppedDown: Boolean read FDroppedDown write SetDroppedDown;

  published

    property Action;

    property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp

      default False;

    property Anchors;

    property BiDiMode;

    property Caption;

    property Constraints;

    property CustomText: String read GetCustomText write SetCustomText;

    property DefaultText: String read GetDefaultText write SetDefaultText;

    property Down: Boolean read FDown write SetDown default False;

    property DropDownArrowColor: TColor read FDropDownArrowColor

      write SetDropDownArrowColor default clBlack;

    property DropDownWidth: Integer read FDropDownWidth write SetDropDownWidth

      default 15;

    property Enabled;

    property Flat: Boolean read FFlat write SetFlat default False;

    property Font;

    property Glyph: TBitmap read GetGlyph write SetGlyph;

    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;

    property IndicatorBorder: TIndicatorBorder read FIndicatorBorder

      write SetIndicatorBorder default ibFlat;

    property Layout: TButtonLayout read FLayout write SetLayout

      default blGlyphLeft;

    property Margin: Integer read FMargin write SetMargin default -1;

    property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs

      default 1;

    property ParentBiDiMode;

    property ParentFont;

    property ParentShowHint;

    property PopupSpacing: Integer read GetPopupSpacing write SetPopupSpacing;

    property SelectionColor: TColor read FSelectionColor write SetSelectionColor

      default clBlack;

    property ShowHint;

    property ShowSystemColors: Boolean read GetShowSystemColors

      write SetShowSystemColors;

    property Spacing: Integer read FSpacing write SetSpacing default 4;

    property Transparent: Boolean read FTransparent write SetTransparent

      default True;

    property Visible;



    property OnChange: TNotifyEvent read FOnChange write FOnChange;

    property OnClick;

    property OnDblClick;

    property OnDefaultSelect: TNotifyEvent read FOnDefaultSelect

      write FOnDefaultSelect;

    property OnDropChanged: TNotifyEvent read FOnDropChanged

      write FOnDropChanged;

    property OnDropChanging: TDropChangingEvent read FOnDropChanging

      write FOnDropChanging;

    property OnHint: THintEvent read FOnHint write FOnHint;

    property OnMouseDown;

    property OnMouseMove;

    property OnMouseUp;

  end;



procedure Register;



// -----------------------------------------------------------------------------



implementation



uses ActnList, ImgList;



const

  DRAW_BUTTON_UP = 8208;

  DRAW_BUTTON_DOWN = 8720;



type

  TColorEntry = record

    Name: PChar;

    case Boolean of

      True:

        (R, G, B, reserved: Byte);

      False:

        (Color: COLORREF);

  end;



const

  DefaultColorCount = 40;

  // these colors are the same as used in Office 97/2000

  DefaultColors: array [0 .. DefaultColorCount - 1] of TColorEntry =

    ((Name: 'Black'; Color: $000000), (Name: 'Brown'; Color: $003399),

    (Name: 'Olive Green'; Color: $003333), (Name: 'Dark Green'; Color: $003300),

    (Name: 'Dark Teal'; Color: $663300), (Name: 'Dark blue'; Color: $800000),

    (Name: 'Indigo'; Color: $993333), (Name: 'Gray-80%'; Color: $333333),



    (Name: 'Dark Red'; Color: $000080), (Name: 'Orange'; Color: $0066FF),

    (Name: 'Dark Yellow'; Color: $008080), (Name: 'Green'; Color: $008000),

    (Name: 'Teal'; Color: $808000), (Name: 'Blue'; Color: $FF0000),

    (Name: 'Blue-Gray'; Color: $996666), (Name: 'Gray-50%'; Color: $808080),



    (Name: 'Red'; Color: $0000FF), (Name: 'Light Orange'; Color: $0099FF),

    (Name: 'Lime'; Color: $00CC99), (Name: 'Sea Green'; Color: $669933),

    (Name: 'Aqua'; Color: $CCCC33), (Name: 'Light Blue'; Color: $FF6633),

    (Name: 'Violet'; Color: $800080), (Name: 'Grey-40%'; Color: $969696),



    (Name: 'Pink'; Color: $FF00FF), (Name: 'Gold'; Color: $00CCFF),

    (Name: 'Yellow'; Color: $00FFFF), (Name: 'Bright Green'; Color: $00FF00),

    (Name: 'Turquoise'; Color: $FFFF00), (Name: 'Sky Blue'; Color: $FFCC00),

    (Name: 'Plum'; Color: $663399), (Name: 'Gray-25%'; Color: $C0C0C0),



    (Name: 'Rose'; Color: $CC99FF), (Name: 'Tan'; Color: $99CCFF),

    (Name: 'Light Yellow'; Color: $99FFFF), (Name: 'Light Green';

    Color: $CCFFCC), (Name: 'Light Turquoise'; Color: $FFFFCC),

    (Name: 'Pale Blue'; Color: $FFCC99), (Name: 'Lavender'; Color: $FF99CC),

    (Name: 'White'; Color: $FFFFFF));



  SysColorCount = 25;

  SysColors: array [0 .. SysColorCount - 1] of TColorEntry =

    ((Name: 'system color: scroll bar'; Color: COLORREF(clScrollBar)),

    (Name: 'system color: background'; Color: COLORREF(clBackground)),

    (Name: 'system color: active caption'; Color: COLORREF(clActiveCaption)),

    (Name: 'system color: inactive caption'; Color: COLORREF(clInactiveCaption)

    ), (Name: 'system color: menu'; Color: COLORREF(clMenu)),

    (Name: 'system color: window'; Color: COLORREF(clWindow)),

    (Name: 'system color: window frame'; Color: COLORREF(clWindowFrame)),

    (Name: 'system color: menu text'; Color: COLORREF(clMenuText)),

    (Name: 'system color: window text'; Color: COLORREF(clWindowText)),

    (Name: 'system color: caption text'; Color: COLORREF(clCaptionText)),

    (Name: 'system color: active border'; Color: COLORREF(clActiveBorder)),

    (Name: 'system color: inactive border'; Color: COLORREF(clInactiveBorder)),

    (Name: 'system color: application workspace';

    Color: COLORREF(clAppWorkSpace)), (Name: 'system color: highlight';

    Color: COLORREF(clHighlight)), (Name: 'system color: highlight text';

    Color: COLORREF(clHighlightText)), (Name: 'system color: button face';

    Color: COLORREF(clBtnFace)), (Name: 'system color: button shadow';

    Color: COLORREF(clBtnShadow)), (Name: 'system color: gray text';

    Color: COLORREF(clGrayText)), (Name: 'system color: button text';

    Color: COLORREF(clBtnText)), (Name: 'system color: inactive caption text';

    Color: COLORREF(clInactiveCaptionText)),

    (Name: 'system color: button highlight'; Color: COLORREF(clBtnHighlight)),

    (Name: 'system color: 3D dark shadow'; Color: COLORREF(cl3DDkShadow)),

    (Name: 'system color: 3D light'; Color: COLORREF(cl3DLight)),

    (Name: 'system color: info text'; Color: COLORREF(clInfoText)),

    (Name: 'system color: info background'; Color: COLORREF(clInfoBk)));



type

  TGlyphList = class(TImageList)

  private

    FUsed: TBits;

    FCount: Integer;

    function AllocateIndex: Integer;

  public

    constructor CreateSize(AWidth, AHeight: Integer);

    destructor Destroy; override;



    function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;

    procedure Delete(Index: Integer);

    property Count: Integer read FCount;

  end;



  TGlyphCache = class

  private

    FGlyphLists: TList;

  public

    constructor Create;

    destructor Destroy; override;



    function GetList(AWidth, AHeight: Integer): TGlyphList;

    procedure ReturnList(List: TGlyphList);

    function Empty: Boolean;

  end;



  TButtonGlyph = class

  private

    FOriginal: TBitmap;

    FGlyphList: TGlyphList;

    FIndexes: array [TButtonState] of Integer;

    FTransparentColor: TColor;

    FNumGlyphs: TNumGlyphs;

    FOnChange: TNotifyEvent;

    procedure GlyphChanged(Sender: TObject);

    procedure SetGlyph(Value: TBitmap);

    procedure SetNumGlyphs(Value: TNumGlyphs);

    procedure Invalidate;

    function CreateButtonGlyph(State: TButtonState): Integer;

    procedure DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;

      State: TButtonState; Transparent: Boolean);

    procedure DrawButtonText(Canvas: TCanvas; const Caption: string;

      TextBounds: TRect; State: TButtonState; BiDiFlags: Longint);

    procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;

      const Offset: TPoint; const Caption: string; Layout: TButtonLayout;

      Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;

      const DropDownWidth: Integer; BiDiFlags: Longint);

  public

    constructor Create;

    destructor Destroy; override;



    function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;

      const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;

      State: TButtonState; Transparent: Boolean; const DropDownWidth: Integer;

      BiDiFlags: Longint): TRect;



    property Glyph: TBitmap read FOriginal write SetGlyph;

    property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs;

    property OnChange: TNotifyEvent read FOnChange write FOnChange;

  end;



  TCombEntry = record

    Position: TPoint;

    Color: COLORREF;

  end;



  TCombArray = array of TCombEntry;



  TFloatPoint = record

    X, Y: Extended;

  end;



  TRGB = record

    Red, Green, Blue: Single;

  end;



  TSelectionMode = (smNone, smColor, smBW, smRamp);



  TColorPopup = class(TWinControl)

  private

    FDefaultText, FCustomText: String;

    FCurrentColor: TColor;

    FCanvas: TCanvas;

    FMargin, FSpacing, FColumnCount, FRowCount, FSysRowCount, FBoxSize: Integer;

    FSelectedIndex, FHoverIndex: Integer;

    FWindowRect, FCustomTextRect, FDefaultTextRect, FColorCombRect, FBWCombRect,

      FSliderRect, FCustomColorRect: TRect;

    FShowSysColors: Boolean;



    // custom color picking

    FCombSize, FLevels: Integer;

    FBWCombs, FColorCombs: TCombArray;

    FCombCorners: array [0 .. 5] of TFloatPoint;

    FCenterColor: TRGB;

    FCenterIntensity: Single; // scale factor for the center color

    FCustomIndex, // If FSelectedIndex contains CustomCell then this index shows

    // which index in the custom area has been selected.

    // Positive values indicate the color comb and negativ values

    // indicate the B&W combs (complement). This value is offset with

    // 1 to use index 0 to show no selection.

    FRadius: Integer;

    FSelectionMode: TSelectionMode; // indicates where the user has clicked

    // with the mouse to restrict draw selection

    procedure SelectColor(Color: TColor);

    procedure ChangeHoverSelection(Index: Integer);

    procedure DrawCell(Index: Integer);

    procedure InvalidateCell(Index: Integer);

    procedure EndSelection(Cancel: Boolean);

    function GetCellRect(Index: Integer; var Rect: TRect): Boolean;

    function GetColumn(Index: Integer): Integer;

    function GetIndex(Row, Col: Integer): Integer;

    function GetRow(Index: Integer): Integer;

    procedure Initialise;

    procedure AdjustWindow;

    procedure SetSpacing(Value: Integer);

    procedure SetSelectedColor(const Value: TColor);

    procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;

    procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;

    procedure CNSysKeyDown(var Message: TWMChar); message CN_SYSKEYDOWN;

    procedure WMActivateApp(var Message: TWMActivateApp);

      message WM_ACTIVATEAPP;

    procedure WMLButtonDown(var Message: TWMLButtonDown);

      message WM_LBUTTONDOWN;

    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;

    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;

    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;

    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

    function SelectionFromPoint(P: TPoint): Integer;

    procedure DrawCombControls;

    procedure DrawComb(Canvas: TCanvas; X, Y, Size: Integer);

    function HandleBWArea(const Message: TWMMouse): Boolean;

    function HandleColorComb(const Message: TWMMouse): Boolean;

    function HandleSlider(const Message: TWMMouse): Boolean;

    function PtInComb(Comb: TCombEntry; P: TPoint; Scale: Integer): Boolean;

    procedure HandleCustomColors(var Message: TWMMouse);

    function GetHint(Cell: Integer): String;

    function FindBWArea(X, Y: Integer): Integer;

    function FindColorArea(X, Y: Integer): Integer;

    procedure DrawSeparator(Left, Top, Right: Integer);

    procedure ChangeSelection(NewSelection: Integer);

  protected

    procedure CalculateCombLayout;

    procedure CreateParams(var Params: TCreateParams); override;

    procedure CreateWnd; override;

    procedure ShowPopupAligned;

  public

    constructor Create(AOwner: TComponent); override;

    destructor Destroy; override;



    property SelectedColor: TColor read FCurrentColor write SetSelectedColor;

    property Spacing: Integer read FSpacing write SetSpacing;

  end;



const

  DefCenterColor: TRGB = (Red: 1; Green: 1; Blue: 1); // White

  DefColors: array [0 .. 5] of TRGB = ((Red: 1; Green: 0; Blue: 1), // Magenta

    (Red: 1; Green: 0; Blue: 0), // Red

    (Red: 1; Green: 1; Blue: 0), // Yellow

    (Red: 0; Green: 1; Blue: 0), // Green

    (Red: 0; Green: 1; Blue: 1), // Cyan

    (Red: 0; Green: 0; Blue: 1) // Blue

    );

  DefCenter: TFloatPoint = (X: 0; Y: 0);



var

  GlyphCache: TGlyphCache;

  ButtonCount: Integer;



  // ----------------- TGlyphList ------------------------------------------------



constructor TGlyphList.CreateSize(AWidth, AHeight: Integer);



begin

  inherited CreateSize(AWidth, AHeight);

  FUsed := TBits.Create;

end;



// -----------------------------------------------------------------------------



destructor TGlyphList.Destroy;



begin

  FUsed.Free;

  inherited Destroy;

end;



// -----------------------------------------------------------------------------



function TGlyphList.AllocateIndex: Integer;



begin

  Result := FUsed.OpenBit;

  if Result >= FUsed.Size then

  begin

    Result := inherited Add(nil, nil);

    FUsed.Size := Result + 1;

  end;

  FUsed[Result] := True;

end;



// -----------------------------------------------------------------------------



function TGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;



begin

  Result := AllocateIndex;

  ReplaceMasked(Result, Image, MaskColor);

  Inc(FCount);

end;



// -----------------------------------------------------------------------------



procedure TGlyphList.Delete(Index: Integer);



begin

  if FUsed[Index] then

  begin

    Dec(FCount);

    FUsed[Index] := False;

  end;

end;



// ----------------- TGlyphCache -----------------------------------------------



constructor TGlyphCache.Create;



begin

  inherited Create;

  FGlyphLists := TList.Create;

end;



// -----------------------------------------------------------------------------



destructor TGlyphCache.Destroy;



begin

  FGlyphLists.Free;

  inherited Destroy;

end;



// -----------------------------------------------------------------------------



function TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;



var

  I: Integer;



begin

  for I := FGlyphLists.Count - 1 downto 0 do

  begin

    Result := FGlyphLists[I];

    with Result do

      if (AWidth = Width) and (AHeight = Height) then

        Exit;

  end;

  Result := TGlyphList.CreateSize(AWidth, AHeight);

  FGlyphLists.Add(Result);

end;



// -----------------------------------------------------------------------------



procedure TGlyphCache.ReturnList(List: TGlyphList);



begin

  if List = nil then

    Exit;

  if List.Count = 0 then

  begin

    FGlyphLists.Remove(List);

    List.Free;

  end;

end;



// -----------------------------------------------------------------------------



function TGlyphCache.Empty: Boolean;



begin

  Result := FGlyphLists.Count = 0;

end;



// ----------------- TButtonGlyph ----------------------------------------------



constructor TButtonGlyph.Create;



var

  I: TButtonState;



begin

  inherited Create;

  FOriginal := TBitmap.Create;

  FOriginal.OnChange := GlyphChanged;

  FTransparentColor := clOlive;

  FNumGlyphs := 1;

  for I := Low(I) to High(I) do

    FIndexes[I] := -1;

  if GlyphCache = nil then

    GlyphCache := TGlyphCache.Create;

end;



// -----------------------------------------------------------------------------



destructor TButtonGlyph.Destroy;



begin

  FOriginal.Free;

  Invalidate;

  if Assigned(GlyphCache) and GlyphCache.Empty then

  begin

    GlyphCache.Free;

    GlyphCache := nil;

  end;

  inherited Destroy;

end;



// -----------------------------------------------------------------------------



procedure TButtonGlyph.Invalidate;



var

  I: TButtonState;



begin

  for I := Low(I) to High(I) do

  begin

    if FIndexes[I] <> -1 then

      FGlyphList.Delete(FIndexes[I]);

    FIndexes[I] := -1;

  end;

  GlyphCache.ReturnList(FGlyphList);

  FGlyphList := nil;

end;



// -----------------------------------------------------------------------------



procedure TButtonGlyph.GlyphChanged(Sender: TObject);



begin

  if Sender = FOriginal then

  begin

    FTransparentColor := FOriginal.TransparentColor;

    Invalidate;

    if Assigned(FOnChange) then

      FOnChange(Self);

  end;

end;



// -----------------------------------------------------------------------------



procedure TButtonGlyph.SetGlyph(Value: TBitmap);



var

  Glyphs: Integer;



begin

  Invalidate;

  FOriginal.Assign(Value);

  if (Value <> nil) and (Value.Height > 0) then

  begin

    FTransparentColor := Value.TransparentColor;

    if Value.Width mod Value.Height = 0 then

    begin

      Glyphs := Value.Width div Value.Height;

      if Glyphs > 4 then

        Glyphs := 1;

      SetNumGlyphs(Glyphs);

    end;

  end;

end;



// -----------------------------------------------------------------------------



procedure TButtonGlyph.SetNumGlyphs(Value: TNumGlyphs);



begin

  if (Value <> FNumGlyphs) and (Value > 0) then

  begin

    Invalidate;

    FNumGlyphs := Value;

    GlyphChanged(Glyph);

  end;

end;



// -----------------------------------------------------------------------------



function TButtonGlyph.CreateButtonGlyph(State: TButtonState): Integer;



const

  ROP_DSPDxax = $00E20746;



var

  TmpImage, DDB, MonoBmp: TBitmap;

  IWidth, IHeight: Integer;

  IRect, ORect: TRect;

  I: TButtonState;

  DestDC: HDC;



begin

  if (State = bsDown) and (NumGlyphs < 3) then

    State := bsUp;

  Result := FIndexes[State];

  if Result <> -1 then

    Exit;

  if (FOriginal.Width or FOriginal.Height) = 0 then

    Exit;



  IWidth := FOriginal.Width div FNumGlyphs;

  IHeight := FOriginal.Height;

  if FGlyphList = nil then

  begin

    if GlyphCache = nil then

      GlyphCache := TGlyphCache.Create;

    FGlyphList := GlyphCache.GetList(IWidth, IHeight);

  end;

  TmpImage := TBitmap.Create;

  try

    TmpImage.Width := IWidth;

    TmpImage.Height := IHeight;

    IRect := Rect(0, 0, IWidth, IHeight);

    TmpImage.Canvas.Brush.Color := clBtnFace;

    TmpImage.Palette := CopyPalette(FOriginal.Palette);

    I := State;

    if Ord(I) >= NumGlyphs then

      I := bsUp;

    ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);

    case State of

      bsUp, bsDown, bsExclusive:

        begin

          TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);

          if FOriginal.TransparentMode = tmFixed then

            FIndexes[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor)

          else

            FIndexes[State] := FGlyphList.AddMasked(TmpImage, clDefault);

        end;

      bsDisabled:

        begin

          MonoBmp := nil;

          DDB := nil;

          try

            MonoBmp := TBitmap.Create;

            DDB := TBitmap.Create;

            DDB.Assign(FOriginal);

            DDB.HandleType := bmDDB;

            if NumGlyphs > 1 then

              with TmpImage.Canvas do

              begin

                // Change white & gray to clBtnHighlight and clBtnShadow

                CopyRect(IRect, DDB.Canvas, ORect);

                MonoBmp.Monochrome := True;

                MonoBmp.Width := IWidth;

                MonoBmp.Height := IHeight;



                // Convert white to clBtnHighlight

                DDB.Canvas.Brush.Color := clWhite;

                MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);

                Brush.Color := clBtnHighlight;

                DestDC := Handle;

                SetTextColor(DestDC, clBlack);

                SetBkColor(DestDC, clWhite);

                BitBlt(DestDC, 0, 0, IWidth, IHeight, MonoBmp.Canvas.Handle, 0,

                  0, ROP_DSPDxax);



                // Convert gray to clBtnShadow

                DDB.Canvas.Brush.Color := clGray;

                MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);

                Brush.Color := clBtnShadow;

                DestDC := Handle;

                SetTextColor(DestDC, clBlack);

                SetBkColor(DestDC, clWhite);

                BitBlt(DestDC, 0, 0, IWidth, IHeight, MonoBmp.Canvas.Handle, 0,

                  0, ROP_DSPDxax);



                // Convert transparent color to clBtnFace

                DDB.Canvas.Brush.Color := ColorToRGB(FTransparentColor);

                MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);

                Brush.Color := clBtnFace;

                DestDC := Handle;

                SetTextColor(DestDC, clBlack);

                SetBkColor(DestDC, clWhite);

                BitBlt(DestDC, 0, 0, IWidth, IHeight, MonoBmp.Canvas.Handle, 0,

                  0, ROP_DSPDxax);

              end

            else

            begin

              // Create a disabled version

              with MonoBmp do

              begin

                Assign(FOriginal);

                HandleType := bmDDB;

                Canvas.Brush.Color := clBlack;

                Width := IWidth;

                if Monochrome then

                begin

                  Canvas.Font.Color := clWhite;

                  Monochrome := False;

                  Canvas.Brush.Color := clWhite;

                end;

                Monochrome := True;

              end;



              with TmpImage.Canvas do

              begin

                Brush.Color := clBtnFace;

                FillRect(IRect);

                Brush.Color := clBtnHighlight;

                SetTextColor(Handle, clBlack);

                SetBkColor(Handle, clWhite);

                BitBlt(Handle, 1, 1, IWidth, IHeight, MonoBmp.Canvas.Handle, 0,

                  0, ROP_DSPDxax);

                Brush.Color := clBtnShadow;

                SetTextColor(Handle, clBlack);

                SetBkColor(Handle, clWhite);

                BitBlt(Handle, 0, 0, IWidth, IHeight, MonoBmp.Canvas.Handle, 0,

                  0, ROP_DSPDxax);

              end;

            end;

          finally

            DDB.Free;

            MonoBmp.Free;

          end;

          FIndexes[State] := FGlyphList.AddMasked(TmpImage, clDefault);

        end;

    end;

  finally

    TmpImage.Free;

  end;

  Result := FIndexes[State];

  FOriginal.Dormant;

end;



// -----------------------------------------------------------------------------



procedure TButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;

  State: TButtonState; Transparent: Boolean);



var

  Index: Integer;



begin

  if Assigned(FOriginal) then

  begin

    if (FOriginal.Width = 0) or (FOriginal.Height = 0) then

      Exit;



    Index := CreateButtonGlyph(State);



    with GlyphPos do

      if Transparent or (State = bsExclusive) then

        ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,

          clNone, clNone, ILD_Transparent)

      else

        ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, X, Y, 0, 0,

          ColorToRGB(clBtnFace), clNone, ILD_Normal);

  end;

end;



// -----------------------------------------------------------------------------



procedure TButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;

  TextBounds: TRect; State: TButtonState; BiDiFlags: Longint);



begin

  with Canvas do

  begin

    Brush.Style := bsClear;

    if State = bsDisabled then

    begin

      OffsetRect(TextBounds, 1, 1);

      Font.Color := clBtnHighlight;

      DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,

        DT_CENTER or DT_VCENTER or BiDiFlags);

      OffsetRect(TextBounds, -1, -1);

      Font.Color := clBtnShadow;

      DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,

        DT_CENTER or DT_VCENTER or BiDiFlags);

    end

    else

      DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,

        DT_CENTER or DT_VCENTER or BiDiFlags);

  end;

end;



// -----------------------------------------------------------------------------



procedure TButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;

  const Offset: TPoint; const Caption: string; Layout: TButtonLayout;

  Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;

  const DropDownWidth: Integer; BiDiFlags: Longint);



var

  TextPos: TPoint;

  ClientSize, GlyphSize, TextSize: TPoint;

  TotalSize: TPoint;



begin

  if (BiDiFlags and DT_RIGHT) = DT_RIGHT then

    if Layout = blGlyphLeft then

      Layout := blGlyphRight

    else if Layout = blGlyphRight then

      Layout := blGlyphLeft;



  // calculate the item sizes

  ClientSize := Point(Client.Right - Client.Left - DropDownWidth,

    Client.Bottom - Client.Top);



  if FOriginal <> nil then

    GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height)

  else

    GlyphSize := Point(0, 0);



  if Length(Caption) > 0 then

  begin

    TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);

    DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds,

      DT_CALCRECT or BiDiFlags);

    TextSize := Point(TextBounds.Right - TextBounds.Left,

      TextBounds.Bottom - TextBounds.Top);

  end

  else

  begin

    TextBounds := Rect(0, 0, 0, 0);

    TextSize := Point(0, 0);

  end;



  // If the layout has the glyph on the right or the left, then both the

  // text and the glyph are centered vertically.  If the glyph is on the top

  // or the bottom, then both the text and the glyph are centered horizontally.

  if Layout in [blGlyphLeft, blGlyphRight] then

  begin

    GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;

    TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;

  end

  else

  begin

    GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;

    TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;

  end;



  // if there is no text or no bitmap, then Spacing is irrelevant

  if (TextSize.X = 0) or (GlyphSize.X = 0) then

    Spacing := 0;



  // adjust Margin and Spacing

  if Margin = -1 then

  begin

    if Spacing = -1 then

    begin

      TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);

      if Layout in [blGlyphLeft, blGlyphRight] then

        Margin := (ClientSize.X - TotalSize.X) div 3

      else

        Margin := (ClientSize.Y - TotalSize.Y) div 3;

      Spacing := Margin;

    end

    else

    begin

      TotalSize := Point(GlyphSize.X + Spacing + TextSize.X,

        GlyphSize.Y + Spacing + TextSize.Y);

      if Layout in [blGlyphLeft, blGlyphRight] then

        Margin := (ClientSize.X - TotalSize.X + 1) div 2

      else

        Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;

    end;

  end

  else

  begin

    if Spacing = -1 then

    begin

      TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X),

        ClientSize.Y - (Margin + GlyphSize.Y));

      if Layout in [blGlyphLeft, blGlyphRight] then

        Spacing := (TotalSize.X - TextSize.X) div 2

      else

        Spacing := (TotalSize.Y - TextSize.Y) div 2;

    end;

  end;



  case Layout of

    blGlyphLeft:

      begin

        GlyphPos.X := Margin;

        TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;

      end;

    blGlyphRight:

      begin

        GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;

        TextPos.X := GlyphPos.X - Spacing - TextSize.X;

      end;

    blGlyphTop:

      begin

        GlyphPos.Y := Margin;

        TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;

      end;

    blGlyphBottom:

      begin

        GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;

        TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;

      end;

  end;



  // fixup the result variables

  with GlyphPos do

  begin

  //  Inc(X, Client.Left + Offset.X);

 //   Inc(Y, Client.Top + Offset.Y);

  end;

  //OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X,

 //   TextPos.Y + Client.Top + Offset.X);

end;



// -----------------------------------------------------------------------------



function TButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;

  const Offset: TPoint; const Caption: string; Layout: TButtonLayout;

  Margin, Spacing: Integer; State: TButtonState; Transparent: Boolean;

  const DropDownWidth: Integer; BiDiFlags: Longint): TRect;



var

  GlyphPos: TPoint;

  R: TRect;



begin

  CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,

    GlyphPos, R, DropDownWidth, BiDiFlags);

  DrawButtonGlyph(Canvas, GlyphPos, State, Transparent);

  DrawButtonText(Canvas, Caption, R, State, BiDiFlags);



  // return a rectangle wherein the color indicator can be drawn

  if Caption = '' then

  begin

    Result := Client;

    Dec(Result.Right, DropDownWidth + 2);

    InflateRect(Result, -2, -2);



    // consider glyph if no text is to be painted (else it is already taken into account)

    if Assigned(FOriginal) and (FOriginal.Width > 0) and (FOriginal.Height > 0)

    then

      case Layout of

        blGlyphLeft:

          begin

            Result.Left := GlyphPos.X + FOriginal.Width + 4;

            Result.Top := GlyphPos.Y;

            Result.Bottom := GlyphPos.Y + FOriginal.Height;

          end;

        blGlyphRight:

          begin

            Result.Right := GlyphPos.X - 4;

            Result.Top := GlyphPos.Y;

            Result.Bottom := GlyphPos.Y + FOriginal.Height;

          end;

        blGlyphTop:

          Result.Top := GlyphPos.Y + FOriginal.Height + 4;

        blGlyphBottom:

          Result.Bottom := GlyphPos.Y - 4;

      end;

  end

  else

  begin

    // consider caption

    Result := Rect(R.Left, R.Bottom, R.Right, R.Bottom + 6);

    if (Result.Bottom + 2) > Client.Bottom then

      Result.Bottom := Client.Bottom - 2;

  end;

end;



// ----------------- TColorPopup ------------------------------------------------



constructor TColorPopup.Create(AOwner: TComponent);



begin

  inherited;

  ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];



  FCanvas := TCanvas.Create;

  Color := clBtnFace;

  ShowHint := True;



  Initialise;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.Initialise;



var

  I: Integer;



begin

  FBoxSize := 18;

  FMargin := GetSystemMetrics(SM_CXEDGE);

  FSpacing := 8;

  FHoverIndex := NoCell;

  FSelectedIndex := NoCell;



  // init comb caclulation

  for I := 0 to 5 do

  begin

    FCombCorners[I].X := 0.5 * cos(Pi * (90 - I * 60) / 180);

    FCombCorners[I].Y := 0.5 * sin(Pi * (90 - I * 60) / 180);

  end;

  FRadius := 66;

  FLevels := 7;

  FCombSize := Trunc(FRadius / (FLevels - 1));

  FCenterColor := DefCenterColor;

  FCenterIntensity := 1;

end;



// ------------------------------------------------------------------------------



destructor TColorPopup.Destroy;



begin

  FBWCombs := nil;

  FColorCombs := nil;

  FCanvas.Free;

  inherited;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.CNSysKeyDown(var Message: TWMKeyDown);



// handles accelerator keys



begin

  with Message do

  begin

    if (Length(FDefaultText) > 0) and IsAccel(CharCode, FDefaultText) then

    begin

      ChangeSelection(DefaultCell);

      EndSelection(False);

      Result := 1;

    end

    else if (FSelectedIndex <> CustomCell) and (Length(FCustomText) > 0) and

      IsAccel(CharCode, FCustomText) then

    begin

      ChangeSelection(CustomCell);

      Result := 1;

    end

    else

      inherited;

  end;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.CNKeyDown(var Message: TWMKeyDown);



// if an arrow key is pressed, then move the selection



var

  Row, MaxRow, Column: Integer;



begin

  inherited;



  if FHoverIndex <> NoCell then

  begin

    Row := GetRow(FHoverIndex);

    Column := GetColumn(FHoverIndex);

  end

  else

  begin

    Row := GetRow(FSelectedIndex);

    Column := GetColumn(FSelectedIndex);

  end;



  if FShowSysColors then

    MaxRow := DefaultColorCount + SysColorCount - 1

  else

    MaxRow := DefaultColorCount - 1;



  case Message.CharCode of

    VK_DOWN:

      begin

        if Row = DefaultCell then

        begin

          Row := 0;

          Column := 0;

        end

        else if Row = CustomCell then

        begin

          if Length(FDefaultText) > 0 then

          begin

            Row := DefaultCell;

            Column := Row;

          end

          else

          begin

            Row := 0;

            Column := 0;

          end;

        end

        else

        begin

          Inc(Row);

          if GetIndex(Row, Column) < 0 then

          begin

            if Length(FCustomText) > 0 then

            begin

              Row := CustomCell;

              Column := Row;

            end

            else

            begin

              if Length(FDefaultText) > 0 then

              begin

                Row := DefaultCell;

                Column := Row;

              end

              else

              begin

                Row := 0;

                Column := 0;

              end;

            end;

          end;

        end;

        ChangeHoverSelection(GetIndex(Row, Column));

        Message.Result := 1;

      end;



    VK_UP:

      begin

        if Row = DefaultCell then

        begin

          if Length(FCustomText) > 0 then

          begin

            Row := CustomCell;

            Column := Row;

          end

          else

          begin

            Row := GetRow(MaxRow);

            Column := GetColumn(MaxRow);

          end

        end

        else if Row = CustomCell then

        begin

          Row := GetRow(MaxRow);

          Column := GetColumn(MaxRow);

        end

        else if Row > 0 then

          Dec(Row)

        else

        begin

          if Length(FDefaultText) > 0 then

          begin

            Row := DefaultCell;

            Column := Row;

          end

          else if Length(FCustomText) > 0 then

          begin

            Row := CustomCell;

            Column := Row;

          end

          else

          begin

            Row := GetRow(MaxRow);

            Column := GetColumn(MaxRow);

          end;

        end;

        ChangeHoverSelection(GetIndex(Row, Column));

        Message.Result := 1;

      end;



    VK_RIGHT:

      begin

        if Row = DefaultCell then

        begin

          Row := 0;

          Column := 0;

        end

        else if Row = CustomCell then

        begin

          if Length(FDefaultText) > 0 then

          begin

            Row := DefaultCell;

            Column := Row;

          end

          else

          begin

            Row := 0;

            Column := 0;

          end;

        end

        else if Column < FColumnCount - 1 then

          Inc(Column)

        else

        begin

          Column := 0;

          Inc(Row);

        end;



        if GetIndex(Row, Column) = NoCell then

        begin

          if Length(FCustomText) > 0 then

          begin

            Row := CustomCell;

            Column := Row;

          end

          else if Length(FDefaultText) > 0 then

          begin

            Row := DefaultCell;

            Column := Row;

          end

          else

          begin

            Row := 0;

            Column := 0;

          end;

        end;

        ChangeHoverSelection(GetIndex(Row, Column));

        Message.Result := 1;

      end;



    VK_LEFT:

      begin

        if Row = DefaultCell then

        begin

          if Length(FCustomText) > 0 then

          begin

            Row := CustomCell;

            Column := Row;

          end

          else

          begin

            Row := GetRow(MaxRow);

            Column := GetColumn(MaxRow);

          end;

        end

        else if Row = CustomCell then

        begin

          Row := GetRow(MaxRow);

          Column := GetColumn(MaxRow);

        end

        else if Column > 0 then

          Dec(Column)

        else

        begin

          if Row > 0 then

          begin

            Dec(Row);

            Column := FColumnCount - 1;

          end

          else

          begin

            if Length(FDefaultText) > 0 then

            begin

              Row := DefaultCell;

              Column := Row;

            end

            else if Length(FCustomText) > 0 then

            begin

              Row := CustomCell;

              Column := Row;

            end

            else

            begin

              Row := GetRow(MaxRow);

              Column := GetColumn(MaxRow);

            end;

          end;

        end;

        ChangeHoverSelection(GetIndex(Row, Column));

        Message.Result := 1;

      end;



    VK_ESCAPE:

      begin

        EndSelection(True);

        Message.Result := 1;

      end;



    VK_RETURN, VK_SPACE:

      begin

        // this case can only occur if there was no click on the window

        // hence the hover index is the new color

        FSelectedIndex := FHoverIndex;

        EndSelection(False);

        Message.Result := 1;

      end;

  end;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.DrawSeparator(Left, Top, Right: Integer);



var

  R: TRect;



begin

  R := Rect(Left, Top, Right, Top);

  DrawEdge(FCanvas.Handle, R, EDGE_ETCHED, BF_TOP);

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.DrawCell(Index: Integer);



var

  R, MarkRect: TRect;

  CellColor: TColor;



begin

  // for the custom text area

  if (Length(FCustomText) > 0) and (Index = CustomCell) then

  begin

    // the extent of the actual text button

    R := FCustomTextRect;



    // fill background

    FCanvas.Brush.Color := clBtnFace;

    FCanvas.FillRect(R);



    with FCustomTextRect do

      DrawSeparator(Left, Top - 2 * FMargin, Right);



    InflateRect(R, -1, 0);



    // fill background

    if (FSelectedIndex = Index) and (FHoverIndex <> Index) then

      FCanvas.Brush.Color := clBtnHighlight

    else

      FCanvas.Brush.Color := clBtnFace;



    FCanvas.FillRect(R);

    // draw button

    if (FSelectedIndex = Index) or

      ((FHoverIndex = Index) and (csLButtonDown in ControlState)) then

      DrawEdge(FCanvas.Handle, R, BDR_SUNKENOUTER, BF_RECT)

    else if FHoverIndex = Index then

      DrawEdge(FCanvas.Handle, R, BDR_RAISEDINNER, BF_RECT);



    // draw custom text

    DrawText(FCanvas.Handle, PChar(FCustomText), Length(FCustomText), R,

      DT_CENTER or DT_VCENTER or DT_SINGLELINE);



    // draw preview color rectangle

    if FCustomIndex = 0 then

    begin

      FCanvas.Brush.Color := clBtnShadow;

      FCanvas.FrameRect(FCustomColorRect);

    end

    else

    begin

      FCanvas.Pen.Color := clGray;

      if FCustomIndex > 0 then

        FCanvas.Brush.Color := FColorCombs[FCustomIndex - 1].Color

      else

        FCanvas.Brush.Color := FBWCombs[-(FCustomIndex + 1)].Color;

      with FCustomColorRect do

        FCanvas.Rectangle(Left, Top, Right, Bottom);

    end;

  end

  else

    // for the default text area

    if (Length(FDefaultText) > 0) and (Index = DefaultCell) then

    begin

      R := FDefaultTextRect;



      // Fill background

      FCanvas.Brush.Color := clBtnFace;

      FCanvas.FillRect(R);



      InflateRect(R, -1, -1);



      // fill background

      if (FSelectedIndex = Index) and (FHoverIndex <> Index) then

        FCanvas.Brush.Color := clBtnHighlight

      else

        FCanvas.Brush.Color := clBtnFace;



      FCanvas.FillRect(R);

      // draw button

      if (FSelectedIndex = Index) or

        ((FHoverIndex = Index) and (csLButtonDown in ControlState)) then

        DrawEdge(FCanvas.Handle, R, BDR_SUNKENOUTER, BF_RECT)

      else if FHoverIndex = Index then

        DrawEdge(FCanvas.Handle, R, BDR_RAISEDINNER, BF_RECT);



      // draw small rectangle

      with MarkRect do

      begin

        MarkRect := R;

        InflateRect(MarkRect, -FMargin - 1, -FMargin - 1);

        FCanvas.Brush.Color := clBtnShadow;

        FCanvas.FrameRect(MarkRect);

      end;



      // draw default text

      SetBkMode(FCanvas.Handle, Transparent);

      DrawText(FCanvas.Handle, PChar(FDefaultText), Length(FDefaultText), R,

        DT_CENTER or DT_VCENTER or DT_SINGLELINE);

    end

    else

    begin

      if GetCellRect(Index, R) then

      begin

        if Index < DefaultColorCount then

          CellColor := TColor(DefaultColors[Index].Color)

        else

          CellColor := TColor(SysColors[Index - DefaultColorCount].Color);

        FCanvas.Pen.Color := clGray;

        // fill background

        if (FSelectedIndex = Index) and (FHoverIndex <> Index) then

          FCanvas.Brush.Color := clBtnHighlight

        else

          FCanvas.Brush.Color := clBtnFace;

        FCanvas.FillRect(R);



        // draw button

        if (FSelectedIndex = Index) or

          ((FHoverIndex = Index) and (csLButtonDown in ControlState)) then

          DrawEdge(FCanvas.Handle, R, BDR_SUNKENOUTER, BF_RECT)

        else if FHoverIndex = Index then

          DrawEdge(FCanvas.Handle, R, BDR_RAISEDINNER, BF_RECT);



        FCanvas.Brush.Color := CellColor;



        // draw the cell colour

        InflateRect(R, -(FMargin + 1), -(FMargin + 1));

        FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);

      end;

    end;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.DrawComb(Canvas: TCanvas; X, Y: Integer; Size: Integer);



// draws one single comb at position X, Y and with size Size

// fill color must already be set on call



var

  I: Integer;

  P: array [0 .. 5] of TPoint;



begin

  for I := 0 to 5 do

  begin

    P[I].X := Round(FCombCorners[I].X * Size + X);

    P[I].Y := Round(FCombCorners[I].Y * Size + Y);

  end;

  Canvas.Polygon(P);

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.DrawCombControls;



var

  I, Index: Integer;

  XOffs, YOffs, Count: Integer;

  dColor: Single;

  OffScreen: TBitmap;

{$IFDEF DEBUG}

  R: TRect;

{$ENDIF}

begin

  // to make the painting (and selecting) flicker free we use an offscreen

  // bitmap here

  OffScreen := TBitmap.Create;

  try

    OffScreen.Width := Width;

    OffScreen.Height := FColorCombRect.Bottom - FColorCombRect.Top +

      FBWCombRect.Bottom - FBWCombRect.Top + 2 * FMargin;



    with OffScreen.Canvas do

    begin

      Brush.Color := clBtnFace;

      FillRect(ClipRect);

      Pen.Style := psClear;

      // draw color comb from FColorCombs array

      XOffs := FRadius + FColorCombRect.Left;

      YOffs := FRadius;



      // draw the combs

      for I := 0 to High(FColorCombs) do

      begin

        Brush.Color := FColorCombs[I].Color;

        DrawComb(OffScreen.Canvas, FColorCombs[I].Position.X + XOffs,

          FColorCombs[I].Position.Y + YOffs, FCombSize);

      end;



      // mark selected comb

      if FCustomIndex > 0 then

      begin

        Index := FCustomIndex - 1;

        Pen.Style := psSolid;

        Pen.Mode := pmXOR;

        Pen.Color := clWhite;

        Pen.Width := 2;

        Brush.Style := bsClear;

        DrawComb(OffScreen.Canvas, FColorCombs[Index].Position.X + XOffs,

          FColorCombs[Index].Position.Y + YOffs, FCombSize);

        Pen.Style := psClear;

        Pen.Mode := pmCopy;

        Pen.Width := 1;

      end;



      // draw white-to-black combs

      XOffs := FColorCombRect.Left;

      YOffs := FColorCombRect.Bottom - FColorCombRect.Top - 4;

      // brush is automatically reset to bsSolid

      for I := 0 to High(FBWCombs) do

      begin

        Brush.Color := FBWCombs[I].Color;

        if I in [0, High(FBWCombs)] then

          DrawComb(OffScreen.Canvas, FBWCombs[I].Position.X + XOffs,

            FBWCombs[I].Position.Y + YOffs, 2 * FCombSize)

        else

          DrawComb(OffScreen.Canvas, FBWCombs[I].Position.X + XOffs,

            FBWCombs[I].Position.Y + YOffs, FCombSize);

      end;



      // mark selected comb

      if FCustomIndex < 0 then

      begin

        Index := -(FCustomIndex + 1);

        Pen.Style := psSolid;

        Pen.Mode := pmXOR;

        Pen.Color := clWhite;

        Pen.Width := 2;

        Brush.Style := bsClear;

        if Index in [0, High(FBWCombs)] then

          DrawComb(OffScreen.Canvas, FBWCombs[Index].Position.X + XOffs,

            FBWCombs[Index].Position.Y + YOffs, 2 * FCombSize)

        else

          DrawComb(OffScreen.Canvas, FBWCombs[Index].Position.X + XOffs,

            FBWCombs[Index].Position.Y + YOffs, FCombSize);

        Pen.Style := psClear;

        Pen.Mode := pmCopy;

        Pen.Width := 1;

      end;



      // center-color trackbar

      XOffs := FSliderRect.Left;

      YOffs := FSliderRect.Top - FColorCombRect.Top;

      Count := FSliderRect.Bottom - FSliderRect.Top - 1;

      dColor := 255 / Count;

      Pen.Style := psSolid;

      // b&w ramp

      for I := 0 to Count do

      begin

        Pen.Color := RGB(Round((Count - I) * dColor),

          Round((Count - I) * dColor), Round((Count - I) * dColor));

        MoveTo(XOffs, YOffs + I);

        LineTo(XOffs + 10, YOffs + I);

      end;



      // marker

      Inc(XOffs, 11);

      Inc(YOffs, Round(Count * (1 - FCenterIntensity)));

      Brush.Color := clBlack;

      Polygon([Point(XOffs, YOffs), Point(XOffs + 5, YOffs - 3),

        Point(XOffs + 5, YOffs + 3)]);



{$IFDEF DEBUG}

      Brush.Color := clRed;

      R := FColorCombRect;

      OffsetRect(R, 0, -FColorCombRect.Top);

      FrameRect(R);

      R := FBWCombRect;

      OffsetRect(R, 0, -FColorCombRect.Top);

      FrameRect(R);

      R := FSliderRect;

      OffsetRect(R, 0, -FColorCombRect.Top);

      FrameRect(R);

{$ENDIF}

      Pen.Style := psClear;

    end;

    // finally put the drawing on the screen

    FCanvas.Draw(0, FColorCombRect.Top, OffScreen);

  finally

    OffScreen.Free;

  end;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.WMPaint(var Message: TWMPaint);



var

  PS: TPaintStruct;

  I: Cardinal;

  R: TRect;

  SeparatorTop: Integer;



begin

  if Message.DC = 0 then

    FCanvas.Handle := BeginPaint(Handle, PS)

  else

    FCanvas.Handle := Message.DC;

  try

    // use system default font for popup text

    FCanvas.Font.Handle := GetStockObject(DEFAULT_GUI_FONT);

    if FColorCombs = nil then

      CalculateCombLayout;



    // default area text

    if Length(FDefaultText) > 0 then

      DrawCell(DefaultCell);



    // Draw colour cells

    for I := 0 to DefaultColorCount - 1 do

      DrawCell(I);



    if FShowSysColors then

    begin

      SeparatorTop := FRowCount * FBoxSize + FMargin;

      if Length(FDefaultText) > 0 then

        Inc(SeparatorTop, FDefaultTextRect.Bottom);

      with FCustomTextRect do

        DrawSeparator(FMargin + FSpacing, SeparatorTop,

          Width - FMargin - FSpacing);



      for I := 0 to SysColorCount - 1 do

        DrawCell(I + DefaultColorCount);

    end;



    // Draw custom text

    if Length(FCustomText) > 0 then

      DrawCell(CustomCell);



    if FSelectedIndex = CustomCell then

      DrawCombControls;



    // draw raised window edge (ex-window style WS_EX_WINDOWEDGE is supposed to do this,

    // but for some reason doesn't paint it)

    R := ClientRect;

    DrawEdge(FCanvas.Handle, R, EDGE_RAISED, BF_RECT);

  finally

    FCanvas.Font.Handle := 0; // a stock object never needs to be freed

    FCanvas.Handle := 0;

    if Message.DC = 0 then

      EndPaint(Handle, PS);

  end;

end;



// ------------------------------------------------------------------------------



function TColorPopup.SelectionFromPoint(P: TPoint): Integer;



// determines the button at the given position



begin

  Result := NoCell;



  // first check we aren't in text box

  if (Length(FCustomText) > 0) and PtInRect(FCustomTextRect, P) then

    Result := CustomCell

  else if (Length(FDefaultText) > 0) and PtInRect(FDefaultTextRect, P) then

    Result := DefaultCell

  else

  begin

    // take into account text box

    if Length(FDefaultText) > 0 then

      Dec(P.Y, FDefaultTextRect.Bottom - FDefaultTextRect.Top);



    // Get the row and column

    if P.X > FSpacing then

    begin

      Dec(P.X, FSpacing);

      // take the margin into account, 2 * FMargin is too small while 3 * FMargin

      // is correct, but looks a bit strange (the arrow corner is so small, it isn't

      // really recognized by the eye) hence I took 2.5 * FMargin

      Dec(P.Y, 5 * FMargin div 2);

      if (P.X >= 0) and (P.Y >= 0) then

      begin

        // consider system colors

        if FShowSysColors and ((P.Y div FBoxSize) >= FRowCount) then

        begin

          // here we know the point is out of the default color area, so

          // take the separator line between default and system colors into account

          Dec(P.Y, 3 * FMargin);

          // if we now are back in the default area then the point was originally

          // between both areas and we have therefore to reject a hit

          if (P.Y div FBoxSize) < FRowCount then

            Exit;

        end;

        Result := GetIndex(P.Y div FBoxSize, P.X div FBoxSize);

      end;

    end;

  end;

end;



// ------------------------------------------------------------------------------



function TColorPopup.HandleSlider(const Message: TWMMouse): Boolean;



// determines whether the mouse position is within the slider area (result is then True

// else False) and acts accordingly



var

  Shift: TShiftState;

  dY: Integer;

  R: TRect;



begin

  Result := PtInRect(FSliderRect, Point(Message.XPos, Message.YPos)) and

    (FSelectionMode = smNone) or ((Message.XPos >= FSliderRect.Left) and

    (Message.XPos <= FSliderRect.Right) and (FSelectionMode = smRamp));

  if Result then

  begin

    Shift := KeysToShiftState(Message.Keys);

    if ssLeft in Shift then

    begin

      FSelectionMode := smRamp;

      // left mouse button pressed -> change the intensity of the center color comb

      dY := FSliderRect.Bottom - FSliderRect.Top;

      FCenterIntensity := 1 - (Message.YPos - FSliderRect.Top) / dY;

      if FCenterIntensity < 0 then

        FCenterIntensity := 0;

      if FCenterIntensity > 1 then

        FCenterIntensity := 1;

      FCenterColor.Red := DefCenterColor.Red * FCenterIntensity;

      FCenterColor.Green := DefCenterColor.Green * FCenterIntensity;

      FCenterColor.Blue := DefCenterColor.Blue * FCenterIntensity;

      R := FSliderRect;

      Dec(R.Top, 3);

      Inc(R.Bottom, 3);

      Inc(R.Left, 10);

      InvalidateRect(Handle, @R, False);

      FColorCombs := nil;

      InvalidateRect(Handle, @FColorCombRect, False);

      InvalidateRect(Handle, @FCustomColorRect, False);

      UpdateWindow(Handle);

    end;

  end;

end;



// ------------------------------------------------------------------------------



function TColorPopup.PtInComb(Comb: TCombEntry; P: TPoint;

  Scale: Integer): Boolean;



// simplyfied "PointInPolygon" test, we know a comb is "nearly" a circle...



begin

  Result := (Sqr(Comb.Position.X - P.X) + Sqr(Comb.Position.Y - P.Y)) <=

    (Scale * Scale);

end;



// ------------------------------------------------------------------------------



function TColorPopup.FindBWArea(X, Y: Integer): Integer;



// Looks for a comb at position (X, Y) in the black&white area.

// Result is -1 if nothing could be found else the index of the particular comb

// into FBWCombs.



var

  I: Integer;

  Pt: TPoint;

  Scale: Integer;



begin

  Result := -1;

  Pt := Point(X - FBWCombRect.Left, Y - FBWCombRect.Top);



  for I := 0 to High(FBWCombs) do

  begin

    if I in [0, High(FBWCombs)] then

      Scale := FCombSize

    else

      Scale := FCombSize div 2;

    if PtInComb(FBWCombs[I], Pt, Scale) then

    begin

      Result := I;

      Break;

    end;

  end;

end;



// ------------------------------------------------------------------------------



function TColorPopup.HandleBWArea(const Message: TWMMouse): Boolean;



// determines whether the mouse position is within the B&W comb area (result is then True

// else False) and acts accordingly



var

  Index: Integer;

  Shift: TShiftState;



begin

  Result := PtInRect(FBWCombRect, Point(Message.XPos, Message.YPos)) and

    (FSelectionMode in [smNone, smBW]);

  if Result then

  begin

    Shift := KeysToShiftState(Message.Keys);

    if ssLeft in Shift then

    begin

      FSelectionMode := smBW;

      Index := FindBWArea(Message.XPos, Message.YPos);



      if Index > -1 then

      begin

        // remove selection comb if it was previously in color comb

        if FCustomIndex > 0 then

          InvalidateRect(Handle, @FColorCombRect, False);

        if FCustomIndex <> -(Index + 1) then

        begin

          FCustomIndex := -(Index + 1);

          InvalidateRect(Handle, @FBWCombRect, False);

          InvalidateRect(Handle, @FCustomColorRect, False);

          UpdateWindow(Handle);

        end;

      end

      else

        Result := False;

    end;

  end;

end;



// ------------------------------------------------------------------------------



function TColorPopup.FindColorArea(X, Y: Integer): Integer;



// Looks for a comb at position (X, Y) in the custom color area.

// Result is -1 if nothing could be found else the index of the particular comb

// into FColorCombs.



var

  I: Integer;

  Pt: TPoint;



begin

  Result := -1;

  Pt := Point(X - (FRadius + FColorCombRect.Left),

    Y - (FRadius + FColorCombRect.Top));



  for I := 0 to High(FColorCombs) do

  begin

    if PtInComb(FColorCombs[I], Pt, FCombSize div 2) then

    begin

      Result := I;

      Break;

    end;

  end;

end;



// ------------------------------------------------------------------------------



function TColorPopup.HandleColorComb(const Message: TWMMouse): Boolean;



// determines whether the mouse position is within the color comb area (result is then True

// else False) and acts accordingly



var

  Index: Integer;

  Shift: TShiftState;



begin

  Result := PtInRect(FColorCombRect, Point(Message.XPos, Message.YPos)) and

    (FSelectionMode in [smNone, smColor]);

  if Result then

  begin

    Shift := KeysToShiftState(Message.Keys);

    if ssLeft in Shift then

    begin

      FSelectionMode := smColor;

      Index := FindColorArea(Message.XPos, Message.YPos);

      if Index > -1 then

      begin

        // remove selection comb if it was previously in b&w comb

        if FCustomIndex < 0 then

          InvalidateRect(Handle, @FBWCombRect, False);

        if FCustomIndex <> (Index + 1) then

        begin

          FCustomIndex := Index + 1;

          InvalidateRect(Handle, @FColorCombRect, False);

          InvalidateRect(Handle, @FCustomColorRect, False);

          UpdateWindow(Handle);

        end;

      end

      else

        Result := False;

    end;

  end;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.HandleCustomColors(var Message: TWMMouse);



begin

  if not HandleSlider(Message) then

    if not HandleBWArea(Message) then

      if not HandleColorComb(Message) then

      begin

        // user has clicked somewhere else, so remove last custom selection

        if FCustomIndex > 0 then

          InvalidateRect(Handle, @FColorCombRect, False)

        else if FCustomIndex < 0 then

          InvalidateRect(Handle, @FBWCombRect, False);



        InvalidateRect(Handle, @FCustomColorRect, False);

        FCustomIndex := 0;

        UpdateWindow(Handle);

      end;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.WMMouseMove(var Message: TWMMouseMove);



var

  NewSelection: Integer;



begin

  inherited;

  // determine new hover index

  NewSelection := SelectionFromPoint(Point(Message.XPos, Message.YPos));



  if NewSelection <> FHoverIndex then

    ChangeHoverSelection(NewSelection);

  if (NewSelection = -1) and PtInRect(ClientRect,

    Point(Message.XPos, Message.YPos)) and (csLButtonDown in ControlState) then

    HandleCustomColors(Message);

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.WMLButtonDown(var Message: TWMLButtonDown);



begin

  inherited;



  if PtInRect(ClientRect, Point(Message.XPos, Message.YPos)) then

  begin



    if FHoverIndex <> NoCell then

    begin

      InvalidateCell(FHoverIndex);

      UpdateWindow(Handle);

    end;



    if FHoverIndex = -1 then

      HandleCustomColors(Message);

  end

  else

    EndSelection(True); // hide popup window if the user has clicked elsewhere

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.ShowPopupAligned;



var

  Pt: TPoint;

  Parent: TColorPickerButton;

  ParentTop: Integer;

  R: TRect;

  H: Integer;



begin

  HandleNeeded;

  if FSelectedIndex = CustomCell then

  begin

    // make room for the custem color picking area

    R := Rect(FWindowRect.Left, FWindowRect.Bottom - 3, FWindowRect.Right,

      FWindowRect.Bottom);

    H := FBWCombRect.Bottom + 2 * FMargin;

  end

  else

  begin

    // hide the custem color picking area

    R := Rect(FWindowRect.Left, FWindowRect.Bottom - 3, FWindowRect.Right,

      FWindowRect.Bottom);

    H := FWindowRect.Bottom;

  end;

  // to ensure the window frame is drawn correctly we invalidate the lower bound explicitely

  InvalidateRect(Handle, @R, True);



  // Make sure the window is still entirely visible and aligned.

  // There's no VCL parent window as this popup is a child of the desktop,

  // but we have the owner and get the parent from this.

  Parent := TColorPickerButton(Owner);

  Pt := Parent.Parent.ClientToScreen(Point(Parent.Left - 1,

    Parent.Top + Parent.Height));

  if (Pt.Y + H) > Screen.Height then

    Pt.Y := Screen.Height - H;

  ParentTop := Parent.Parent.ClientToScreen(Point(Parent.Left, Parent.Top)).Y;

  if Pt.Y < ParentTop then

    Pt.Y := ParentTop - H;

  if (Pt.X + Width) > Screen.Width then

    Pt.X := Screen.Width - Width;

  if Pt.X < 0 then

    Pt.X := 0;

  SetWindowPos(Handle, HWND_TOPMOST, Pt.X, Pt.Y, FWindowRect.Right, H,

    SWP_SHOWWINDOW);

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.ChangeSelection(NewSelection: Integer);



begin

  if NewSelection <> NoCell then

  begin

    if FSelectedIndex <> NoCell then

      InvalidateCell(FSelectedIndex);

    FSelectedIndex := NewSelection;

    if FSelectedIndex <> NoCell then

      InvalidateCell(FSelectedIndex);



    if FSelectedIndex = CustomCell then

      ShowPopupAligned;

  end;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.WMLButtonUp(var Message: TWMLButtonUp);



var

  NewSelection: Integer;

  LastMode: TSelectionMode;



begin

  inherited;

  // determine new selection index

  NewSelection := SelectionFromPoint(Point(Message.XPos, Message.YPos));

  LastMode := FSelectionMode;

  FSelectionMode := smNone;

  if (NewSelection <> NoCell) or ((FSelectedIndex = CustomCell) and

    (FCustomIndex <> 0)) then

  begin

    ChangeSelection(NewSelection);

    if ((FSelectedIndex = CustomCell) and (LastMode in [smColor, smBW])) or

      (FSelectedIndex <> NoCell) and (FSelectedIndex <> CustomCell) then

      EndSelection(False)

    else

      SetCapture(TColorPickerButton(Owner).FPopupWnd);

  end

  else

    // we need to restore the mouse capturing, else the utility window will loose it

    // (safety feature of Windows?)

    SetCapture(TColorPickerButton(Owner).FPopupWnd);

end;



// ------------------------------------------------------------------------------



function TColorPopup.GetIndex(Row, Col: Integer): Integer;



begin

  Result := NoCell;

  if ((Row = CustomCell) or (Col = CustomCell)) and (Length(FCustomText) > 0)

  then

    Result := CustomCell

  else if ((Row = DefaultCell) or (Col = DefaultCell)) and

    (Length(FDefaultText) > 0) then

    Result := DefaultCell

  else if (Col in [0 .. FColumnCount - 1]) and (Row >= 0) then

  begin



    if Row < FRowCount then

    begin

      Result := Row * FColumnCount + Col;

      // consider not fully filled last row

      if Result >= DefaultColorCount then

        Result := NoCell;

    end

    else if FShowSysColors then

    begin

      Dec(Row, FRowCount);

      if Row < FSysRowCount then

      begin

        Result := Row * FColumnCount + Col;

        // consider not fully filled last row

        if Result >= SysColorCount then

          Result := NoCell

        else

          Inc(Result, DefaultColorCount);

      end;

    end;

  end;

end;



// ------------------------------------------------------------------------------



function TColorPopup.GetRow(Index: Integer): Integer;



begin

  if (Index = CustomCell) and (Length(FCustomText) > 0) then

    Result := CustomCell

  else if (Index = DefaultCell) and (Length(FDefaultText) > 0) then

    Result := DefaultCell

  else

    Result := Index div FColumnCount;

end;



// ------------------------------------------------------------------------------



function TColorPopup.GetColumn(Index: Integer): Integer;



begin

  if (Index = CustomCell) and (Length(FCustomText) > 0) then

    Result := CustomCell

  else if (Index = DefaultCell) and (Length(FDefaultText) > 0) then

    Result := DefaultCell

  else

    Result := Index mod FColumnCount;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.SelectColor(Color: TColor);



// looks up the given color in our lists and sets the proper indices



var

  I: Integer;

  C: COLORREF;

  found: Boolean;



begin

  found := False;



  // handle special colors first

  if Color = clNone then

    FSelectedIndex := NoCell

  else if Color = clDefault then

    FSelectedIndex := DefaultCell

  else

  begin

    // if the incoming color is one of the predefined colors (clBtnFace etc.) and

    // system colors are active then start looking in the system color list

    if FShowSysColors and (Color < 0) then

    begin

      for I := 0 to SysColorCount - 1 do

        if TColor(SysColors[I].Color) = Color then

        begin

          FSelectedIndex := I + DefaultColorCount;

          found := True;

          Break;

        end;

    end;



    if not found then

    begin

      C := ColorToRGB(Color);

      for I := 0 to DefaultColorCount - 1 do

        // only Borland knows why the result of ColorToRGB is Longint not COLORREF,

        // in order to make the compiler quiet I need a Longint cast here

        if ColorToRGB(DefaultColors[I].Color) = Longint(C) then

        begin

          FSelectedIndex := I;

          found := True;

          Break;

        end;



      // look in the system colors if not already done yet

      if not found and FShowSysColors and (Color >= 0) then

      begin

        for I := 0 to SysColorCount - 1 do

        begin

          if ColorToRGB(TColor(SysColors[I].Color)) = Longint(C) then

          begin

            FSelectedIndex := I + DefaultColorCount;

            found := True;

            Break;

          end;

        end;

      end;



      if not found then

      begin

        if FColorCombs = nil then

          CalculateCombLayout;

        FCustomIndex := 0;

        FSelectedIndex := NoCell;

        for I := 0 to High(FBWCombs) do

          if FBWCombs[I].Color = C then

          begin

            FSelectedIndex := CustomCell;

            FCustomIndex := -(I + 1);

            found := True;

            Break;

          end;



        if not found then

          for I := 0 to High(FColorCombs) do

            if FColorCombs[I].Color = C then

            begin

              FSelectedIndex := CustomCell;

              FCustomIndex := I + 1;

              Break;

            end;

      end;

    end;

  end;

end;



// ------------------------------------------------------------------------------



function TColorPopup.GetCellRect(Index: Integer; var Rect: TRect): Boolean;



// gets the dimensions of the colour cell given by Index



begin

  Result := False;

  if Index = CustomCell then

  begin

    Rect := FCustomTextRect;

    Result := True;

  end

  else if Index = DefaultCell then

  begin

    Rect := FDefaultTextRect;

    Result := True;

  end

  else if Index >= 0 then

  begin

    Rect.Left := GetColumn(Index) * FBoxSize + FMargin + FSpacing;

    Rect.Top := GetRow(Index) * FBoxSize + 2 * FMargin;



    // move everything down if we are displaying a default text area

    if Length(FDefaultText) > 0 then

      Inc(Rect.Top, FDefaultTextRect.Bottom - 2 * FMargin);



    // move everything further down if we consider syscolors

    if Index >= DefaultColorCount then

      Inc(Rect.Top, 3 * FMargin);



    Rect.Right := Rect.Left + FBoxSize;

    Rect.Bottom := Rect.Top + FBoxSize;



    Result := True;

  end;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.AdjustWindow;



// works out an appropriate size and position of this window



var

  TextSize, DefaultSize: TSize;

  DC: HDC;

  WHeight: Integer;



begin

  // If we are showing a custom or default text area, get the font and text size.

  if (Length(FCustomText) > 0) or (Length(FDefaultText) > 0) then

  begin

    DC := GetDC(Handle);

    FCanvas.Handle := DC;

    FCanvas.Font.Handle := GetStockObject(DEFAULT_GUI_FONT);

    try

      // Get the size of the custom text (if there IS custom text)

      TextSize.cx := 0;

      TextSize.cy := 0;

      if Length(FCustomText) > 0 then

        TextSize := FCanvas.TextExtent(FCustomText);



      // Get the size of the default text (if there IS default text)

      if Length(FDefaultText) > 0 then

      begin

        DefaultSize := FCanvas.TextExtent(FDefaultText);

        if DefaultSize.cx > TextSize.cx then

          TextSize.cx := DefaultSize.cx;

        if DefaultSize.cy > TextSize.cy then

          TextSize.cy := DefaultSize.cy;

      end;



      Inc(TextSize.cx, 2 * FMargin);

      Inc(TextSize.cy, 4 * FMargin + 2);



    finally

      FCanvas.Font.Handle := 0;

      FCanvas.Handle := 0;

      ReleaseDC(Handle, DC);

    end;

  end;



  // Get the number of columns and rows

  FColumnCount := 8;

  FRowCount := DefaultColorCount div FColumnCount;

  if (DefaultColorCount mod FColumnCount) <> 0 then

    Inc(FRowCount);



  FWindowRect := Rect(0, 0, FColumnCount * FBoxSize + 2 * FMargin + 2 *

    FSpacing, FRowCount * FBoxSize + 4 * FMargin);



  FRadius := Trunc(7 * (FColumnCount * FBoxSize) / 16);

  FCombSize := Round(0.5 + FRadius / (FLevels - 1));



  // if default text, then expand window if necessary, and set text width as

  // window width

  if Length(FDefaultText) > 0 then

  begin

    if TextSize.cx > (FWindowRect.Right - FWindowRect.Left) then

      FWindowRect.Right := FWindowRect.Left + TextSize.cx;

    TextSize.cx := FWindowRect.Right - FWindowRect.Left - 2 * FMargin;



    // work out the text area

    FDefaultTextRect := Rect(FMargin + FSpacing, 2 * FMargin,

      FMargin - FSpacing + TextSize.cx, 2 * FMargin + TextSize.cy);

    Inc(FWindowRect.Bottom, FDefaultTextRect.Bottom - FDefaultTextRect.Top + 2

      * FMargin);

  end;



  if FShowSysColors then

  begin

    FSysRowCount := SysColorCount div FColumnCount;

    if (SysColorCount mod FColumnCount) <> 0 then

      Inc(FSysRowCount);

    Inc(FWindowRect.Bottom, FSysRowCount * FBoxSize + 2 * FMargin);

  end;



  // if custom text, then expand window if necessary, and set text width as

  // window width

  if Length(FCustomText) > 0 then

  begin

    if TextSize.cx > (FWindowRect.Right - FWindowRect.Left) then

      FWindowRect.Right := FWindowRect.Left + TextSize.cx;

    TextSize.cx := FWindowRect.Right - FWindowRect.Left - 2 * FMargin;



    // work out the text area

    WHeight := FWindowRect.Bottom - FWindowRect.Top;

    FCustomTextRect := Rect(FMargin + FSpacing, WHeight,

      FMargin - FSpacing + TextSize.cx, WHeight + TextSize.cy);

    // precalculate also the small preview box for custom color selection for fast updates

    FCustomColorRect := Rect(0, 0, FBoxSize, FBoxSize);

    InflateRect(FCustomColorRect, -(FMargin + 1), -(FMargin + 1));

    OffsetRect(FCustomColorRect, FCustomTextRect.Right - FBoxSize - FMargin,

      FCustomTextRect.Top + (FCustomTextRect.Bottom - FCustomTextRect.Top -

      FCustomColorRect.Bottom - FMargin - 1) div 2);



    Inc(FWindowRect.Bottom, FCustomTextRect.Bottom - FCustomTextRect.Top + 2

      * FMargin);

  end;



  // work out custom color choice area (color combs) (FWindowRect covers only the always visible part)

  FColorCombRect := Rect(FMargin + FSpacing, FWindowRect.Bottom,

    FMargin + FSpacing + 2 * FRadius, FWindowRect.Bottom + 2 * FRadius);

  // work out custom color choice area (b&w combs)

  FBWCombRect := Rect(FColorCombRect.Left, FColorCombRect.Bottom - 4,

    Round(17 * FCombSize * cos(Pi / 6) / 2) + 6 * FCombSize,

    FColorCombRect.Bottom + 2 * FCombSize);

  // work out slider area

  FSliderRect := Rect(FColorCombRect.Right, FColorCombRect.Top + FCombSize,

    FColorCombRect.Right + 20, FColorCombRect.Bottom - FCombSize);



  // set the window size

  with FWindowRect do

    SetBounds(Left, Top, Right - Left, Bottom - Top);

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.ChangeHoverSelection(Index: Integer);



begin

  if not FShowSysColors and (Index >= DefaultColorCount) or

    (Index >= (DefaultColorCount + SysColorCount)) then

    Index := NoCell;



  // remove old hover selection

  InvalidateCell(FHoverIndex);



  FHoverIndex := Index;

  InvalidateCell(FHoverIndex);

  UpdateWindow(Handle);

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.EndSelection(Cancel: Boolean);



begin

  with Owner as TColorPickerButton do

  begin

    if not Cancel then

    begin

      if FSelectedIndex > -1 then

        if FSelectedIndex < DefaultColorCount then

          SelectionColor := TColor(DefaultColors[FSelectedIndex].Color)

        else

          SelectionColor :=

            TColor(SysColors[FSelectedIndex - DefaultColorCount].Color)

      else if FSelectedIndex = CustomCell then

      begin

        if FCustomIndex < 0 then

          SelectionColor := FBWCombs[-(FCustomIndex + 1)].Color

        else if FCustomIndex > 0 then

          SelectionColor := FColorCombs[FCustomIndex - 1].Color;

      end

      else

        DoDefaultEvent;

    end;

    DroppedDown := False;

  end;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.WMKillFocus(var Message: TWMKillFocus);



begin

  inherited;

  (Owner as TColorPickerButton).DroppedDown := False;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.CalculateCombLayout;



// fills arrays with centers and colors for the custom color and black & white combs,

// these arrays are used to quickly draw the combx and do hit tests



// --------------- local functions -----------------------



  function RGBFromFloat(Color: TRGB): COLORREF;



  begin

    Result := RGB(Round(255 * Color.Red), Round(255 * Color.Green),

      Round(255 * Color.Blue));

  end;



// -------------------------------------------------------



  function GrayFromIntensity(Intensity: Byte): COLORREF;



  begin

    Result := RGB(Intensity, Intensity, Intensity);

  end;



// --------------- end local functions -------------------



var

  CurrentIndex: Cardinal;

  CurrentColor: TRGB;

  CurrentPos: TFloatPoint;

  CombCount: Cardinal;

  I, J, Level: Cardinal;

  Scale: Extended;



  // triangle vars

  Pos1, Pos2: TFloatPoint;

  dPos1, dPos2: TFloatPoint;

  Color1, Color2: TRGB;

  dColor1, dColor2: TRGB;

  dPos: TFloatPoint;

  dColor: TRGB;



begin

  // this ensures the radius and comb size is set correctly

  HandleNeeded;

  if FLevels < 1 then

    FLevels := 1;

  // To draw perfectly aligned combs we split the final comb into six triangles (sextants)

  // and calculate each separately. The center comb is stored as first entry in the array

  // and will not considered twice (as with the other shared combs too).

  //

  // The way used here for calculation of the layout seems a bit complicated, but works

  // correctly for all cases (even if the comb corners are rotated).



  // initialization

  CurrentIndex := 0;

  CurrentColor := FCenterColor;



  // number of combs can be calculated by:

  // 1 level: 1 comb (the center)

  // 2 levels: 1 comb + 6 combs

  // 3 levels: 1 comb + 1 * 6 combs + 2 * 6 combs

  // n levels: 1 combs + 1 * 6 combs + 2 * 6 combs + .. + (n-1) * 6 combs

  // this equals to 1 + 6 * (1 + 2 + 3 + .. + (n-1)), by using Gauss' famous formula we get:

  // Count = 1 + 6 * (((n-1) * n) / 2)

  // Because there's always an even number involved (either n or n-1) we can use an integer div

  // instead of a float div here...

  CombCount := 1 + 6 * (((FLevels - 1) * FLevels) div 2);

  SetLength(FColorCombs, CombCount);



  // store center values

  FColorCombs[CurrentIndex].Position := Point(0, 0);

  FColorCombs[CurrentIndex].Color := RGBFromFloat(CurrentColor);

  Inc(CurrentIndex);



  // go out off here if there are not further levels to draw

  if FLevels < 2 then

    Exit;



  // now go for each sextant, the generic corners have been calculated already at creation

  // time for a comb with diameter 1

  // ------

  // /\  1 /\

  // /  \  /  \

  // / 2  \/  0 \

  // -----------

  // \ 3  /\  5 /

  // \  /  \  /

  // \/  4 \/

  // ------



  for I := 0 to 5 do

  begin

    // initialize triangle corner values

    //

    // center (always at 0,0)

    // /\

    // dPos1      /  \    dPos2

    // dColor1   /    \   dColor2

    // / dPos \

    // /--------\ (span)

    // /  dColor  \

    // /____________\

    // comb corner 1     comb corner 2

    //

    // Pos1, Pos2, Color1, Color2 are running terms for both sides of the triangle

    // incremented by dPos1/2 and dColor1/2.

    // dPos and dColor are used to interpolate a span between the values just mentioned.

    //

    // The small combs are actually oriented with corner 0 at top (i.e. mirrored at y = x,

    // compared with the values in FCombCorners), we can achieve that by simply exchanging

    // X and Y values.



    Scale := 2 * FRadius * cos(Pi / 6);

    Pos1.X := FCombCorners[I].Y * Scale;

    Pos1.Y := FCombCorners[I].X * Scale;

    Color1 := DefColors[I];

    if I = 5 then

    begin

      Pos2.X := FCombCorners[0].Y * Scale;

      Pos2.Y := FCombCorners[0].X * Scale;

      Color2 := DefColors[0];

    end

    else

    begin

      Pos2.X := FCombCorners[I + 1].Y * Scale;

      Pos2.Y := FCombCorners[I + 1].X * Scale;

      Color2 := DefColors[I + 1];

    end;

    dPos1.X := Pos1.X / (FLevels - 1);

    dPos1.Y := Pos1.Y / (FLevels - 1);

    dPos2.X := Pos2.X / (FLevels - 1);

    dPos2.Y := Pos2.Y / (FLevels - 1);



    dColor1.Red := (Color1.Red - FCenterColor.Red) / (FLevels - 1);

    dColor1.Green := (Color1.Green - FCenterColor.Green) / (FLevels - 1);

    dColor1.Blue := (Color1.Blue - FCenterColor.Blue) / (FLevels - 1);



    dColor2.Red := (Color2.Red - FCenterColor.Red) / (FLevels - 1);

    dColor2.Green := (Color2.Green - FCenterColor.Green) / (FLevels - 1);

    dColor2.Blue := (Color2.Blue - FCenterColor.Blue) / (FLevels - 1);



    Pos1 := DefCenter;

    Pos2 := DefCenter;

    Color1 := FCenterColor;

    Color2 := FCenterColor;



    // Now that we have finished the initialization for this step we'll go

    // through a loop for each level to calculate the spans.

    // We can ignore level 0 (as this is the center we already have determined) as well

    // as the last step of each span (as this is the start value in the next triangle and will

    // be calculated there). We have, though, take them into the calculation of the running terms.

    for Level := 0 to FLevels - 1 do

    begin

      if Level > 0 then

      begin

        // initialize span values

        dPos.X := (Pos2.X - Pos1.X) / Level;

        dPos.Y := (Pos2.Y - Pos1.Y) / Level;

        dColor.Red := (Color2.Red - Color1.Red) / Level;

        dColor.Green := (Color2.Green - Color1.Green) / Level;

        dColor.Blue := (Color2.Blue - Color1.Blue) / Level;

        CurrentPos := Pos1;

        CurrentColor := Color1;



        for J := 0 to Level - 1 do

        begin

          // store current values in the array

          FColorCombs[CurrentIndex].Position.X := Round(CurrentPos.X);

          FColorCombs[CurrentIndex].Position.Y := Round(CurrentPos.Y);

          FColorCombs[CurrentIndex].Color := RGBFromFloat(CurrentColor);

          Inc(CurrentIndex);



          // advance in span

          CurrentPos.X := CurrentPos.X + dPos.X;

          CurrentPos.Y := CurrentPos.Y + dPos.Y;



          CurrentColor.Red := CurrentColor.Red + dColor.Red;

          CurrentColor.Green := CurrentColor.Green + dColor.Green;

          CurrentColor.Blue := CurrentColor.Blue + dColor.Blue;

        end;

      end;

      // advance running terms

      Pos1.X := Pos1.X + dPos1.X;

      Pos1.Y := Pos1.Y + dPos1.Y;

      Pos2.X := Pos2.X + dPos2.X;

      Pos2.Y := Pos2.Y + dPos2.Y;



      Color1.Red := Color1.Red + dColor1.Red;

      Color1.Green := Color1.Green + dColor1.Green;

      Color1.Blue := Color1.Blue + dColor1.Blue;



      Color2.Red := Color2.Red + dColor2.Red;

      Color2.Green := Color2.Green + dColor2.Green;

      Color2.Blue := Color2.Blue + dColor2.Blue;

    end;

  end;



  // second step is to build a list for the black & white area

  // 17 entries from pure white to pure black

  // the first and last are implicitely of double comb size

  SetLength(FBWCombs, 17);

  CurrentIndex := 0;

  FBWCombs[CurrentIndex].Color := GrayFromIntensity(255);

  FBWCombs[CurrentIndex].Position := Point(FCombSize, FCombSize);

  Inc(CurrentIndex);



  CurrentPos.X := 3 * FCombSize;

  CurrentPos.Y := 3 * (FCombSize div 4);

  dPos.X := Round(FCombSize * cos(Pi / 6) / 2);

  dPos.Y := Round(FCombSize * (1 + sin(Pi / 6)) / 2);

  for I := 0 to 14 do

  begin

    FBWCombs[CurrentIndex].Color := GrayFromIntensity((16 - CurrentIndex) * 15);

    if Odd(I) then

      FBWCombs[CurrentIndex].Position := Point(Round(CurrentPos.X + I * dPos.X),

        Round(CurrentPos.Y + dPos.Y))

    else

      FBWCombs[CurrentIndex].Position := Point(Round(CurrentPos.X + I * dPos.X),

        Round(CurrentPos.Y));

    Inc(CurrentIndex);

  end;

  FBWCombs[CurrentIndex].Color := 0;

  FBWCombs[CurrentIndex].Position :=

    Point(Round(CurrentPos.X + 16 * dPos.X + FCombSize), FCombSize);

end;



// -----------------------------------------------------------------------------



procedure TColorPopup.CreateParams(var Params: TCreateParams);



begin

  inherited CreateParams(Params);

  with Params do

  begin

    WndParent := GetDesktopWindow;

    Style := WS_CLIPSIBLINGS or WS_CHILD;

    ExStyle := WS_EX_TOPMOST or WS_EX_TOOLWINDOW;

    WindowClass.Style := CS_DBLCLKS or CS_SAVEBITS;

  end;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.CreateWnd;



begin

  inherited;

  AdjustWindow;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.SetSpacing(Value: Integer);



begin

  if Value < 0 then

    Value := 0;

  if FSpacing <> Value then

  begin

    FSpacing := Value;

    Invalidate;

  end;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.InvalidateCell(Index: Integer);



var

  R: TRect;



begin

  if GetCellRect(Index, R) then

    InvalidateRect(Handle, @R, False);

end;



// ------------------------------------------------------------------------------



function TColorPopup.GetHint(Cell: Integer): String;



begin

  Result := '';

  if Assigned(TColorPickerButton(Owner).FOnHint) then

    TColorPickerButton(Owner).FOnHint(Owner, Cell, Result);

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.CMHintShow(var Message: TMessage);



// determine hint message (tooltip) and out-of-hint rect



var

  Index: Integer;

  R, G, B: Byte;

  Colors: TCombArray;



begin

  Colors := nil;

  with TCMHintShow(Message) do

  begin

    if not TColorPickerButton(Owner).ShowHint then

      Message.Result := 1

    else

    begin

      with HintInfo^ do

      begin

        // show that we want a hint

        Result := 0;

        // predefined colors always get their names as tooltip

        if FHoverIndex >= 0 then

        begin

          GetCellRect(FHoverIndex, CursorRect);

          if FHoverIndex < DefaultColorCount then

            HintStr := DefaultColors[FHoverIndex].Name

          else

            HintStr := SysColors[FHoverIndex - DefaultColorCount].Name;

        end

        else

          // both special cells get their hint either from the application by

          // means of the OnHint event or the hint string of the owner control

          if (FHoverIndex = DefaultCell) or (FHoverIndex = CustomCell) then

          begin

            HintStr := GetHint(FHoverIndex);

            if HintStr = '' then

              HintStr := TColorPickerButton(Owner).Hint

            else

            begin

              // if the application supplied a hint by event then deflate the cursor rect

              // to the belonging button

              if FHoverIndex = DefaultCell then

                CursorRect := FDefaultTextRect

              else

                CursorRect := FCustomTextRect;

            end;

          end

          else

          begin

            // well, mouse is not hovering over one of the buttons, now check for

            // the ramp and the custom color areas

            if PtInRect(FSliderRect, Point(CursorPos.X, CursorPos.Y)) then

            begin

              // in case of the intensity slider we show the current intensity

              HintStr := Format('Intensity: %d%%',

                [Round(100 * FCenterIntensity)]);

              CursorRect := Rect(FSliderRect.Left, CursorPos.Y - 2,

                FSliderRect.Right, CursorPos.Y + 2);

              HintPos := ClientToScreen(Point(FSliderRect.Right,

                CursorPos.Y - 8));

              HideTimeout := 5000;

              CursorRect := Rect(FSliderRect.Left, CursorPos.Y,

                FSliderRect.Right, CursorPos.Y);

            end

            else

            begin

              Index := -1;

              if PtInRect(FBWCombRect, Point(CursorPos.X, CursorPos.Y)) then

              begin

                // considering black&white area...

                if csLButtonDown in ControlState then

                  Index := -(FCustomIndex + 1)

                else

                  Index := FindBWArea(CursorPos.X, CursorPos.Y);

                Colors := FBWCombs;

              end

              else if PtInRect(FColorCombRect, Point(CursorPos.X, CursorPos.Y))

              then

              begin

                // considering color comb area...

                if csLButtonDown in ControlState then

                  Index := FCustomIndex - 1

                else

                  Index := FindColorArea(CursorPos.X, CursorPos.Y);

                Colors := FColorCombs;

              end;



              if (Index > -1) and (Colors <> nil) then

              begin

                with Colors[Index] do

                begin

                  R := GetRValue(Color);

                  G := GetGValue(Color);

                  B := GetBValue(Color);

                end;

                HintStr := Format('red: %d, green: %d, blue: %d', [R, G, B]);

                HideTimeout := 5000;

              end

              else

                HintStr := GetHint(NoCell);



              // make the hint follow the mouse

              CursorRect := Rect(CursorPos.X, CursorPos.Y, CursorPos.X,

                CursorPos.Y);

            end;

          end;

      end;

    end;

  end;

end;



// ------------------------------------------------------------------------------



procedure TColorPopup.SetSelectedColor(const Value: TColor);



begin

  FCurrentColor := Value;

  SelectColor(Value);

end;



// ----------------- TColorPickerButton ------------------------------------------



constructor TColorPickerButton.Create(AOwner: TComponent);



begin

  inherited Create(AOwner);

  FSelectionColor := clBlack;

  FColorPopup := TColorPopup.Create(Self);

  // park the window somewhere it can't be seen

  FColorPopup.Left := -1000;

  FPopupWnd := AllocateHWnd(PopupWndProc);



  FGlyph := TButtonGlyph.Create;

  TButtonGlyph(FGlyph).OnChange := GlyphChanged;

  SetBounds(0, 0, 45, 22);

  FDropDownWidth := 15;

  ControlStyle := [csCaptureMouse, csDoubleClicks];

  ParentFont := True;

  Color := clBtnFace;

  FSpacing := 4;

  FMargin := -1;

  FLayout := blGlyphLeft;

  FTransparent := True;

  FIndicatorBorder := ibFlat;



  Inc(ButtonCount);

end;



// -----------------------------------------------------------------------------



destructor TColorPickerButton.Destroy;



begin

  DeallocateHWnd(FPopupWnd);

  Dec(ButtonCount);

  // the color popup window will automatically be freed since the button is the owner

  // of the popup

  TButtonGlyph(FGlyph).Free;

  inherited Destroy;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.PopupWndProc(var Msg: TMessage);



var

  P: TPoint;



begin

  case Msg.Msg of

    WM_MOUSEFIRST .. WM_MOUSELAST:

      begin

        with TWMMouse(Msg) do

        begin

          P := SmallPointToPoint(Pos);

          MapWindowPoints(FPopupWnd, FColorPopup.Handle, P, 1);

          Pos := PointToSmallPoint(P);

        end;

        FColorPopup.WindowProc(Msg);

      end;

    CN_KEYDOWN, CN_SYSKEYDOWN:

      FColorPopup.WindowProc(Msg);

  else

    with Msg do

      Result := DefWindowProc(FPopupWnd, Msg, wParam, lParam);

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetDropDownArrowColor(Value: TColor);



begin

  if not(FDropDownArrowColor = Value) then;

  begin

    FDropDownArrowColor := Value;

    Invalidate;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetDropDownWidth(Value: Integer);



begin

  if not(FDropDownWidth = Value) then;

  begin

    FDropDownWidth := Value;

    Invalidate;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.Paint;



const

  MAX_WIDTH = 5;

  DownStyles: array [Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER);

  FillStyles: array [Boolean] of Integer = (BF_MIDDLE, 0);



var

  PaintRect: TRect;

  ExtraRect: TRect;

  DrawFlags: Integer;

  Offset: TPoint;

  LeftPos: Integer;



begin

  if not Enabled then

  begin

    FState := bsDisabled;

    FDragging := False;

  end

  else if (FState = bsDisabled) then

  begin

    if FDown and (GroupIndex <> 0) then

      FState := bsExclusive

    else

      FState := bsUp;

  end;



  Canvas.Font := Self.Font;



  // Creates a rectangle that represent the button and the drop down area,

  // determines also the position to draw the arrow...

  PaintRect := Rect(0, 0, Width, Height);

  ExtraRect := Rect(Width - FDropDownWidth, 0, Width, Height);

  LeftPos := (Width - FDropDownWidth) + ((FDropDownWidth + MAX_WIDTH) div 2) -

    MAX_WIDTH - 1;



  // Determines if the button is a flat or normal button... each uses

  // different painting methods

  if not FFlat then

  begin

    DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;



    if FState in [bsDown, bsExclusive] then

      DrawFlags := DrawFlags or DFCS_PUSHED;



    // Check if the mouse is in the drop down zone. If it is we then check

    // the state of the button to determine the drawing sequence

    if FDropDownZone then

    begin

      if FDroppedDown then

      begin

        // paint pressed Drop Down Button

        DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DRAW_BUTTON_UP);

        DrawFrameControl(Canvas.Handle, ExtraRect, DFC_BUTTON,

          DRAW_BUTTON_DOWN);

      end

      else

      begin

        // paint depressed Drop Down Button

        DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DRAW_BUTTON_UP);

        DrawFrameControl(Canvas.Handle, ExtraRect, DFC_BUTTON, DRAW_BUTTON_UP);

        DrawButtonSeperatorUp(Canvas);

      end;

    end

    else

    begin

      DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags);



      // Determine the type of drop down seperator...

      if (FState in [bsDown, bsExclusive]) then

        DrawButtonSeperatorDown(Canvas)

      else

        DrawButtonSeperatorUp(Canvas);

    end;

  end

  else

  begin

    if (FState in [bsDown, bsExclusive]) or

      (FMouseInControl and (FState <> bsDisabled)) or

      (csDesigning in ComponentState) then

    begin

      // Check if the mouse is in the drop down zone. If it is we then check

      // the state of the button to determine the drawing sequence

      if FDropDownZone then

      begin

        if FDroppedDown then

        begin

          // Paint pressed Drop Down Button

          DrawEdge(Canvas.Handle, PaintRect, DownStyles[False],

            FillStyles[FTransparent] or BF_RECT);

          DrawEdge(Canvas.Handle, ExtraRect, DownStyles[True],

            FillStyles[FTransparent] or BF_RECT);

        end

        else

        begin

          // Paint depressed Drop Down Button

          DrawEdge(Canvas.Handle, PaintRect, DownStyles[False],

            FillStyles[FTransparent] or BF_RECT);

          DrawEdge(Canvas.Handle, ExtraRect, DownStyles[False],

            FillStyles[FTransparent] or BF_RECT);

          DrawButtonSeperatorUp(Canvas);

        end;

      end

      else

      begin

        DrawEdge(Canvas.Handle, PaintRect,

          DownStyles[FState in [bsDown, bsExclusive]],

          FillStyles[FTransparent] or BF_RECT);



        if (FState in [bsDown, bsExclusive]) then

          DrawButtonSeperatorDown(Canvas)

        else

          DrawButtonSeperatorUp(Canvas);

      end;

    end

    else if not FTransparent then

    begin

      Canvas.Brush.Style := bsSolid;

      Canvas.Brush.Color := Color;

      Canvas.FillRect(PaintRect);

    end;

    InflateRect(PaintRect, -1, -1);

  end;



  if (FState in [bsDown, bsExclusive]) and not(FDropDownZone) then

  begin

    if (FState = bsExclusive) and (not FFlat or not FMouseInControl) then

    begin

      Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight);

      Canvas.FillRect(PaintRect);

    end;

    Offset.X := 1;

    Offset.Y := 1;

  end

  else

  begin

    Offset.X := 0;

    Offset.Y := 0;

  end;



  PaintRect := TButtonGlyph(FGlyph).Draw(Canvas, PaintRect, Offset, Caption,

    FLayout, FMargin, FSpacing, FState, FTransparent, FDropDownWidth,

    DrawTextBiDiModeFlags(0));



  // draw color indicator

  Canvas.Brush.Color := FSelectionColor;

  Canvas.Pen.Color := clBtnShadow;



  case FIndicatorBorder of

    ibNone:

      Canvas.FillRect(PaintRect);

    ibFlat:

      with PaintRect do

        Canvas.Rectangle(Left, Top, Right, Bottom);

  else

    if FIndicatorBorder = ibSunken then

      DrawEdge(Canvas.Handle, PaintRect, BDR_SUNKENOUTER, BF_RECT)

    else

      DrawEdge(Canvas.Handle, PaintRect, BDR_RAISEDINNER, BF_RECT);

    InflateRect(PaintRect, -1, -1);

    Canvas.FillRect(PaintRect);

  end;



  // Draws the arrow for the correct state

  if FState = bsDisabled then

  begin

    Canvas.Pen.Style := psClear;

    Canvas.Brush.Color := clBtnShadow;

  end

  else

  begin

    Canvas.Pen.Color := FDropDownArrowColor;

    Canvas.Brush.Color := FDropDownArrowColor;

  end;



  if FDropDownZone and FDroppedDown or (FState = bsDown) and not(FDropDownZone)

  then

    DrawTriangle(Canvas, (Height div 2) + 1, LeftPos + 1, MAX_WIDTH)

  else

    DrawTriangle(Canvas, (Height div 2), LeftPos, MAX_WIDTH);

end;





// -----------------------------------------------------------------------------



procedure TColorPickerButton.UpdateTracking;



var

  P: TPoint;



begin

  if FFlat then

  begin

    if Enabled then

    begin

      GetCursorPos(P);

      FMouseInControl := not(FindDragTarget(P, True) = Self);

      if FMouseInControl then

        Perform(CM_MOUSELEAVE, 0, 0)

      else

        Perform(CM_MOUSEENTER, 0, 0);

    end;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.Loaded;



var

  State: TButtonState;



begin

  inherited Loaded;

  if Enabled then

    State := bsUp

  else

    State := bsDisabled;

  TButtonGlyph(FGlyph).CreateButtonGlyph(State);

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.MouseDown(Button: TMouseButton; Shift: TShiftState;

  X, Y: Integer);



begin

  inherited MouseDown(Button, Shift, X, Y);



  if (Button = mbLeft) and Enabled then

  begin

    // Determine if mouse is currently in the drop down section...

    FDropDownZone := (X > Width - FDropDownWidth);



    // If so display the button in the proper state and display the menu

    if FDropDownZone then

    begin

      if not FDroppedDown then

      begin

        Update;

        DroppedDown := True;

      end;



      // Setting this flag to false is very important, we want the dsUp state to

      // be used to display the button properly the next time the mouse moves in

      FDragging := False;

    end

    else

    begin

      if not FDown then

      begin

        FState := bsDown;

        Invalidate;

      end;



      FDragging := True;

    end;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.MouseMove(Shift: TShiftState; X, Y: Integer);



var

  NewState: TButtonState;



begin

  inherited MouseMove(Shift, X, Y);

  if FDragging then

  begin

    if not FDown then

      NewState := bsUp

    else

      NewState := bsExclusive;

    if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then

      if FDown then

        NewState := bsExclusive

      else

        NewState := bsDown;

    if NewState <> FState then

    begin

      FState := NewState;

      Invalidate;

    end;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.MouseUp(Button: TMouseButton; Shift: TShiftState;

  X, Y: Integer);



var

  DoClick: Boolean;



begin

  inherited MouseUp(Button, Shift, X, Y);

  if FDragging then

  begin

    FDragging := False;

    DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and

      (Y <= ClientHeight);

    if FGroupIndex = 0 then

    begin

      // Redraw face in case mouse is captured

      FState := bsUp;

      FMouseInControl := False;

      if DoClick and not(FState in [bsExclusive, bsDown]) then

        Invalidate;

    end

    else if DoClick then

    begin

      SetDown(not FDown);

      if FDown then

        Repaint;

    end

    else

    begin

      if FDown then

        FState := bsExclusive;

      Repaint;

    end;

    if DoClick then

      Click;

    UpdateTracking;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.Click;



begin

  inherited Click;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.DoDefaultEvent;



begin

  if Assigned(FOnDefaultSelect) then

    FOnDefaultSelect(Self);

end;



// -----------------------------------------------------------------------------



function TColorPickerButton.GetPalette: HPALETTE;



begin

  Result := Glyph.Palette;

end;



// -----------------------------------------------------------------------------



function TColorPickerButton.GetGlyph: TBitmap;



begin

  Result := TButtonGlyph(FGlyph).Glyph;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetGlyph(Value: TBitmap);



begin

  TButtonGlyph(FGlyph).Glyph := Value;

  Invalidate;

end;



// -----------------------------------------------------------------------------



function TColorPickerButton.GetNumGlyphs: TNumGlyphs;



begin

  Result := TButtonGlyph(FGlyph).NumGlyphs;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.DrawButtonSeperatorUp(Canvas: TCanvas);



begin

  with Canvas do

  begin

    Pen.Style := psSolid;

    Brush.Style := bsClear;

    Pen.Color := clBtnHighlight;

    Rectangle(Width - DropDownWidth, 1, Width - DropDownWidth + 1, Height - 1);

    Pen.Color := clBtnShadow;

    Rectangle(Width - DropDownWidth - 1, 1, Width - DropDownWidth, Height - 1);

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.DrawButtonSeperatorDown(Canvas: TCanvas);



begin

  with Canvas do

  begin

    Pen.Style := psSolid;

    Brush.Style := bsClear;

    Pen.Color := clBtnHighlight;

    Rectangle(Width - DropDownWidth + 1, 2, Width - DropDownWidth + 2,

      Height - 2);

    Pen.Color := clBtnShadow;

    Rectangle(Width - DropDownWidth, 2, Width - DropDownWidth + 1, Height - 2);

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.DrawTriangle(Canvas: TCanvas;

  Top, Left, Width: Integer);



begin

  if Odd(Width) then

    Inc(Width);

  Canvas.Polygon([Point(Left, Top), Point(Left + Width, Top),

    Point(Left + Width div 2, Top + Width div 2)]);

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetNumGlyphs(Value: TNumGlyphs);



begin

  if Value < 0 then

    Value := 1

  else if Value > 4 then

    Value := 4;



  if Value <> TButtonGlyph(FGlyph).NumGlyphs then

  begin

    TButtonGlyph(FGlyph).NumGlyphs := Value;

    Invalidate;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.GlyphChanged(Sender: TObject);



begin

  Invalidate;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.UpdateExclusive;



var

  Msg: TMessage;



begin

  if (FGroupIndex <> 0) and (Parent <> nil) then

  begin

    Msg.Msg := CM_BUTTONPRESSED;

    Msg.wParam := FGroupIndex;

    Msg.lParam := Longint(Self);

    Msg.Result := 0;

    Parent.Broadcast(Msg);

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetDown(Value: Boolean);



begin

  if FGroupIndex = 0 then

    Value := False;

  if Value <> FDown then

  begin

    if FDown and (not FAllowAllUp) then

      Exit;

    FDown := Value;

    if Value then

    begin

      if FState = bsUp then

        Invalidate;

      FState := bsExclusive;

    end

    else

    begin

      FState := bsUp;

      Repaint;

    end;

    if Value then

      UpdateExclusive;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetFlat(Value: Boolean);



begin

  if Value <> FFlat then

  begin

    FFlat := Value;

    if Value then

      ControlStyle := ControlStyle - [csOpaque]

    else

      ControlStyle := ControlStyle + [csOpaque];

    Invalidate;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetGroupIndex(Value: Integer);



begin

  if FGroupIndex <> Value then

  begin

    FGroupIndex := Value;

    UpdateExclusive;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetLayout(Value: TButtonLayout);



begin

  if FLayout <> Value then

  begin

    FLayout := Value;

    Invalidate;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetMargin(Value: Integer);



begin

  if (Value <> FMargin) and (Value >= -1) then

  begin

    FMargin := Value;

    Invalidate;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetSpacing(Value: Integer);



begin

  if Value <> FSpacing then

  begin

    FSpacing := Value;

    Invalidate;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetAllowAllUp(Value: Boolean);



begin

  if FAllowAllUp <> Value then

  begin

    FAllowAllUp := Value;

    UpdateExclusive;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPopup.WMActivateApp(var Message: TWMActivateApp);



begin

  inherited;

  if not Message.Active then

    EndSelection(True);

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.WMLButtonDblClk(var Message: TWMLButtonDown);



begin

  inherited;

  if FDown then

    DblClick;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.CMEnabledChanged(var Message: TMessage);



const

  NewState: array [Boolean] of TButtonState = (bsDisabled, bsUp);



begin

  TButtonGlyph(FGlyph).CreateButtonGlyph(NewState[Enabled]);

  UpdateTracking;

  Repaint;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.CMButtonPressed(var Message: TMessage);



var

  Sender: TColorPickerButton;



begin

  if Message.wParam = FGroupIndex then

  begin

    Sender := TColorPickerButton(Message.lParam);

    if Sender <> Self then

    begin

      if Sender.Down and FDown then

      begin

        FDown := False;

        FState := bsUp;

        Invalidate;

      end;

      FAllowAllUp := Sender.AllowAllUp;

    end;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.CMDialogChar(var Message: TCMDialogChar);



begin

  with Message do

    if IsAccel(CharCode, Caption) and Enabled and Visible and Assigned(Parent)

      and Parent.Showing then

    begin

      Click;

      Result := 1;

    end

    else

      inherited;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.CMFontChanged(var Message: TMessage);



begin

  Invalidate;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.CMTextChanged(var Message: TMessage);



begin

  Invalidate;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.CMSysColorChange(var Message: TMessage);



begin

  with TButtonGlyph(FGlyph) do

  begin

    Invalidate;

    CreateButtonGlyph(FState);

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.CMMouseEnter(var Message: TMessage);



begin

  inherited;

  if FFlat and not FMouseInControl and Enabled then

  begin

    FMouseInControl := True;

    Repaint;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.CMMouseLeave(var Message: TMessage);



begin

  inherited;

  if FFlat and FMouseInControl and Enabled and not FDragging then

  begin

    FMouseInControl := False;

    Invalidate;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetDroppedDown(const Value: Boolean);



var

  Allowed: Boolean;



begin

  if FDroppedDown <> Value then

  begin

    Allowed := True;

    if Assigned(FOnDropChanging) then

      FOnDropChanging(Self, Allowed);

    if Allowed then

    begin

      FDroppedDown := Value;

      if FDroppedDown then

      begin

        FState := bsDown;

        TColorPopup(FColorPopup).SelectedColor := FSelectionColor;

        TColorPopup(FColorPopup).ShowPopupAligned;

        SetCapture(FPopupWnd);

      end

      else

      begin

        FState := bsUp;

        ReleaseCapture;

        ShowWindow(FColorPopup.Handle, SW_HIDE);

      end;

      if Assigned(FOnDropChanged) then

        FOnDropChanged(Self);

      Invalidate;

    end;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetSelectionColor(const Value: TColor);



begin

  if FSelectionColor <> Value then

  begin

    FSelectionColor := Value;

    Invalidate;

    if FDroppedDown then

      TColorPopup(FColorPopup).SelectColor(Value);

    if Assigned(FOnChange) then

      FOnChange(Self);

  end;

end;



// -----------------------------------------------------------------------------



function TColorPickerButton.GetCustomText: String;



begin

  Result := TColorPopup(FColorPopup).FCustomText;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetCustomText(const Value: String);



begin

  with TColorPopup(FColorPopup) do

  begin

    if FCustomText <> Value then

    begin

      FCustomText := Value;

      if (FCustomText = '') and (FSelectedIndex = CustomCell) then

        FSelectedIndex := NoCell;

      AdjustWindow;

      if FDroppedDown then

      begin

        Invalidate;

        ShowPopupAligned;

      end;

    end;

  end;

end;



// -----------------------------------------------------------------------------



function TColorPickerButton.GetDefaultText: String;



begin

  Result := TColorPopup(FColorPopup).FDefaultText;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetDefaultText(const Value: String);



begin

  if TColorPopup(FColorPopup).FDefaultText <> Value then

  begin

    with TColorPopup(FColorPopup) do

    begin

      FDefaultText := Value;

      AdjustWindow;

      if FDroppedDown then

      begin

        Invalidate;

        ShowPopupAligned;

      end;

    end;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetShowSystemColors(const Value: Boolean);



begin

  with TColorPopup(FColorPopup) do

  begin

    if FShowSysColors <> Value then

    begin

      FShowSysColors := Value;

      AdjustWindow;

      if FDroppedDown then

      begin

        Invalidate;

        ShowPopupAligned;

      end;

    end;

  end;

end;



// -----------------------------------------------------------------------------



function TColorPickerButton.GetShowSystemColors: Boolean;



begin

  Result := TColorPopup(FColorPopup).FShowSysColors;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetTransparent(const Value: Boolean);



begin

  if Value <> FTransparent then

  begin

    FTransparent := Value;

    if Value then

      ControlStyle := ControlStyle - [csOpaque]

    else

      ControlStyle := ControlStyle + [csOpaque];

    Invalidate;

  end;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.ActionChange(Sender: TObject;

  CheckDefaults: Boolean);



// --------------- local functions -----------------------



  procedure CopyImage(ImageList: TCustomImageList; Index: Integer);



  begin

    with Glyph do

    begin

      Width := ImageList.Width;

      Height := ImageList.Height;

      Canvas.Brush.Color := clFuchsia; // ! for lack of a better color

      Canvas.FillRect(Rect(0, 0, Width, Height));

      ImageList.Draw(Canvas, 0, 0, Index);

    end;

  end;



// --------------- end local functions -------------------



begin

  inherited ActionChange(Sender, CheckDefaults);

  if Sender is TCustomAction then

    with TCustomAction(Sender) do

    begin

      // Copy image from action's imagelist

      if Glyph.Empty and Assigned(ActionList) and Assigned(ActionList.Images)

        and (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then

        CopyImage(ActionList.Images, ImageIndex);

    end;

end;



// -----------------------------------------------------------------------------



procedure Register;



begin

  RegisterComponents('Tools', [TColorPickerButton]);

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetIndicatorBorder(const Value: TIndicatorBorder);



begin

  if FIndicatorBorder <> Value then

  begin

    FIndicatorBorder := Value;

    Invalidate;

  end;

end;



// -----------------------------------------------------------------------------



function TColorPickerButton.GetPopupSpacing: Integer;



begin

  Result := TColorPopup(FColorPopup).Spacing;

end;



// -----------------------------------------------------------------------------



procedure TColorPickerButton.SetPopupSpacing(const Value: Integer);



begin

  TColorPopup(FColorPopup).Spacing := Value;

end;



// -----------------------------------------------------------------------------



end.

你可能感兴趣的:(button)

JAVA·一个简单的登录窗口 MortalTom java 开发语言学习
文章目录概要整体架构流程技术名词解释技术细节资源概要JavaSwing是Java基础类库的一部分，主要用于开发图形用户界面（GUI）程序整体架构流程新建项目，导入sql.jar包（链接放在了文末），编译项目并运行技术名词解释一、特点丰富的组件提供了多种可视化组件，如按钮（JButton）、文本框（JTextField）、标签（JLabel）、下拉列表（JComboBox）等，可以满足不同的界面设计
Android实现监听事件的方法 Amy木婉清
1.通过内部类实现2.通过匿名内部类实现3.通过事件源所在类实现4.通过外部类实现5.布局文件中onclick属性(针对点击事件)1.通过内部类实现代码:privateButtonmBtnEvent;//oncreate中mBtnEvent.setOnClickListener(newOnClick());//内部类实现监听classOnClickimplementsView.OnClickLis
前端知识点 ZhangTao_zata 前端 javascript css
下面是一个最基本的html代码body{font-family:Arial,sans-serif;margin:20px;}//JavaScriptfunctionthatdisplaysanalertwhencalledfunctionshowMessage(){alert("Hello!Youclickedthebutton.");}MyFirstHTMLPageWelcometoMyPage
4×4矩阵键盘详解（STM32）辰哥单片机设计 STM32传感器教学矩阵计算机外设 stm32 嵌入式硬件单片机传感器
目录一、介绍二、传感器原理1.原理图2.工作原理介绍三、程序设计main.c文件button4_4.h文件button4_4.c文件四、实验效果五、资料获取项目分享一、介绍矩阵键盘，又称为行列式键盘，是用4条I/O线作为行线，4条I/O线作为列线组成的键盘。在行线和列线的每一个交叉点上设置一个按键，因此键盘中按键的个数是4×4个。这种行列式键盘结构能够有效地提高单片机系统中I/O口的利用率，节约单
html ul点击删除,用原生实现点击删除点击的li weixin_39993454 html ul点击删除
简单的实现方式#button{display:inline-block;}ul{list-style:none;}li{background-color:red;display:inline-block;width:20px;padding:10px;margin-left:3px;color:white;}window.onload=function(){varoBtn1=document.ge
QT 自定义组件界面跳转子座 qt 数据库开发语言
一、引用组件需要的类（头文件）1、按钮类QPushButton:普通按钮;QToolButton:工具按钮;QRadioButton:单选按钮;QCheckBox:复选按钮;QCommandLinkButton:命令连接按钮;2、布局类QHBoxLayout水平QVBoxLayout垂直QGridLayout网格QFormLayout表单QSrackedLayout.堆栈3、输出类QLabel:标
Qt QTableWidget 触摸屏上滑动效果 hss2799 Qt
要实现QTableWidget在触摸屏上，滑动记录，记录会跟着滑动，只需要加QScroller*pScroller=QScroller::scroller(tablewidget);pScroller->grabGesture(tablewidget,QScroller::LeftMouseButtonGesture);tablewidget->setVerticalScrollMode(QLis
微信小程序生成小程序转发链接，携带参数跳转到另外一个页面 coderYYY 前端项目教程以及代码小程序微信小程序前端 javascript 微信
作者：coderYYY个人简介：前端程序媛，目前主攻web前端，后端辅助，其他技术知识也会偶尔分享欢迎和我一起交流！（评论和私信一般会回！！）个人专栏推荐：《前端项目教程以及代码》✨一、前言需求：在页面A生成分享链接（携带参数），分享到微信聊天后，好友点击链接可跳转到页面B，页面B可获取到参数二、具体实现pageA（生成链接页面）：通过给button组件设置属性
FloatActionButton 使用 yuzhiyi_宇
FloatActionButton(简称FAB)是负责显示界面基本操作的圆形按钮，其提供的最好是高频率的操作。使用FloatActionButton继承自ImageView，具备ImageView的全部属性。xml布局代码属性作用android:srcFAB中显示的图标app:layout_anchor设置FAB的锚点，即以该控件为参考app:layout_anchorGravityFAB相对锚点
【HTML】元素自定义属性设置与获取（两种方式-含data-*） Sam9029 html 前端 javascript
介绍了两种自定义属性的方式一：完全自定义二：data-*内置的自定义方式1.自定义属性名Clickme!varbtn=document.querySelector('button')console.log(btn.getAttribute('desc'))//获取属性值btn.setAttribute('tip','pleaseclickbutton')//设置属性值–2.data-*自定义属性名
微信小程序仿微信聊天界面微特尔普拉斯微信小程序微信 notepad++
界面结构:消息列表:使用scroll-view实现滚动，每条消息使用view组件包裹，根据消息类型(文本、图片、文件)显示不同内容。输入框区域:包含输入框(textarea)、发送按钮(button)和上传文件按钮(view组件模拟)。头像:使用image组件展示。功能实现:多行输入框高度自适应:使用textarea组件的auto-height属性，并监听linechange事件动态调整高度。消息
前端文件上传总结小小小小小小拉松 javascript html5
第一种：经典的form和input上传。设置form的aciton为后端页面，enctype="multipart/form-data"，type=‘post’提交使用input选择文件，设置好其他input的值，点击提交，将文件数据及签名等认证信息发送到form设置的action对应的页面，浏览器也会跳转到该页面。触发form表单提交数据的方式有2种，一种是在页面上点击button按钮或按钮触发
python pyqt5 设置控件随窗体拉伸 SkTj
2#--coding:utf-8--'''【简介】布局中用到的addStretch函数例子'''fromPyQt5.QtWidgetsimportQApplication,QWidget,QVBoxLayout,QHBoxLayout,QPushButtonimportsysclassWindowDemo(QWidget):definit(self):super().init()btn1=QPus
Python 对话框 houyanhua1 Python python
#coding=utf-8#对话框fromtkinterimport*importtkinter.messageboxasmb#给导入的包指定一个别名classApp:def__init__(self,master):frame=Frame(master)frame.pack()button=Button(frame,text='点击',command=self.info)button.grid(
Vue 项目性能优化技巧分享 2401_84437170 程序员 vue.js 性能优化前端
importVuefrom‘vue’;import{Button,Select}from‘element-ui’;Vue.use(Button)Vue.use(Select)1.9、优化无限列表性能如果你的应用存在非常长或者无限滚动的列表，那么需要采用窗口化的技术来优化性能，只需要渲染少部分区域的内容，减少重新渲染组件和创建dom节点的时间。你可以参考以下开源项目vue-virtual-scrol
mxgraph创建流程实现简单的加减乘除 lost_wen mxgraph mxgraph
html{min-width:800px;}body{margin:0auto;font-size:12px;height:550px;}input.form-control,button.btn{font-size:12px;height:25px;line-height:12px;}#container{width:100%;height:500px;overflow:hidden;backg
信号和槽介绍、使用方式无_欲 Qt qt c++
一、信号与槽的简介信号与槽是Qt的编程基础，是Qt编程的核心特性，也是Qt区别与其它C++开发框架的重要特性。信号：是在特定情况下被发射的通知，例如QPushButton较常见的信号就是点击时发射的clicked()信号。GUI程序设计的主要工作就是对界面上各组件的信号进行响应，只需要知道什么时候发射哪些信号，合理的去响应和处理这些信号就可以了。槽(slot)是对信号进行响应的函数。槽就是函数，所
使用AlertDialog实现提示框晨曦诗雨
image.png自己写一个提示消息的框xml文件java的实现功能publicclassAlertDialogextendsAppCompatActivityimplementsView.OnClickListener{privateButtonbutton1;privateButtonbutton2;NotificationManagernotificationManager;//通知控制列i
qt 表格中插入一行_Qt在表格中加入控件唉唉唉哒 qt 表格中插入一行
任务：使用QTableWidget动态生成表格，在每行的某两列中加入QComboBox下拉框控件和QPushButton按钮控件有添加，删除，编辑功能，每行的按钮可以浏览文件夹并选择文件1、新建一个对话框QDialog，设计界面中选择Item-Widgets里的TableWidget，添加该控件，命名为tableWidget_userlist2、在Dialog的构造函数中初始化表格的一些参数//初
HTML5 `＜button＞` 标签深入全面解析软考鸭 html5 html5 前端 html
引言在HTML5中，标签用于定义一个可点击的按钮，它是创建交互式网页的重要元素之一。与相比，标签提供了更多的灵活性和样式化的可能性。本文将深入解析HTML5中的标签，详细介绍其属性、样式以及实际应用。标签的基本用法标签内部可以放置内容，如文本、图像或其他HTML元素。这使得标签比更加灵活。点击我在这个简单的例子中，我们创建了一个普通的按钮，其上的文本是“点击我”。标签的属性标签支持多种属性，用于定
简单实现浮动按钮+上滑隐藏按钮+下滑显示按钮 AlanGe
#import"SlideShowOrHideVC.h"@interfaceSlideShowOrHideVC(){CGFloatlastContentOffset;BOOLhideBtn;BOOLisBottom;}@property(nonatomic,strong)UITableView*tableView;@property(nonatomic,strong)UIButton*myButt
Java 上传读取Excel文件 Ben_1043556915 Java进阶 java servlet 开发语言
Web中導入Excel文件ExtJs前端代碼://=========上傳Excel=============================uploadPanel=newExt.form.FormPanel({fileUpload:true,id:'fileUploadForm',frame:true,labelAlign:'right',buttonAlign:'center',labelWid
鸿蒙（HarmonyOS）应用层开发知识点汇总 OH五星上将移动开发鸿蒙开发 HarmonyOS harmonyos 鸿蒙开发移动开发分布式 arkui 组件化性能优化
由于不少粉丝朋友反馈，说网上的有些知识点记录的比较杂乱，学习起来很费时间！小编下面针对【鸿蒙】应用开发中的一些技术点做的整理归纳，希望下面的能够有效的帮助到大家：基础组件基础组件(text开发）基础组件(input开发）基础组件(button开发）基础组件(picker开发）基础组件(image开发）基础组件(image-animator开发）基础组件(rating开发）基础组件(slider开发
出现 [Vue warn]: Unhandled error during execution of component event handler 解决方法码农研究僧 BUG vue.js javascript ecmascript
目录前言1.问题所示2.原理分析3.解决方法3.1第一次遇到3.2第二次遇到前言基本的知识推荐阅读：详细分析Js中的Promise.all基本知识（附Demo）1.问题所示点击按钮的时候，浏览器出现如下提示虽然它是warn，但是本着解决问题的本质还是理性分析下use-button.ts:57[Vuewarn]:Unhandlederrorduringexecutionofcomponenteven
python的GUI for_choc Python
由于在Python3.x上安装wx失败所以最后使用Tkinter实现，python2.x在这个模块上还是有挺多的区别的。创建并运行GUI程序的基本步骤：1.导入tkinter模块(Python3.x)结合2，我导入了部分需要的子模块fromtkinterimportTk,Button,Frame,Label,Entry,filedialog,2.创建一个顶层窗口对象需要一个放置所有组件的地方top
Python_GUI Richard&仰望星空 python python
#Author:Richardfromtkinterimport*defprocessOK():print("OKbuttonisclicked!")defprocessCancel():print("Cancelbuttonisclicked!")window=Tk()#creatawindow#label=Label(window,text="WelcometoPython!")#小构建类#b
[Electron]中的dialog模块嗓子疼谁心疼 Electron 前端 javascript electron
Electron的dialog模块dialog模块具有以下方法:dialog.showOpenDialogSync([browserWindow,]options)同步打开文件对话框*browserWindowBrowserWindow(可选)*options *titlestring(可选)-对话框窗口的标题 *defaultPathstring(可选)-对话框的默认展示路径 *buttonLa
微信小程序组件 contact-button（客服会话按钮）代码前哨站
微信小程序组件contact-button（客服会话按钮）contact-button客服会话按钮，用于在页面上显示一个客服会话按钮，用户点击该按钮后会进入客服会话。在页面中使用可以显示进入客服会话按钮。当用户在客服会话发送消息（或进行某些特定的用户操作引发的事件推送时），微信服务器会将消息（或事件）的数据包（JSON或者XML格式）POST请求开发者填写的URL。开发者收到请求后可以使用发送客服
小程序button去除边框，自定义样式 angryAnt的简书
微信小程序button去除边框微信小程序的button提供了几种系统样式，但在我们开发中一般都用不上，但是有些功能必须只能用button来调用，如分享(open-type="share")所以我们需要在view上面盖上一个透明的button，来响应事件。step1.去除button的边框：.share-img-button{border:none;}.share-img-button::after
JAVA制作的简易计算器——傻瓜计算器咱是地球人编程 JAVA 学习
用JAVA编写的傻瓜计算器作用：1.可以实现加法、减法、乘法、除法简单运算且是单一运算，不可混合使用。2.CE为清除键3.没有小数点O(∩_∩)O思路：创建JFrame窗口，设置标题，创建JButton,创建文本框JTextField用作显示。先定义各种按钮类型，用作成员。定义窗口方法对窗口进行设置。定义按钮事件方法，每个按钮的每次点下在文本框都会进行打印。以运算符为界限对字符串进行分割，并把分割
Java实现的简单双向Map，支持重复Value superlxw1234 java 双向map
关键字：Java双向Map、DualHashBidiMap 有个需求，需要根据即时修改Map结构中的Value值，比如，将Map中所有value=V1的记录改成value=V2，key保持不变。数据量比较大，遍历Map性能太差，这就需要根据Value先找到Key，然后去修改。即：既要根据Key找Value，又要根据Value
PL/SQL触发器基础及例子百合不是茶 oracle数据库触发器 PL/SQL编程
触发器的简介; 触发器的定义就是说某个条件成立的时候，触发器里面所定义的语句就会被自动的执行。因此触发器不需要人为的去调用，也不能调用。触发器和过程函数类似过程函数必须要调用, 一个表中最多只能有12个触发器类型的,触发器和过程函数相似触发器不需要调用直接执行, 触发时间：指明触发器何时执行，该值可取： before：表示在数据库动作之前触发
[时空与探索]穿越时空的一些问题 comsci 问题
我们还没有进行过任何数学形式上的证明,仅仅是一个猜想..... 这个猜想就是; 任何有质量的物体(哪怕只有一微克)都不可能穿越时空,该物体强行穿越时空的时候,物体的质量会与时空粒子产生反应,物体会变成暗物质,也就是说,任何物体穿越时空会变成暗物质..(暗物质就我的理
easy ui datagrid上移下移一行商人shang js 上移下移 easyui datagrid
/** * 向上移动一行 * * @param dg * @param row */ function moveupRow(dg, row) { var datagrid = $(dg); var index = datagrid.datagrid("getRowIndex", row); if (isFirstRow(dg, row)) {
Java反射 oloz 反射
本人菜鸟，今天恰好有时间，写写博客，总结复习一下java反射方面的知识，欢迎大家探讨交流学习指教首先看看java中的Class package demo; public class ClassTest { /*先了解java中的Class*/ public static void main(String[] args) { //任何一个类都
springMVC 使用JSR-303 Validation验证杨白白 spring mvc
JSR-303是一个数据验证的规范，但是spring并没有对其进行实现，Hibernate Validator是实现了这一规范的，通过此这个实现来讲SpringMVC对JSR-303的支持。 JSR-303的校验是基于注解的，首先要把这些注解标记在需要验证的实体类的属性上或是其对应的get方法上。登录需要验证类 public class Login { @NotEmpty
log4j 香水浓 log4j
log4j.rootCategory=DEBUG, STDOUT, DAILYFILE, HTML, DATABASE #log4j.rootCategory=DEBUG, STDOUT, DAILYFILE, ROLLINGFILE, HTML #console log4j.appender.STDOUT=org.apache.log4j.ConsoleAppender log4
使用ajax和history.pushState无刷新改变页面URL agevs jquery 框架 Ajax html5 chrome
表现如果你使用chrome或者firefox等浏览器访问本博客、github.com、plus.google.com等网站时，细心的你会发现页面之间的点击是通过ajax异步请求的，同时页面的URL发生了了改变。并且能够很好的支持浏览器前进和后退。是什么有这么强大的功能呢？ HTML5里引用了新的API，history.pushState和history.replaceState，就是通过
centos中文乱码 AILIKES centos OS ssh
一、CentOS系统访问 g.cn ，发现中文乱码。于是用以前的方式：yum -y install fonts-chinese CentOS系统安装后，还是不能显示中文字体。我使用 gedit 编辑源码，其中文注释也为乱码。后来，终于找到以下方法可以解决，需要两个中文支持的包： fonts-chinese-3.02-12.
触发器 baalwolf 触发器
触发器(trigger)：监视某种情况，并触发某种操作。触发器创建语法四要素：1.监视地点(table) 2.监视事件(insert/update/delete) 3.触发时间(after/before) 4.触发事件(insert/update/delete) 语法： create trigger triggerName after/before
JS正则表达式的i m g bijian1013 JavaScript 正则表达式
g:表示全局（global)模式，即模式将被应用于所有字符串，而非在发现第一个匹配项时立即停止。 i:表示不区分大小写（case-insensitive）模式，即在确定匹配项时忽略模式与字符串的大小写。 m:表示
HTML5模式和Hashbang模式 bijian1013 JavaScript AngularJS Hashbang模式 HTML5模式
我们可以用$locationProvider来配置$location服务（可以采用注入的方式，就像AngularJS中其他所有东西一样）。这里provider的两个参数很有意思，介绍如下。 html5Mode 一个布尔值，标识$location服务是否运行在HTML5模式下。 ha
[Maven学习笔记六]Maven生命周期 bit1129 maven
从mvn test的输出开始说起当我们在user-core中执行mvn test时，执行的输出如下： /software/devsoftware/jdk1.7.0_55/bin/java -Dmaven.home=/software/devsoftware/apache-maven-3.2.1 -Dclassworlds.conf=/software/devs
【Hadoop七】基于Yarn的Hadoop Map Reduce容错 bit1129 hadoop
运行于Yarn的Map Reduce作业，可能发生失败的点包括 Task Failure Application Master Failure Node Manager Failure Resource Manager Failure 1. Task Failure 任务执行过程中产生的异常和JVM的意外终止会汇报给Application Master。僵死的任务也会被A
记一次数据推送的异常解决端口解决 ronin47 记一次数据推送的异常解决
　　需求：从db获取数据然后推送到B 程序开发完成，上jboss,刚开始报了很多错，逐一解决，可最后显示连接不到数据库。机房的同事说可以ping 通。　　自已画了个图，逐一排除，把linux 防火墙　和　setenforce　设置最低。　　　service iptables stop
巧用视错觉-UI更有趣 brotherlamp UI ui视频 ui教程 ui自学 ui资料
我们每个人在生活中都曾感受过视错觉（optical illusion）的魅力。视错觉现象是双眼跟我们开的一个玩笑，而我们往往还心甘情愿地接受我们看到的假象。其实不止如此，视觉错现象的背后还有一个重要的科学原理——格式塔原理。格式塔原理解释了人们如何以视觉方式感觉物体，以及图像的结构，视角，大小等要素是如何影响我们的视觉的。在下面这篇文章中，我们首先会简单介绍一下格式塔原理中的基本概念，
线段树-poj1177-N个矩形求边长（离散化+扫描线） bylijinnan 数据结构算法线段树
package com.ljn.base; import java.util.Arrays; import java.util.Comparator; import java.util.Set; import java.util.TreeSet; /** * POJ 1177 (线段树+离散化+扫描线)，题目链接为http://poj.org/problem?id=1177
HTTP协议详解 chicony http协议
引言
Scala设计模式 chenchao051 设计模式 scala
Scala设计模式我的话：在国外网站上看到一篇文章，里面详细描述了很多设计模式，并且用Java及Scala两种语言描述，清晰的让我们看到各种常规的设计模式，在Scala中是如何在语言特性层面直接支持的。基于文章很nice，我利用今天的空闲时间将其翻译，希望大家能一起学习，讨论。翻译
安装mysql daizj mysql 安装
安装mysql (1)删除linux上已经安装的mysql相关库信息。rpm -e xxxxxxx --nodeps (强制删除) 执行命令rpm -qa |grep mysql 检查是否删除干净 (2)执行命令 rpm -i MySQL-server-5.5.31-2.el
HTTP状态码大全 dcj3sjt126com http状态码
完整的 HTTP 1.1规范说明书来自于RFC 2616，你可以在http://www.talentdigger.cn/home/link.php?url=d3d3LnJmYy1lZGl0b3Iub3JnLw%3D%3D在线查阅。HTTP 1.1的状态码被标记为新特性，因为许多浏览器只支持 HTTP 1.0。你应只把状态码发送给支持 HTTP 1.1的客户端，支持协议版本可以通过调用request
asihttprequest上传图片 dcj3sjt126com ASIHTTPRequest
NSURL *url =@"yourURL"; ASIFormDataRequest*currentRequest =[ASIFormDataRequest requestWithURL:url]; [currentRequest setPostFormat:ASIMultipartFormDataPostFormat];[currentRequest se
C语言中，关键字static的作用 e200702084 C++c C#
在C语言中，关键字static有三个明显的作用： 1)在函数体，局部的static变量。生存期为程序的整个生命周期，（它存活多长时间）；作用域却在函数体内（它在什么地方能被访问（空间））。一个被声明为静态的变量在这一函数被调用过程中维持其值不变。因为它分配在静态存储区，函数调用结束后并不释放单元，但是在其它的作用域的无法访问。当再次调用这个函数时，这个局部的静态变量还存活，而且用在它的访
win7/8使用curl geeksun win7
1. WIN7/8下要使用curl，需要下载curl-7.20.0-win64-ssl-sspi.zip和Win64OpenSSL_Light-1_0_2d.exe。下载地址： http://curl.haxx.se/download.html 请选择不带SSL的版本，否则还需要安装SSL的支持包 2. 可以给Windows增加c
Creating a Shared Repository; Users Sharing The Repository hongtoushizi git
转载自： http://www.gitguys.com/topics/creating-a-shared-repository-users-sharing-the-repository/ Commands discussed in this section: git init –bare git clone git remote git pull git p
Java实现字符串反转的8种或9种方法 Josh_Persistence 异或反转递归反转二分交换反转 java字符串反转栈反转
注：对于第7种使用异或的方式来实现字符串的反转，如果不太看得明白的，可以参照另一篇博客： http://josh-persistence.iteye.com/blog/2205768 /** * */ package com.wsheng.aggregator.algorithm.string; import java.util.Stack; /**
代码实现任意容量倒水问题 home198979 PHP 算法倒水
形象化设计模式实战 HELLO!架构 redis命令源码解析倒水问题：有两个杯子，一个A升，一个B升，水有无限多，现要求利用这两杯子装C
Druid datasource zhb8015 druid
推荐大家使用数据库连接池 DruidDataSource. http://code.alibabatech.com/wiki/display/Druid/DruidDataSource DruidDataSource经过阿里巴巴数百个应用一年多生产环境运行验证，稳定可靠。它最重要的特点是：监控、扩展和性能。下载和Maven配置看这里： http
两种启动监听器ApplicationListener和ServletContextListener spjich java spring 框架
引言:有时候需要在项目初始化的时候进行一系列工作，比如初始化一个线程池，初始化配置文件，初始化缓存等等，这时候就需要用到启动监听器，下面分别介绍一下两种常用的项目启动监听器 ServletContextListener 特点: 依赖于sevlet容器，需要配置web.xml 使用方法: public class StartListener implements
JavaScript Rounding Methods of the Math object 何不笑 JavaScript Math
The next group of methods has to do with rounding decimal values into integers. Three methods — Math.ceil(), Math.floor(), and Math.round() — handle rounding in differen