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 gomesj@bsi.com.br)
(c) 1999, written by Dipl. Ing. Mike Lischke (public@lischke-online.de)
All rights reserved. This control 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 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
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 gomesj@bsi.com.br)
//
// (c) 1999, written by Dipl. Ing. Mike Lischke (public@lischke-online.de)
// 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.