mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-05 12:58:04 +02:00
1126 lines
34 KiB
ObjectPascal
1126 lines
34 KiB
ObjectPascal
{
|
|
TColorBox is component that displays colors in a combobox
|
|
TColorListBox is component that displays colors in a listbox
|
|
|
|
Copyright (C) 2005 Darius Blaszijk
|
|
|
|
*****************************************************************************
|
|
This file is part of the Lazarus Component Library (LCL)
|
|
|
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
|
for details about the license.
|
|
*****************************************************************************
|
|
}
|
|
|
|
unit ColorBox;
|
|
|
|
{$mode objfpc}
|
|
{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
LResources, SysUtils, Types, Classes,
|
|
LCLType, LCLStrConsts, Graphics, Controls, Forms, Dialogs, StdCtrls,
|
|
LazStringUtils;
|
|
|
|
const
|
|
cDefaultColorRectWidth = 14;
|
|
cDefaultColorRectOffset = 3;
|
|
|
|
type
|
|
{ TCustomColorBox }
|
|
|
|
TCustomColorBox = class;
|
|
TColorBoxStyles = (cbStandardColors, // 16 standard colors (look at graphics.pp)
|
|
cbExtendedColors, // 4 extended colors (look at graphics.pp)
|
|
cbSystemColors, // system colors (look at graphics.pp)
|
|
cbIncludeNone, // include clNone
|
|
cbIncludeDefault, // include clDefault
|
|
cbCustomColor, // first color is customizable
|
|
cbPrettyNames, // use good looking color names - like Red for clRed
|
|
cbCustomColors); // call OnGetColors after all other colors processing
|
|
TColorBoxStyle = set of TColorBoxStyles;
|
|
TGetColorsEvent = procedure(Sender: TCustomColorBox; Items: TStrings) of object;
|
|
|
|
TCustomColorBox = class(TCustomComboBox)
|
|
private
|
|
FColorRectWidth: Integer;
|
|
FColorRectOffset: Integer;
|
|
FDefaultColorColor: TColor;
|
|
FNoneColorColor: TColor;
|
|
FColorDialog:TColorDialog;
|
|
FOnGetColors: TGetColorsEvent;
|
|
FStyle: TColorBoxStyle;
|
|
FSelected: TColor;
|
|
function GetColor(Index : Integer): TColor;
|
|
function GetColorName(Index: Integer): string;
|
|
function GetColorRectWidth: Integer;
|
|
function GetSelected: TColor;
|
|
procedure SetColorRectWidth(AValue: Integer);
|
|
procedure SetColorRectOffset(AValue: Integer);
|
|
procedure SetDefaultColorColor(const AValue: TColor);
|
|
procedure SetNoneColorColor(const AValue: TColor);
|
|
procedure SetSelected(Value: TColor);
|
|
procedure SetStyle(const AValue: TColorBoxStyle); reintroduce;
|
|
procedure ColorProc(const s: AnsiString);
|
|
procedure SetIndexOnColor(aColor: TColor);
|
|
protected
|
|
function ColorRectWidthStored: Boolean;
|
|
procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
|
|
procedure SetColorList;
|
|
procedure Loaded; override;
|
|
procedure InitializeWnd; override;
|
|
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
|
|
const AXProportion, AYProportion: Double); override;
|
|
procedure DoGetColors; virtual;
|
|
procedure CloseUp; override;
|
|
function PickCustomColor: Boolean; virtual;
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
property ColorRectWidth: Integer read GetColorRectWidth write SetColorRectWidth stored ColorRectWidthStored;
|
|
property ColorRectOffset: Integer read FColorRectOffset write SetColorRectOffset default cDefaultColorRectOffset;
|
|
property Style: TColorBoxStyle read FStyle write SetStyle
|
|
default [cbStandardColors, cbExtendedColors, cbSystemColors];
|
|
property Colors[Index: Integer]: TColor read GetColor;
|
|
property ColorNames[Index: Integer]: string read GetColorName;
|
|
property Selected: TColor read GetSelected write SetSelected default clBlack;
|
|
property DefaultColorColor: TColor read FDefaultColorColor write SetDefaultColorColor default clBlack;
|
|
property NoneColorColor: TColor read FNoneColorColor write SetNoneColorColor default clBlack;
|
|
property OnGetColors: TGetColorsEvent read FOnGetColors write FOnGetColors;
|
|
property ColorDialog: TColorDialog read FColorDialog write FColorDialog;
|
|
end;
|
|
|
|
{ TColorBox }
|
|
|
|
TColorBox = class(TCustomColorBox)
|
|
published
|
|
property ColorRectWidth;
|
|
property ColorRectOffset;
|
|
property DefaultColorColor;
|
|
property NoneColorColor;
|
|
property Selected;
|
|
property Style;
|
|
property OnGetColors;
|
|
property ColorDialog;
|
|
property Align;
|
|
property Anchors;
|
|
property ArrowKeysTraverseList;
|
|
property AutoComplete;
|
|
property AutoCompleteText;
|
|
property AutoDropDown;
|
|
property AutoSelect;
|
|
property AutoSize;
|
|
property BidiMode;
|
|
property BorderSpacing;
|
|
property Color;
|
|
property Constraints;
|
|
property DragCursor;
|
|
property DragMode;
|
|
property DropDownCount;
|
|
property Enabled;
|
|
property Font;
|
|
property ItemHeight;
|
|
property ItemWidth;
|
|
property ParentBidiMode;
|
|
property ParentColor;
|
|
property ParentFont;
|
|
property ParentShowHint;
|
|
property PopupMenu;
|
|
property ShowHint;
|
|
property TabOrder;
|
|
property TabStop;
|
|
property Visible;
|
|
|
|
property OnChange;
|
|
property OnChangeBounds;
|
|
property OnClick;
|
|
property OnCloseUp;
|
|
property OnContextPopup;
|
|
property OnDblClick;
|
|
property OnDragDrop;
|
|
property OnDragOver;
|
|
property OnEndDrag;
|
|
property OnDropDown;
|
|
property OnEditingDone;
|
|
property OnEnter;
|
|
property OnExit;
|
|
property OnKeyDown;
|
|
property OnKeyPress;
|
|
property OnKeyUp;
|
|
property OnMouseDown;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
property OnMouseWheel;
|
|
property OnMouseWheelDown;
|
|
property OnMouseWheelUp;
|
|
property OnStartDrag;
|
|
property OnSelect;
|
|
property OnUTF8KeyPress;
|
|
end;
|
|
|
|
{ TCustomColorListBox }
|
|
|
|
TCustomColorListBox = class;
|
|
TLBGetColorsEvent = procedure(Sender: TCustomColorListBox; Items: TStrings) of object;
|
|
|
|
TCustomColorListBox = class(TCustomListBox)
|
|
private
|
|
FColorRectWidth: Integer;
|
|
FColorRectOffset: Integer;
|
|
FDefaultColorColor: TColor;
|
|
FNoneColorColor: TColor;
|
|
FOnGetColors: TLBGetColorsEvent;
|
|
FColorDialog:TColorDialog;
|
|
FSelected: TColor;
|
|
FStyle: TColorBoxStyle;
|
|
function GetColorRectWidth: Integer;
|
|
function GetColors(Index : Integer): TColor;
|
|
function GetColorName(Index: Integer): string;
|
|
function GetSelected: TColor;
|
|
procedure SetColorRectOffset(AValue: Integer);
|
|
procedure SetColorRectWidth(AValue: Integer);
|
|
procedure SetColors(Index: Integer; AValue: TColor);
|
|
procedure SetDefaultColorColor(const AValue: TColor);
|
|
procedure SetNoneColorColor(const AValue: TColor);
|
|
procedure SetSelected(Value: TColor);
|
|
procedure SetStyle(const AValue: TColorBoxStyle); reintroduce;
|
|
procedure ColorProc(const s: AnsiString);
|
|
procedure SetIndexOnColor(aColor: TColor);
|
|
protected
|
|
function ColorRectWidthStored: Boolean;
|
|
procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
|
|
procedure SetColorList;
|
|
procedure Loaded; override;
|
|
procedure InitializeWnd; override;
|
|
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
|
|
const AXProportion, AYProportion: Double); override;
|
|
procedure DoGetColors; virtual;
|
|
procedure DoSelectionChange(User: Boolean); override;
|
|
function PickCustomColor: Boolean; virtual;
|
|
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
property ColorRectWidth: Integer read GetColorRectWidth write SetColorRectWidth stored ColorRectWidthStored;
|
|
property ColorRectOffset: Integer read FColorRectOffset write SetColorRectOffset default cDefaultColorRectOffset;
|
|
property Style: TColorBoxStyle read FStyle write SetStyle
|
|
default [cbStandardColors, cbExtendedColors, cbSystemColors];
|
|
property Colors[Index: Integer]: TColor read GetColors write SetColors;
|
|
property ColorNames[Index: Integer]: string read GetColorName;
|
|
property Selected: TColor read GetSelected write SetSelected default clBlack;
|
|
property DefaultColorColor: TColor read FDefaultColorColor write SetDefaultColorColor default clBlack;
|
|
property NoneColorColor: TColor read FNoneColorColor write SetNoneColorColor default clBlack;
|
|
property OnGetColors: TLBGetColorsEvent read FOnGetColors write FOnGetColors;
|
|
property ColorDialog:TColorDialog read fcolorDialog write FColorDialog;
|
|
end;
|
|
|
|
{ TColorListBox }
|
|
|
|
TColorListBox = class(TCustomColorListBox)
|
|
published
|
|
property ColorRectWidth;
|
|
property ColorRectOffset;
|
|
property DefaultColorColor;
|
|
property NoneColorColor;
|
|
property Selected;
|
|
property Style;
|
|
property OnGetColors;
|
|
property ColorDialog;
|
|
property Align;
|
|
property Anchors;
|
|
property BidiMode;
|
|
property BorderSpacing;
|
|
property BorderStyle;
|
|
property ClickOnSelChange;
|
|
property Color;
|
|
property Constraints;
|
|
property DragCursor;
|
|
property DragKind;
|
|
property DragMode;
|
|
property ExtendedSelect;
|
|
property Enabled;
|
|
property Font;
|
|
property IntegralHeight;
|
|
property ItemHeight;
|
|
property OnChangeBounds;
|
|
property OnClick;
|
|
property OnContextPopup;
|
|
property OnDblClick;
|
|
property OnDragDrop;
|
|
property OnDragOver;
|
|
property OnEnter;
|
|
property OnEndDrag;
|
|
property OnExit;
|
|
property OnKeyPress;
|
|
property OnKeyDown;
|
|
property OnKeyUp;
|
|
property OnMouseDown;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
property OnMouseWheel;
|
|
property OnMouseWheelDown;
|
|
property OnMouseWheelUp;
|
|
property OnMouseWheelHorz;
|
|
property OnMouseWheelLeft;
|
|
property OnMouseWheelRight;
|
|
property OnResize;
|
|
property OnSelectionChange;
|
|
property OnShowHint;
|
|
property OnStartDrag;
|
|
property OnUTF8KeyPress;
|
|
property ParentBidiMode;
|
|
property ParentColor;
|
|
property ParentShowHint;
|
|
property ParentFont;
|
|
property PopupMenu;
|
|
property ShowHint;
|
|
property TabOrder;
|
|
property TabStop;
|
|
property TopIndex;
|
|
property Visible;
|
|
end;
|
|
|
|
procedure Register;
|
|
|
|
implementation
|
|
|
|
{------------------------------------------------------------------------------}
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('Additional', [TColorBox, TColorListBox]);
|
|
end;
|
|
|
|
function GetPrettyColorName(ColorName: String): String;
|
|
|
|
function FindInMap(ColorName: String; out NewColorName: String): Boolean;
|
|
var
|
|
Color: TColor;
|
|
begin
|
|
Result := IdentToColor(ColorName, Color);
|
|
if Result then
|
|
begin
|
|
{ workaround for a bug in fpc 2.2.2 }
|
|
if Color=clScrollBar then
|
|
NewColorName := rsScrollBarColorCaption
|
|
else
|
|
case Color of
|
|
clBlack : NewColorName := rsBlackColorCaption;
|
|
clMaroon : NewColorName := rsMaroonColorCaption;
|
|
clGreen : NewColorName := rsGreenColorCaption;
|
|
clOlive : NewColorName := rsOliveColorCaption;
|
|
clNavy : NewColorName := rsNavyColorCaption;
|
|
clPurple : NewColorName := rsPurpleColorCaption;
|
|
clTeal : NewColorName := rsTealColorCaption;
|
|
clGray : NewColorName := rsGrayColorCaption;
|
|
clSilver : NewColorName := rsSilverColorCaption;
|
|
clRed : NewColorName := rsRedColorCaption;
|
|
clLime : NewColorName := rsLimeColorCaption;
|
|
clYellow : NewColorName := rsYellowColorCaption;
|
|
clBlue : NewColorName := rsBlueColorCaption;
|
|
clFuchsia : NewColorName := rsFuchsiaColorCaption;
|
|
clAqua : NewColorName := rsAquaColorCaption;
|
|
clWhite : NewColorName := rsWhiteColorCaption;
|
|
clMoneyGreen : NewColorName := rsMoneyGreenColorCaption;
|
|
clSkyBlue : NewColorName := rsSkyBlueColorCaption;
|
|
clCream : NewColorName := rsCreamColorCaption;
|
|
clMedGray : NewColorName := rsMedGrayColorCaption;
|
|
clNone : NewColorName := rsNoneColorCaption;
|
|
clDefault : NewColorName := rsDefaultColorCaption;
|
|
clBackground : NewColorName := rsBackgroundColorCaption;
|
|
clActiveCaption : NewColorName := rsActiveCaptionColorCaption;
|
|
clInactiveCaption : NewColorName := rsInactiveCaptionColorCaption;
|
|
clMenu : NewColorName := rsMenuColorCaption;
|
|
clWindow : NewColorName := rsWindowColorCaption;
|
|
clWindowFrame : NewColorName := rsWindowFrameColorCaption;
|
|
clMenuText : NewColorName := rsMenuTextColorCaption;
|
|
clWindowText : NewColorName := rsWindowTextColorCaption;
|
|
clCaptionText : NewColorName := rsCaptionTextColorCaption;
|
|
clActiveBorder : NewColorName := rsActiveBorderColorCaption;
|
|
clInactiveBorder : NewColorName := rsInactiveBorderColorCaption;
|
|
clAppWorkspace : NewColorName := rsAppWorkspaceColorCaption;
|
|
clHighlight : NewColorName := rsHighlightColorCaption;
|
|
clHighlightText : NewColorName := rsHighlightTextColorCaption;
|
|
clBtnFace : NewColorName := rsBtnFaceColorCaption;
|
|
clBtnShadow : NewColorName := rsBtnShadowColorCaption;
|
|
clGrayText : NewColorName := rsGrayTextColorCaption;
|
|
clBtnText : NewColorName := rsBtnTextColorCaption;
|
|
clInactiveCaptionText : NewColorName := rsInactiveCaptionText;
|
|
clBtnHighlight : NewColorName := rsBtnHighlightColorCaption;
|
|
cl3DDkShadow : NewColorName := rs3DDkShadowColorCaption;
|
|
cl3DLight : NewColorName := rs3DLightColorCaption;
|
|
clInfoText : NewColorName := rsInfoTextColorCaption;
|
|
clInfoBk : NewColorName := rsInfoBkColorCaption;
|
|
clHotLight : NewColorName := rsHotLightColorCaption;
|
|
clGradientActiveCaption : NewColorName := rsGradientActiveCaptionColorCaption;
|
|
clGradientInactiveCaption : NewColorName := rsGradientInactiveCaptionColorCaption;
|
|
clMenuHighlight : NewColorName := rsMenuHighlightColorCaption;
|
|
clMenuBar : NewColorName := rsMenuBarColorCaption;
|
|
clForm : NewColorName := rsFormColorCaption;
|
|
else
|
|
Result := False;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
// check in color map
|
|
if not FindInMap(ColorName, Result) then
|
|
begin
|
|
Result := ColorName;
|
|
if LazStartsStr('cl', Result) then
|
|
Delete(Result, 1, 2);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCustomColorBox.Create
|
|
Params: AOwner
|
|
Returns: Nothing
|
|
|
|
Use Create to create an instance of TCustomColorBox and initialize all properties
|
|
and variables.
|
|
|
|
------------------------------------------------------------------------------}
|
|
constructor TCustomColorBox.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
inherited Style := csOwnerDrawFixed;
|
|
|
|
FColorRectWidth := -1;
|
|
FColorRectOffset := cDefaultColorRectOffset;
|
|
FStyle := [cbStandardColors, cbExtendedColors, cbSystemColors];
|
|
FNoneColorColor := clBlack;
|
|
FDefaultColorColor := clBlack;
|
|
FSelected := clBlack;
|
|
SetColorList;
|
|
end;
|
|
{------------------------------------------------------------------------------
|
|
Method: TCustomColorBox.GetSelected
|
|
Params: None
|
|
Returns: TColor
|
|
|
|
Use GetSelected to convert the item selected into a system color.
|
|
|
|
------------------------------------------------------------------------------}
|
|
function TCustomColorBox.GetSelected: TColor;
|
|
begin
|
|
if HandleAllocated then
|
|
begin
|
|
if ItemIndex <> -1 then
|
|
begin
|
|
Result := Colors[ItemIndex];
|
|
// keep FSelected in sync
|
|
if FSelected <> Result then
|
|
begin
|
|
// DebugLn('WARNING TCustomColorBox: FSelected out of sync with Colors[0]');
|
|
FSelected := Result;
|
|
end;
|
|
end else
|
|
Result := FSelected;
|
|
end
|
|
else
|
|
Result := FSelected;
|
|
end;
|
|
|
|
procedure TCustomColorBox.SetColorRectWidth(AValue: Integer);
|
|
begin
|
|
if FColorRectWidth = AValue then Exit;
|
|
FColorRectWidth := AValue;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TCustomColorBox.SetColorRectOffset(AValue: Integer);
|
|
begin
|
|
if FColorRectOffset = AValue then Exit;
|
|
FColorRectOffset := AValue;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TCustomColorBox.SetDefaultColorColor(const AValue: TColor);
|
|
begin
|
|
if FDefaultColorColor <> AValue then
|
|
begin
|
|
FDefaultColorColor := AValue;
|
|
invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomColorBox.SetNoneColorColor(const AValue: TColor);
|
|
begin
|
|
if FNoneColorColor <> AValue then
|
|
begin
|
|
FNoneColorColor := AValue;
|
|
invalidate;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCustomColorBox.GetColor
|
|
Params: Index
|
|
Returns: Color at position Index
|
|
|
|
Used as read procedure from Colors property.
|
|
|
|
------------------------------------------------------------------------------}
|
|
|
|
function TCustomColorBox.GetColor(Index : Integer): TColor;
|
|
begin
|
|
Result := PtrInt(Items.Objects[Index])
|
|
end;
|
|
|
|
function TCustomColorBox.GetColorName(Index: Integer): string;
|
|
begin
|
|
Result := Items[Index];
|
|
end;
|
|
|
|
function TCustomColorBox.GetColorRectWidth: Integer;
|
|
begin
|
|
if ColorRectWidthStored then
|
|
Result := FColorRectWidth
|
|
else
|
|
Result := Scale96ToFont(cDefaultColorRectWidth);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCustomColorBox.SetSelected
|
|
Params: Value
|
|
Returns: Nothing
|
|
|
|
Use SetSelected to set the item in the ColorBox when appointed a color
|
|
from code.
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomColorBox.SetSelected(Value: TColor);
|
|
begin
|
|
if FSelected = Value then
|
|
Exit;
|
|
|
|
FSelected := Value;
|
|
SetIndexOnColor(FSelected);
|
|
inherited Change;
|
|
end;
|
|
|
|
procedure TCustomColorBox.SetStyle(const AValue: TColorBoxStyle);
|
|
begin
|
|
if FStyle <> AValue then
|
|
begin
|
|
FStyle := AValue;
|
|
SetColorList;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomColorBox.ColorProc(const s: AnsiString);
|
|
var
|
|
AColor: TColor;
|
|
Index: Integer;
|
|
ColorCaption: String;
|
|
begin
|
|
if IdentToColor(s, AColor) then
|
|
begin
|
|
if AColor = clWhite then
|
|
AColor := AColor;
|
|
// check clDefault
|
|
if not (cbIncludeDefault in Style) and (AColor = clDefault) then
|
|
Exit;
|
|
// check clNone
|
|
if not (cbIncludeNone in Style) and (AColor = clNone) then
|
|
Exit;
|
|
// check System colors
|
|
if not (cbSystemColors in Style) and ((AColor and SYS_COLOR_BASE) <> 0) then
|
|
Exit;
|
|
// check Standard, Extended colors
|
|
if ([cbStandardColors, cbExtendedColors] * Style <> [cbStandardColors, cbExtendedColors]) and
|
|
ColorIndex(AColor, Index) then
|
|
begin
|
|
if not (cbStandardColors in Style) and (Index < StandardColorsCount) then
|
|
Exit;
|
|
if not (cbExtendedColors in Style) and
|
|
(Index < StandardColorsCount + ExtendedColorCount) and
|
|
(Index >= StandardColorsCount) then
|
|
Exit;
|
|
end;
|
|
|
|
if cbPrettyNames in Style then
|
|
ColorCaption := GetPrettyColorName(s)
|
|
else
|
|
ColorCaption := s;
|
|
|
|
Items.AddObject(ColorCaption, TObject(PtrInt(AColor)));
|
|
end;
|
|
end;
|
|
|
|
function TCustomColorBox.ColorRectWidthStored: Boolean;
|
|
begin
|
|
Result := FColorRectWidth >= 0;
|
|
end;
|
|
|
|
procedure TCustomColorBox.DoAutoAdjustLayout(
|
|
const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double
|
|
);
|
|
begin
|
|
inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion);
|
|
|
|
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
|
|
begin
|
|
if ColorRectWidthStored then
|
|
FColorRectWidth := Round(FColorRectWidth * AXProportion);
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomColorBox.SetIndexOnColor(aColor: TColor);
|
|
var
|
|
i: integer;
|
|
begin
|
|
if not HandleAllocated then exit;
|
|
// find color in list
|
|
for i := ord(cbCustomColor in Style) to Items.Count - 1 do
|
|
if Colors[i] = aColor then
|
|
begin
|
|
ItemIndex := i;
|
|
exit;
|
|
end;
|
|
// check custom color
|
|
if cbCustomColor in Style then
|
|
begin
|
|
Items.Objects[0] := TObject(PtrInt(aColor));
|
|
ItemIndex := 0;
|
|
Invalidate;
|
|
exit;
|
|
end;
|
|
// color not found
|
|
ItemIndex := -1;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCustomColorBox.DrawItem
|
|
Params: Index, Rect, State
|
|
Returns: Nothing
|
|
|
|
Use DrawItem to customdraw an item in the ColorBox. A color preview is drawn
|
|
and the item rectangle is made smaller and given to the inherited method to
|
|
draw the corresponding text. The Brush color and Pen color where changed and
|
|
reset to their original values.
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomColorBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
|
|
var
|
|
r: TRect;
|
|
BrushColor, PenColor, NewColor: TColor;
|
|
noFill: Boolean;
|
|
begin
|
|
if Index = -1 then
|
|
Exit;
|
|
|
|
r.top := Rect.top + ColorRectOffset;
|
|
r.bottom := Rect.bottom - ColorRectOffset;
|
|
r.left := Rect.left + ColorRectOffset;
|
|
r.right := r.left + ColorRectWidth;
|
|
|
|
if not(odBackgroundPainted in State) then
|
|
Canvas.FillRect(Rect);
|
|
|
|
BrushColor := Canvas.Brush.Color;
|
|
PenColor := Canvas.Pen.Color;
|
|
|
|
NewColor := Colors[Index];
|
|
noFill := NewColor = clNone;
|
|
if noFill then
|
|
NewColor := NoneColorColor
|
|
else
|
|
if NewColor = clDefault then
|
|
NewColor := DefaultColorColor;
|
|
|
|
Canvas.Brush.Color := NewColor;
|
|
Canvas.Pen.Color := clBlack;
|
|
|
|
r := BiDiFlipRect(r, Rect, UseRightToLeftAlignment);
|
|
Canvas.Rectangle(r);
|
|
|
|
if noFill then
|
|
begin
|
|
Canvas.Line(r.Left, r.Top, r.Right-1, r.Bottom-1);
|
|
Canvas.Line(r.Left, r.Bottom-1, r.Right-1, r.Top);
|
|
end;
|
|
|
|
Canvas.Brush.Color := BrushColor;
|
|
Canvas.Pen.Color := PenColor;
|
|
|
|
r := Rect;
|
|
r.left := r.left + ColorRectWidth + ColorRectOffset + 1;
|
|
|
|
Include(State, odBackgroundPainted);
|
|
inherited DrawItem(Index, BidiFlipRect(r, Rect, UseRightToLeftAlignment), State);
|
|
end;
|
|
{------------------------------------------------------------------------------
|
|
Method: TCustomColorBox.SetColorList
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Use SetColorList to fill the itemlist in the ColorBox with the right color
|
|
entries. Based on the value of the Palette property.
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomColorBox.SetColorList;
|
|
var
|
|
OldSelected: Integer;
|
|
begin
|
|
// we need to wait while we finish loading since we depend on style and OnGetColors event
|
|
if (csLoading in ComponentState) then
|
|
Exit;
|
|
|
|
OldSelected := FSelected;
|
|
with Items do
|
|
begin
|
|
Clear;
|
|
if cbCustomColor in Style then
|
|
Items.AddObject(rsCustomColorCaption, TObject(PtrInt(clBlack)));
|
|
GetColorValues(@ColorProc);
|
|
if (cbCustomColors in Style) then
|
|
DoGetColors;
|
|
end;
|
|
Selected := OldSelected;
|
|
end;
|
|
|
|
procedure TCustomColorBox.Loaded;
|
|
begin
|
|
inherited Loaded;
|
|
SetColorList;
|
|
end;
|
|
|
|
procedure TCustomColorBox.InitializeWnd;
|
|
begin
|
|
inherited InitializeWnd;
|
|
SetIndexOnColor(FSelected);
|
|
end;
|
|
|
|
procedure TCustomColorBox.DoGetColors;
|
|
begin
|
|
if Assigned(OnGetColors) then
|
|
OnGetColors(Self, Items)
|
|
end;
|
|
|
|
procedure TCustomColorBox.CloseUp;
|
|
begin
|
|
// if custom color has been selected
|
|
if (cbCustomColor in Style) and (ItemIndex = 0) then
|
|
PickCustomColor;
|
|
|
|
// select color and call OnChange
|
|
if ItemIndex >= 0 then
|
|
Selected := Colors[ItemIndex];
|
|
|
|
inherited CloseUp;
|
|
end;
|
|
|
|
function TCustomColorBox.PickCustomColor: Boolean;
|
|
var
|
|
FreeDialog: boolean;
|
|
begin
|
|
if csDesigning in ComponentState then
|
|
exit(false);
|
|
|
|
FreeDialog := FColorDialog = nil;
|
|
if FreeDialog then
|
|
FColorDialog := TColorDialog.Create(GetTopParent);
|
|
try
|
|
FColorDialog.Color := Colors[0];
|
|
result := FColorDialog.Execute;
|
|
if result then
|
|
begin
|
|
Items.Objects[0] := TObject(PtrInt(FColorDialog.Color));
|
|
Invalidate;
|
|
end;
|
|
finally
|
|
if FreeDialog then
|
|
FreeAndNil(FColorDialog);
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomColorBox.Notification(AComponent: TComponent; Operation: TOperation);
|
|
begin
|
|
inherited Notification(AComponent, Operation);
|
|
if (Operation = opRemove) and (AComponent = FColorDialog) then
|
|
FColorDialog := nil;
|
|
end;
|
|
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{------------------------------------------------------------------------------
|
|
Method: TCustomColorListBox.Create
|
|
Params: AOwner
|
|
Returns: Nothing
|
|
|
|
Use Create to create an instance of TCustomColorListBox and initialize all properties
|
|
and variables.
|
|
|
|
------------------------------------------------------------------------------}
|
|
constructor TCustomColorListBox.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
inherited Style := lbOwnerDrawFixed;
|
|
FColorRectWidth := -1;
|
|
FColorRectOffset := cDefaultColorRectOffset;
|
|
FStyle := [cbStandardColors, cbExtendedColors, cbSystemColors];
|
|
FNoneColorColor := clBlack;
|
|
FDefaultColorColor := clBlack;
|
|
FSelected := clBlack;
|
|
|
|
SetColorList;
|
|
end;
|
|
{------------------------------------------------------------------------------
|
|
Method: TCustomColorListBox.GetSelected
|
|
Params: None
|
|
Returns: TColor
|
|
|
|
Use GetSelected to convert the item selected into a system color.
|
|
|
|
------------------------------------------------------------------------------}
|
|
function TCustomColorListBox.GetSelected: TColor;
|
|
begin
|
|
if HandleAllocated then
|
|
begin
|
|
if ItemIndex <> -1 then
|
|
Result := Colors[ItemIndex]
|
|
else
|
|
Result := FSelected
|
|
end
|
|
else
|
|
Result := FSelected;
|
|
end;
|
|
|
|
procedure TCustomColorListBox.SetColorRectOffset(AValue: Integer);
|
|
begin
|
|
if FColorRectOffset = AValue then Exit;
|
|
FColorRectOffset := AValue;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TCustomColorListBox.SetColorRectWidth(AValue: Integer);
|
|
begin
|
|
if FColorRectWidth = AValue then Exit;
|
|
FColorRectWidth := AValue;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TCustomColorListBox.SetColors(Index: Integer; AValue: TColor);
|
|
begin
|
|
if Colors[Index]=AValue then exit;
|
|
Items.Objects[Index]:=TObject(PtrInt(AValue));
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TCustomColorListBox.SetDefaultColorColor(const AValue: TColor);
|
|
begin
|
|
if FDefaultColorColor <> AValue then
|
|
begin
|
|
FDefaultColorColor := AValue;
|
|
invalidate;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomColorListBox.SetNoneColorColor(const AValue: TColor);
|
|
begin
|
|
if FNoneColorColor <> AValue then
|
|
begin
|
|
FNoneColorColor := AValue;
|
|
invalidate;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCustomColorListBox.GetColors
|
|
Params: Index
|
|
Returns: Color at position Index
|
|
|
|
Used as read procedure from Colors property.
|
|
|
|
------------------------------------------------------------------------------}
|
|
function TCustomColorListBox.GetColors(Index : Integer): TColor;
|
|
begin
|
|
Result := PtrInt(Items.Objects[Index]);
|
|
end;
|
|
|
|
function TCustomColorListBox.GetColorName(Index: Integer): string;
|
|
begin
|
|
Result := Items[Index];
|
|
end;
|
|
|
|
function TCustomColorListBox.GetColorRectWidth: Integer;
|
|
begin
|
|
if ColorRectWidthStored then
|
|
Result := FColorRectWidth
|
|
else
|
|
Result := Scale96ToFont(cDefaultColorRectWidth);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCustomColorListBox.SetSelected
|
|
Params: Value
|
|
Returns: Nothing
|
|
|
|
Use SetSelected to set the item in the ColorListBox when appointed a color
|
|
from code.
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomColorListBox.SetSelected(Value: TColor);
|
|
begin
|
|
if FSelected = Value then
|
|
exit;
|
|
|
|
FSelected := Value;
|
|
SetIndexOnColor(FSelected);
|
|
end;
|
|
|
|
procedure TCustomColorListBox.SetStyle(const AValue: TColorBoxStyle);
|
|
begin
|
|
if FStyle <> AValue then
|
|
begin
|
|
FStyle := AValue;
|
|
SetColorList;
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomColorListBox.ColorProc(const s: AnsiString);
|
|
var
|
|
AColor: TColor;
|
|
Index: Integer;
|
|
ColorCaption: String;
|
|
begin
|
|
if IdentToColor(s, AColor) then
|
|
begin
|
|
// check clDefault
|
|
if not (cbIncludeDefault in Style) and (AColor = clDefault) then
|
|
Exit;
|
|
// check clNone
|
|
if not (cbIncludeNone in Style) and (AColor = clNone) then
|
|
Exit;
|
|
// check System colors
|
|
if not (cbSystemColors in Style) and ((AColor and SYS_COLOR_BASE) <> 0) then
|
|
Exit;
|
|
// check Standard, Extended colors
|
|
if ([cbStandardColors, cbExtendedColors] * Style <> [cbStandardColors, cbExtendedColors]) and
|
|
ColorIndex(AColor, Index) then
|
|
begin
|
|
if not (cbStandardColors in Style) and (Index < StandardColorsCount) then
|
|
Exit;
|
|
if not (cbExtendedColors in Style) and
|
|
(Index < StandardColorsCount + ExtendedColorCount) and
|
|
(Index >= StandardColorsCount) then
|
|
Exit;
|
|
end;
|
|
|
|
if cbPrettyNames in Style then
|
|
ColorCaption := GetPrettyColorName(s)
|
|
else
|
|
ColorCaption := s;
|
|
|
|
Items.AddObject(ColorCaption, TObject(PtrInt(AColor)));
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomColorListBox.SetIndexOnColor(aColor: TColor);
|
|
var
|
|
i: integer;
|
|
begin
|
|
if not HandleAllocated then exit;
|
|
// find color in list
|
|
for i := ord(cbCustomColor in Style) to Items.Count - 1 do
|
|
if Colors[i] = aColor then
|
|
begin
|
|
ItemIndex := i;
|
|
exit;
|
|
end;
|
|
// check custom color
|
|
if cbCustomColor in Style then
|
|
begin
|
|
Items.Objects[0] := TObject(PtrInt(aColor));
|
|
ItemIndex := 0;
|
|
Invalidate;
|
|
exit;
|
|
end;
|
|
// color not found
|
|
ItemIndex := -1;
|
|
end;
|
|
|
|
function TCustomColorListBox.ColorRectWidthStored: Boolean;
|
|
begin
|
|
Result := FColorRectWidth >= 0;
|
|
end;
|
|
|
|
procedure TCustomColorListBox.DoAutoAdjustLayout(
|
|
const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double
|
|
);
|
|
begin
|
|
inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion);
|
|
|
|
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
|
|
begin
|
|
if ColorRectWidthStored then
|
|
FColorRectWidth := Round(FColorRectWidth * AXProportion);
|
|
Invalidate;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TCustomColorListBox.DrawItem
|
|
Params: Index, Rect, State
|
|
Returns: Nothing
|
|
|
|
Use DrawItem to customdraw an item in the ColorListBox. A color preview is drawn
|
|
and the item rectangle is made smaller and given to the inherited method to
|
|
draw the corresponding text. The Brush color and Pen color where changed and
|
|
reset to their original values.
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomColorListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
|
|
var
|
|
r: TRect;
|
|
BrushColor, PenColor, NewColor: TColor;
|
|
noFill: boolean;
|
|
begin
|
|
if Index < 0 then
|
|
Exit;
|
|
|
|
r.top := Rect.top + ColorRectOffset;
|
|
r.bottom := Rect.bottom - ColorRectOffset;
|
|
r.left := Rect.left + ColorRectOffset;
|
|
r.right := r.left + ColorRectWidth;
|
|
|
|
if not(odBackgroundPainted in State) then
|
|
Canvas.FillRect(Rect);
|
|
|
|
BrushColor := Canvas.Brush.Color;
|
|
PenColor := Canvas.Pen.Color;
|
|
|
|
NewColor := Colors[Index];
|
|
noFill := NewColor = clNone;
|
|
if noFill then
|
|
NewColor := NoneColorColor
|
|
else
|
|
if NewColor = clDefault then
|
|
NewColor := DefaultColorColor;
|
|
|
|
Canvas.Brush.Color := NewColor;
|
|
Canvas.Pen.Color := clBlack;
|
|
|
|
Canvas.Rectangle(BidiFlipRect(r, Rect, UseRightToLeftAlignment));
|
|
|
|
if noFill then
|
|
begin
|
|
Canvas.Line(r.Left, r.Top, r.Right-1, r.Bottom-1);
|
|
Canvas.Line(r.Left, r.Bottom-1, r.Right-1, r.Top);
|
|
end;
|
|
|
|
Canvas.Brush.Color := BrushColor;
|
|
Canvas.Pen.Color := PenColor;
|
|
|
|
r := Rect;
|
|
r.left := r.left + ColorRectWidth + ColorRectOffset + 1;
|
|
|
|
Include(State,odBackgroundPainted);
|
|
inherited DrawItem(Index, BidiFlipRect(r, Rect, UseRightToLeftAlignment), State);
|
|
end;
|
|
{------------------------------------------------------------------------------
|
|
Method: TCustomColorListBox.SetColorList
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Use SetColorList to fill the itemlist in the ColorListBox with the right color
|
|
entries. Based on the value of the Palette property.
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TCustomColorListBox.SetColorList;
|
|
var
|
|
OldSelected: Integer;
|
|
begin
|
|
// we need to wait while we finish loading since we depend on style and OnGetColors event
|
|
if (csLoading in ComponentState) then
|
|
Exit;
|
|
OldSelected := FSelected;
|
|
with Items do
|
|
begin
|
|
Clear;
|
|
if cbCustomColor in Style then
|
|
Items.AddObject(rsCustomColorCaption, TObject(PtrInt(clBlack)));
|
|
GetColorValues(@ColorProc);
|
|
if (cbCustomColors in Style) then
|
|
DoGetColors;
|
|
end;
|
|
Selected := OldSelected;
|
|
end;
|
|
|
|
procedure TCustomColorListBox.Loaded;
|
|
begin
|
|
inherited Loaded;
|
|
SetColorList;
|
|
end;
|
|
|
|
procedure TCustomColorListBox.InitializeWnd;
|
|
begin
|
|
inherited InitializeWnd;
|
|
Selected := FSelected;
|
|
end;
|
|
|
|
procedure TCustomColorListBox.DoGetColors;
|
|
begin
|
|
if Assigned(OnGetColors) then
|
|
OnGetColors(Self, Items)
|
|
end;
|
|
|
|
procedure TCustomColorListBox.DoSelectionChange(User: Boolean);
|
|
begin
|
|
if User then
|
|
begin
|
|
// if custom color has been selected
|
|
if (cbCustomColor in Style) and (ItemIndex = 0) then
|
|
PickCustomColor;
|
|
|
|
// select color
|
|
if ItemIndex >= 0 then
|
|
FSelected := Colors[ItemIndex];
|
|
end;
|
|
|
|
// call OnSelectionChange
|
|
inherited DoSelectionChange(User);
|
|
end;
|
|
|
|
function TCustomColorListBox.PickCustomColor: Boolean;
|
|
var
|
|
FreeDialog: boolean;
|
|
begin
|
|
if csDesigning in ComponentState then
|
|
exit(false);
|
|
|
|
FreeDialog := FColorDialog = nil;
|
|
if FreeDialog then
|
|
FColorDialog := TColorDialog.Create(GetTopParent);
|
|
try
|
|
FColorDialog.Color := Colors[0];
|
|
result := FColorDialog.Execute;
|
|
if result then
|
|
begin
|
|
Items.Objects[0] := TObject(PtrInt(FColorDialog.Color));
|
|
Invalidate;
|
|
end;
|
|
finally
|
|
if FreeDialog then
|
|
FreeAndNil(FColorDialog);
|
|
end;
|
|
end;
|
|
|
|
procedure TCustomColorListBox.Notification(AComponent: TComponent; Operation: TOperation);
|
|
begin
|
|
inherited Notification(AComponent, Operation);
|
|
if (Operation = opRemove) and (AComponent = FColorDialog) then
|
|
FColorDialog := nil;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
end.
|