1 {
2 TColorBox is component that displays colors in a combobox
3 TColorListBox is component that displays colors in a listbox
4
5 Copyright (C) 2005 Darius Blaszijk
6
7 *****************************************************************************
8 This file is part of the Lazarus Component Library (LCL)
9
10 See the file COPYING.modifiedLGPL.txt, included in this distribution,
11 for details about the license.
12 *****************************************************************************
13 }
14
15 unit ColorBox;
16
17 {$mode objfpc}
18 {$H+}
19
20 interface
21
22 uses
23 LResources, SysUtils, Types, Classes,
24 LCLProc, LCLType, LCLStrConsts, Graphics, Controls, Forms, Dialogs, StdCtrls;
25
26 const
27 cDefaultColorRectWidth = 14;
28 cDefaultColorRectOffset = 3;
29
30 type
31 { TCustomColorBox }
32
33 TCustomColorBox = class;
34 TColorBoxStyles = (cbStandardColors, // 16 standard colors (look at graphics.pp)
35 cbExtendedColors, // 4 extended colors (look at graphics.pp)
36 cbSystemColors, // system colors (look at graphics.pp)
37 cbIncludeNone, // include clNone
38 cbIncludeDefault, // include clDefault
39 cbCustomColor, // first color is customizable
40 cbPrettyNames, // use good looking color names - like Red for clRed
41 cbCustomColors); // call OnGetColors after all other colors processing
42 TColorBoxStyle = set of TColorBoxStyles;
43 TGetColorsEvent = procedure(Sender: TCustomColorBox; Items: TStrings) of object;
44
45 TCustomColorBox = class(TCustomComboBox)
46 private
47 FColorRectWidth: Integer;
48 FColorRectOffset: Integer;
49 FDefaultColorColor: TColor;
50 FNoneColorColor: TColor;
51 FOnGetColors: TGetColorsEvent;
52 FStyle: TColorBoxStyle;
53 FSelected: TColor;
GetColornull54 function GetColor(Index : Integer): TColor;
GetColorNamenull55 function GetColorName(Index: Integer): string;
GetColorRectWidthnull56 function GetColorRectWidth: Integer;
GetSelectednull57 function GetSelected: TColor;
58 procedure SetColorRectWidth(AValue: Integer);
59 procedure SetColorRectOffset(AValue: Integer);
60 procedure SetDefaultColorColor(const AValue: TColor);
61 procedure SetNoneColorColor(const AValue: TColor);
62 procedure SetSelected(Value: TColor);
63 procedure SetStyle(const AValue: TColorBoxStyle); reintroduce;
64 procedure ColorProc(const s: AnsiString);
65 procedure UpdateCombo;
66 protected
ColorRectWidthStorednull67 function ColorRectWidthStored: Boolean;
68 procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
69 procedure SetColorList;
70 procedure Loaded; override;
71 procedure InitializeWnd; override;
72 procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
73 const AXProportion, AYProportion: Double); override;
74 procedure DoGetColors; virtual;
75 procedure CloseUp; override;
PickCustomColornull76 function PickCustomColor: Boolean; virtual;
77 public
78 constructor Create(AOwner: TComponent); override;
79 property ColorRectWidth: Integer read GetColorRectWidth write SetColorRectWidth stored ColorRectWidthStored;
80 property ColorRectOffset: Integer read FColorRectOffset write SetColorRectOffset default cDefaultColorRectOffset;
81 property Style: TColorBoxStyle read FStyle write SetStyle
82 default [cbStandardColors, cbExtendedColors, cbSystemColors];
83 property Colors[Index: Integer]: TColor read GetColor;
84 property ColorNames[Index: Integer]: string read GetColorName;
85 property Selected: TColor read GetSelected write SetSelected default clBlack;
86 property DefaultColorColor: TColor read FDefaultColorColor write SetDefaultColorColor default clBlack;
87 property NoneColorColor: TColor read FNoneColorColor write SetNoneColorColor default clBlack;
88 property OnGetColors: TGetColorsEvent read FOnGetColors write FOnGetColors;
89 end;
90
91 { TColorBox }
92
93 TColorBox = class(TCustomColorBox)
94 published
95 property ColorRectWidth;
96 property ColorRectOffset;
97 property DefaultColorColor;
98 property NoneColorColor;
99 property Selected;
100 property Style;
101 property OnGetColors;
102
103 property Align;
104 property Anchors;
105 property ArrowKeysTraverseList;
106 property AutoComplete;
107 property AutoCompleteText;
108 property AutoDropDown;
109 property AutoSelect;
110 property AutoSize;
111 property BidiMode;
112 property BorderSpacing;
113 property Color;
114 property Constraints;
115 property DragCursor;
116 property DragMode;
117 property DropDownCount;
118 property Enabled;
119 property Font;
120 property ItemHeight;
121 property ItemWidth;
122 property OnChange;
123 property OnChangeBounds;
124 property OnClick;
125 property OnCloseUp;
126 property OnContextPopup;
127 property OnDblClick;
128 property OnDragDrop;
129 property OnDragOver;
130 property OnEndDrag;
131 property OnDropDown;
132 property OnEditingDone;
133 property OnEnter;
134 property OnExit;
135 property OnKeyDown;
136 property OnKeyPress;
137 property OnKeyUp;
138 property OnMouseDown;
139 property OnMouseEnter;
140 property OnMouseLeave;
141 property OnMouseMove;
142 property OnMouseUp;
143 property OnMouseWheel;
144 property OnMouseWheelDown;
145 property OnMouseWheelUp;
146 property OnStartDrag;
147 property OnSelect;
148 property OnUTF8KeyPress;
149 property ParentBidiMode;
150 property ParentColor;
151 property ParentFont;
152 property ParentShowHint;
153 property PopupMenu;
154 property ShowHint;
155 property TabOrder;
156 property TabStop;
157 property Visible;
158 end;
159
160 { TCustomColorListBox }
161
162 TCustomColorListBox = class;
163 TLBGetColorsEvent = procedure(Sender: TCustomColorListBox; Items: TStrings) of object;
164
165 TCustomColorListBox = class(TCustomListBox)
166 private
167 FColorRectWidth: Integer;
168 FColorRectOffset: Integer;
169 FDefaultColorColor: TColor;
170 FNoneColorColor: TColor;
171 FOnGetColors: TLBGetColorsEvent;
172 FSelected: TColor;
173 FStyle: TColorBoxStyle;
GetColorRectWidthnull174 function GetColorRectWidth: Integer;
GetColorsnull175 function GetColors(Index : Integer): TColor;
GetColorNamenull176 function GetColorName(Index: Integer): string;
GetSelectednull177 function GetSelected: TColor;
178 procedure SetColorRectOffset(AValue: Integer);
179 procedure SetColorRectWidth(AValue: Integer);
180 procedure SetColors(Index: Integer; AValue: TColor);
181 procedure SetDefaultColorColor(const AValue: TColor);
182 procedure SetNoneColorColor(const AValue: TColor);
183 procedure SetSelected(Value: TColor);
184 procedure SetStyle(const AValue: TColorBoxStyle); reintroduce;
185 procedure ColorProc(const s: AnsiString);
186 protected
ColorRectWidthStorednull187 function ColorRectWidthStored: Boolean;
188 procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
189 procedure SetColorList;
190 procedure Loaded; override;
191 procedure InitializeWnd; override;
192 procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
193 const AXProportion, AYProportion: Double); override;
194 procedure DoGetColors; virtual;
195 procedure DoSelectionChange(User: Boolean); override;
PickCustomColornull196 function PickCustomColor: Boolean; virtual;
197 public
198 constructor Create(AOwner: TComponent); override;
199 property ColorRectWidth: Integer read GetColorRectWidth write SetColorRectWidth stored ColorRectWidthStored;
200 property ColorRectOffset: Integer read FColorRectOffset write SetColorRectOffset default cDefaultColorRectOffset;
201 property Style: TColorBoxStyle read FStyle write SetStyle
202 default [cbStandardColors, cbExtendedColors, cbSystemColors];
203 property Colors[Index: Integer]: TColor read GetColors write SetColors;
204 property ColorNames[Index: Integer]: string read GetColorName;
205 property Selected: TColor read GetSelected write SetSelected default clBlack;
206 property DefaultColorColor: TColor read FDefaultColorColor write SetDefaultColorColor default clBlack;
207 property NoneColorColor: TColor read FNoneColorColor write SetNoneColorColor default clBlack;
208 property OnGetColors: TLBGetColorsEvent read FOnGetColors write FOnGetColors;
209 end;
210
211 { TColorListBox }
212
213 TColorListBox = class(TCustomColorListBox)
214 published
215 property ColorRectWidth;
216 property ColorRectOffset;
217 property DefaultColorColor;
218 property NoneColorColor;
219 property Selected;
220 property Style;
221 property OnGetColors;
222
223 property Align;
224 property Anchors;
225 property BidiMode;
226 property BorderSpacing;
227 property BorderStyle;
228 property ClickOnSelChange;
229 property Color;
230 property Constraints;
231 property DragCursor;
232 property DragKind;
233 property DragMode;
234 property ExtendedSelect;
235 property Enabled;
236 property Font;
237 property IntegralHeight;
238 property ItemHeight;
239 property OnChangeBounds;
240 property OnClick;
241 property OnContextPopup;
242 property OnDblClick;
243 property OnDragDrop;
244 property OnDragOver;
245 property OnEnter;
246 property OnEndDrag;
247 property OnExit;
248 property OnKeyPress;
249 property OnKeyDown;
250 property OnKeyUp;
251 property OnMouseDown;
252 property OnMouseEnter;
253 property OnMouseLeave;
254 property OnMouseMove;
255 property OnMouseUp;
256 property OnMouseWheel;
257 property OnMouseWheelDown;
258 property OnMouseWheelUp;
259 property OnResize;
260 property OnSelectionChange;
261 property OnShowHint;
262 property OnStartDrag;
263 property OnUTF8KeyPress;
264 property ParentBidiMode;
265 property ParentColor;
266 property ParentShowHint;
267 property ParentFont;
268 property PopupMenu;
269 property ShowHint;
270 property TabOrder;
271 property TabStop;
272 property TopIndex;
273 property Visible;
274 end;
275
276 procedure Register;
277
278 implementation
279
280 {------------------------------------------------------------------------------}
281 procedure Register;
282 begin
283 RegisterComponents('Additional', [TColorBox, TColorListBox]);
284 end;
285
GetPrettyColorNamenull286 function GetPrettyColorName(ColorName: String): String;
287
FindInMapnull288 function FindInMap(ColorName: String; out NewColorName: String): Boolean;
289 var
290 Color: TColor;
291 begin
292 Result := IdentToColor(ColorName, Color);
293 if Result then
294 begin
295 { workaround for a bug in fpc 2.2.2 }
296 if Color=clScrollBar then
297 NewColorName := rsScrollBarColorCaption
298 else
299 case Color of
300 clBlack : NewColorName := rsBlackColorCaption;
301 clMaroon : NewColorName := rsMaroonColorCaption;
302 clGreen : NewColorName := rsGreenColorCaption;
303 clOlive : NewColorName := rsOliveColorCaption;
304 clNavy : NewColorName := rsNavyColorCaption;
305 clPurple : NewColorName := rsPurpleColorCaption;
306 clTeal : NewColorName := rsTealColorCaption;
307 clGray : NewColorName := rsGrayColorCaption;
308 clSilver : NewColorName := rsSilverColorCaption;
309 clRed : NewColorName := rsRedColorCaption;
310 clLime : NewColorName := rsLimeColorCaption;
311 clYellow : NewColorName := rsYellowColorCaption;
312 clBlue : NewColorName := rsBlueColorCaption;
313 clFuchsia : NewColorName := rsFuchsiaColorCaption;
314 clAqua : NewColorName := rsAquaColorCaption;
315 clWhite : NewColorName := rsWhiteColorCaption;
316 clMoneyGreen : NewColorName := rsMoneyGreenColorCaption;
317 clSkyBlue : NewColorName := rsSkyBlueColorCaption;
318 clCream : NewColorName := rsCreamColorCaption;
319 clMedGray : NewColorName := rsMedGrayColorCaption;
320 clNone : NewColorName := rsNoneColorCaption;
321 clDefault : NewColorName := rsDefaultColorCaption;
322 clBackground : NewColorName := rsBackgroundColorCaption;
323 clActiveCaption : NewColorName := rsActiveCaptionColorCaption;
324 clInactiveCaption : NewColorName := rsInactiveCaptionColorCaption;
325 clMenu : NewColorName := rsMenuColorCaption;
326 clWindow : NewColorName := rsWindowColorCaption;
327 clWindowFrame : NewColorName := rsWindowFrameColorCaption;
328 clMenuText : NewColorName := rsMenuTextColorCaption;
329 clWindowText : NewColorName := rsWindowTextColorCaption;
330 clCaptionText : NewColorName := rsCaptionTextColorCaption;
331 clActiveBorder : NewColorName := rsActiveBorderColorCaption;
332 clInactiveBorder : NewColorName := rsInactiveBorderColorCaption;
333 clAppWorkspace : NewColorName := rsAppWorkspaceColorCaption;
334 clHighlight : NewColorName := rsHighlightColorCaption;
335 clHighlightText : NewColorName := rsHighlightTextColorCaption;
336 clBtnFace : NewColorName := rsBtnFaceColorCaption;
337 clBtnShadow : NewColorName := rsBtnShadowColorCaption;
338 clGrayText : NewColorName := rsGrayTextColorCaption;
339 clBtnText : NewColorName := rsBtnTextColorCaption;
340 clInactiveCaptionText : NewColorName := rsInactiveCaptionText;
341 clBtnHighlight : NewColorName := rsBtnHighlightColorCaption;
342 cl3DDkShadow : NewColorName := rs3DDkShadowColorCaption;
343 cl3DLight : NewColorName := rs3DLightColorCaption;
344 clInfoText : NewColorName := rsInfoTextColorCaption;
345 clInfoBk : NewColorName := rsInfoBkColorCaption;
346 clHotLight : NewColorName := rsHotLightColorCaption;
347 clGradientActiveCaption : NewColorName := rsGradientActiveCaptionColorCaption;
348 clGradientInactiveCaption : NewColorName := rsGradientInactiveCaptionColorCaption;
349 clMenuHighlight : NewColorName := rsMenuHighlightColorCaption;
350 clMenuBar : NewColorName := rsMenuBarColorCaption;
351 clForm : NewColorName := rsFormColorCaption;
352 else
353 Result := False;
354 end;
355 end;
356 end;
357
358 begin
359 // check in color map
360 if not FindInMap(ColorName, Result) then
361 begin
362 Result := ColorName;
363 if Copy(Result, 1, 2) = 'cl' then
364 Delete(Result, 1, 2);
365 end;
366 end;
367
368 {------------------------------------------------------------------------------
369 Method: TCustomColorBox.Create
370 Params: AOwner
371 Returns: Nothing
372
373 Use Create to create an instance of TCustomColorBox and initialize all properties
374 and variables.
375
376 ------------------------------------------------------------------------------}
377 constructor TCustomColorBox.Create(AOwner: TComponent);
378 begin
379 inherited Create(AOwner);
380 inherited Style := csOwnerDrawFixed;
381 inherited ReadOnly := True;
382
383 FColorRectWidth := -1;
384 FColorRectOffset := cDefaultColorRectOffset;
385 FStyle := [cbStandardColors, cbExtendedColors, cbSystemColors];
386 FNoneColorColor := clBlack;
387 FDefaultColorColor := clBlack;
388 FSelected := clBlack;
389 SetColorList;
390 end;
391 {------------------------------------------------------------------------------
392 Method: TCustomColorBox.GetSelected
393 Params: None
394 Returns: TColor
395
396 Use GetSelected to convert the item selected into a system color.
397
398 ------------------------------------------------------------------------------}
TCustomColorBox.GetSelectednull399 function TCustomColorBox.GetSelected: TColor;
400 begin
401 if HandleAllocated then
402 begin
403 if ItemIndex <> -1 then
404 begin
405 Result := Colors[ItemIndex];
406 // keep FSelected in sync
407 if FSelected <> Result then
408 begin
409 // DebugLn('WARNING TCustomColorBox: FSelected out of sync with Colors[0]');
410 FSelected := Result;
411 end;
412 end else
413 Result := FSelected;
414 end
415 else
416 Result := FSelected;
417 end;
418
419 procedure TCustomColorBox.SetColorRectWidth(AValue: Integer);
420 begin
421 if FColorRectWidth = AValue then Exit;
422 FColorRectWidth := AValue;
423 Invalidate;
424 end;
425
426 procedure TCustomColorBox.SetColorRectOffset(AValue: Integer);
427 begin
428 if FColorRectOffset = AValue then Exit;
429 FColorRectOffset := AValue;
430 Invalidate;
431 end;
432
433 procedure TCustomColorBox.SetDefaultColorColor(const AValue: TColor);
434 begin
435 if FDefaultColorColor <> AValue then
436 begin
437 FDefaultColorColor := AValue;
438 invalidate;
439 end;
440 end;
441
442 procedure TCustomColorBox.SetNoneColorColor(const AValue: TColor);
443 begin
444 if FNoneColorColor <> AValue then
445 begin
446 FNoneColorColor := AValue;
447 invalidate;
448 end;
449 end;
450
451 {------------------------------------------------------------------------------
452 Method: TCustomColorBox.GetColor
453 Params: Index
454 Returns: Color at position Index
455
456 Used as read procedure from Colors property.
457
458 ------------------------------------------------------------------------------}
459
GetColornull460 function TCustomColorBox.GetColor(Index : Integer): TColor;
461 begin
462 Result := PtrInt(Items.Objects[Index])
463 end;
464
GetColorNamenull465 function TCustomColorBox.GetColorName(Index: Integer): string;
466 begin
467 Result := Items[Index];
468 end;
469
GetColorRectWidthnull470 function TCustomColorBox.GetColorRectWidth: Integer;
471 begin
472 if ColorRectWidthStored then
473 Result := FColorRectWidth
474 else
475 Result := Scale96ToFont(cDefaultColorRectWidth);
476 end;
477
478 {------------------------------------------------------------------------------
479 Method: TCustomColorBox.SetSelected
480 Params: Value
481 Returns: Nothing
482
483 Use SetSelected to set the item in the ColorBox when appointed a color
484 from code.
485
486 ------------------------------------------------------------------------------}
487 procedure TCustomColorBox.SetSelected(Value: TColor);
488 begin
489 if FSelected = Value then
490 Exit;
491
492 FSelected := Value;
493 UpdateCombo;
494 inherited Change;
495 end;
496
497 procedure TCustomColorBox.SetStyle(const AValue: TColorBoxStyle);
498 begin
499 if FStyle <> AValue then
500 begin
501 FStyle := AValue;
502 SetColorList;
503 end;
504 end;
505
506 procedure TCustomColorBox.ColorProc(const s: AnsiString);
507 var
508 AColor: TColor;
509 Index: Integer;
510 ColorCaption: String;
511 begin
512 if IdentToColor(s, AColor) then
513 begin
514 if AColor = clWhite then
515 AColor := AColor;
516 // check clDefault
517 if not (cbIncludeDefault in Style) and (AColor = clDefault) then
518 Exit;
519 // check clNone
520 if not (cbIncludeNone in Style) and (AColor = clNone) then
521 Exit;
522 // check System colors
523 if not (cbSystemColors in Style) and ((AColor and SYS_COLOR_BASE) <> 0) then
524 Exit;
525 // check Standard, Extended colors
526 if ([cbStandardColors, cbExtendedColors] * Style <> [cbStandardColors, cbExtendedColors]) and
527 ColorIndex(AColor, Index) then
528 begin
529 if not (cbStandardColors in Style) and (Index < StandardColorsCount) then
530 Exit;
531 if not (cbExtendedColors in Style) and
532 (Index < StandardColorsCount + ExtendedColorCount) and
533 (Index >= StandardColorsCount) then
534 Exit;
535 end;
536
537 if cbPrettyNames in Style then
538 ColorCaption := GetPrettyColorName(s)
539 else
540 ColorCaption := s;
541
542 Items.AddObject(ColorCaption, TObject(PtrInt(AColor)));
543 end;
544 end;
545
ColorRectWidthStorednull546 function TCustomColorBox.ColorRectWidthStored: Boolean;
547 begin
548 Result := FColorRectWidth >= 0;
549 end;
550
551 procedure TCustomColorBox.DoAutoAdjustLayout(
552 const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double
553 );
554 begin
555 inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion);
556
557 if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
558 begin
559 if ColorRectWidthStored then
560 FColorRectWidth := Round(FColorRectWidth * AXProportion);
561 Invalidate;
562 end;
563 end;
564
565 procedure TCustomColorBox.UpdateCombo;
566 var
567 c: integer;
568 begin
569 if HandleAllocated then
570 begin
571 for c := Ord(cbCustomColor in Style) to Items.Count - 1 do
572 begin
573 if Colors[c] = FSelected then
574 begin
575 ItemIndex := c;
576 Exit;
577 end;
578 end;
579 if cbCustomColor in Style then
580 begin
581 Items.Objects[0] := TObject(PtrInt(FSelected));
582 ItemIndex := 0;
583 Invalidate;
584 end
585 else
586 ItemIndex := -1;
587 end;
588 end;
589
590 {------------------------------------------------------------------------------
591 Method: TCustomColorBox.DrawItem
592 Params: Index, Rect, State
593 Returns: Nothing
594
595 Use DrawItem to customdraw an item in the ColorBox. A color preview is drawn
596 and the item rectangle is made smaller and given to the inherited method to
597 draw the corresponding text. The Brush color and Pen color where changed and
598 reset to their original values.
599
600 ------------------------------------------------------------------------------}
601 procedure TCustomColorBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
602 var
603 r: TRect;
604 BrushColor, PenColor, NewColor: TColor;
605 noFill: Boolean;
606 begin
607 if Index = -1 then
608 Exit;
609
610 r.top := Rect.top + ColorRectOffset;
611 r.bottom := Rect.bottom - ColorRectOffset;
612 r.left := Rect.left + ColorRectOffset;
613 r.right := r.left + ColorRectWidth;
614
615 if not(odBackgroundPainted in State) then
616 Canvas.FillRect(Rect);
617
618 BrushColor := Canvas.Brush.Color;
619 PenColor := Canvas.Pen.Color;
620
621 NewColor := Colors[Index];
622 noFill := NewColor = clNone;
623 if noFill then
624 NewColor := NoneColorColor
625 else
626 if NewColor = clDefault then
627 NewColor := DefaultColorColor;
628
629 Canvas.Brush.Color := NewColor;
630 Canvas.Pen.Color := clBlack;
631
632 r := BiDiFlipRect(r, Rect, UseRightToLeftAlignment);
633 Canvas.Rectangle(r);
634
635 if noFill then
636 begin
637 Canvas.Line(r.Left, r.Top, r.Right-1, r.Bottom-1);
638 Canvas.Line(r.Left, r.Bottom-1, r.Right-1, r.Top);
639 end;
640
641 Canvas.Brush.Color := BrushColor;
642 Canvas.Pen.Color := PenColor;
643
644 r := Rect;
645 r.left := r.left + ColorRectWidth + ColorRectOffset + 1;
646
647 Include(State, odBackgroundPainted);
648 inherited DrawItem(Index, BidiFlipRect(r, Rect, UseRightToLeftAlignment), State);
649 end;
650 {------------------------------------------------------------------------------
651 Method: TCustomColorBox.SetColorList
652 Params: None
653 Returns: Nothing
654
655 Use SetColorList to fill the itemlist in the ColorBox with the right color
656 entries. Based on the value of the Palette property.
657
658 ------------------------------------------------------------------------------}
659 procedure TCustomColorBox.SetColorList;
660 var
661 OldSelected: Integer;
662 begin
663 // we need to wait while we finish loading since we depend on style and OnGetColors event
664 if (csLoading in ComponentState) then
665 Exit;
666
667 OldSelected := FSelected;
668 with Items do
669 begin
670 Clear;
671 if cbCustomColor in Style then
672 Items.AddObject(rsCustomColorCaption, TObject(PtrInt(clBlack)));
673 GetColorValues(@ColorProc);
674 if (cbCustomColors in Style) then
675 DoGetColors;
676 end;
677 Selected := OldSelected;
678 end;
679
680 procedure TCustomColorBox.Loaded;
681 begin
682 inherited Loaded;
683 SetColorList;
684 end;
685
686 procedure TCustomColorBox.InitializeWnd;
687 begin
688 inherited InitializeWnd;
689 UpdateCombo;
690 end;
691
692 procedure TCustomColorBox.DoGetColors;
693 begin
694 if Assigned(OnGetColors) then
695 OnGetColors(Self, Items)
696 end;
697
698 procedure TCustomColorBox.CloseUp;
699 begin
700 if (cbCustomColor in Style) and (ItemIndex = 0) then // custom color has been selected
701 PickCustomColor;
702 if ItemIndex <> -1 then
703 Selected := Colors[ItemIndex];
704 inherited CloseUp;
705 end;
706
TCustomColorBox.PickCustomColornull707 function TCustomColorBox.PickCustomColor: Boolean;
708 begin
709 if csDesigning in ComponentState then
710 begin
711 Result := False;
712 Exit;
713 end;
714
715 with TColorDialog.Create(Self) do
716 begin
717 Color := Colors[0];
718 Result := Execute;
719 if Result then
720 begin
721 Items.Objects[0] := TObject(PtrInt(Color));
722 invalidate;
723 end;
724 Free;
725 end;
726 end;
727
728 {------------------------------------------------------------------------------}
729 {------------------------------------------------------------------------------
730 Method: TCustomColorListBox.Create
731 Params: AOwner
732 Returns: Nothing
733
734 Use Create to create an instance of TCustomColorListBox and initialize all properties
735 and variables.
736
737 ------------------------------------------------------------------------------}
738 constructor TCustomColorListBox.Create(AOwner: TComponent);
739 begin
740 inherited Create(AOwner);
741 inherited Style := lbOwnerDrawFixed;
742 FColorRectWidth := -1;
743 FColorRectOffset := cDefaultColorRectOffset;
744 FStyle := [cbStandardColors, cbExtendedColors, cbSystemColors];
745 FNoneColorColor := clBlack;
746 FDefaultColorColor := clBlack;
747 FSelected := clBlack;
748
749 SetColorList;
750 end;
751 {------------------------------------------------------------------------------
752 Method: TCustomColorListBox.GetSelected
753 Params: None
754 Returns: TColor
755
756 Use GetSelected to convert the item selected into a system color.
757
758 ------------------------------------------------------------------------------}
GetSelectednull759 function TCustomColorListBox.GetSelected: TColor;
760 begin
761 if HandleAllocated then
762 begin
763 if ItemIndex <> -1 then
764 Result := Colors[ItemIndex]
765 else
766 Result := FSelected
767 end
768 else
769 Result := FSelected;
770 end;
771
772 procedure TCustomColorListBox.SetColorRectOffset(AValue: Integer);
773 begin
774 if FColorRectOffset = AValue then Exit;
775 FColorRectOffset := AValue;
776 Invalidate;
777 end;
778
779 procedure TCustomColorListBox.SetColorRectWidth(AValue: Integer);
780 begin
781 if FColorRectWidth = AValue then Exit;
782 FColorRectWidth := AValue;
783 Invalidate;
784 end;
785
786 procedure TCustomColorListBox.SetColors(Index: Integer; AValue: TColor);
787 begin
788 if Colors[Index]=AValue then exit;
789 Items.Objects[Index]:=TObject(PtrInt(AValue));
790 Invalidate;
791 end;
792
793 procedure TCustomColorListBox.SetDefaultColorColor(const AValue: TColor);
794 begin
795 if FDefaultColorColor <> AValue then
796 begin
797 FDefaultColorColor := AValue;
798 invalidate;
799 end;
800 end;
801
802 procedure TCustomColorListBox.SetNoneColorColor(const AValue: TColor);
803 begin
804 if FNoneColorColor <> AValue then
805 begin
806 FNoneColorColor := AValue;
807 invalidate;
808 end;
809 end;
810
811 {------------------------------------------------------------------------------
812 Method: TCustomColorListBox.GetColors
813 Params: Index
814 Returns: Color at position Index
815
816 Used as read procedure from Colors property.
817
818 ------------------------------------------------------------------------------}
TCustomColorListBox.GetColorsnull819 function TCustomColorListBox.GetColors(Index : Integer): TColor;
820 begin
821 Result := PtrInt(Items.Objects[Index]);
822 end;
823
GetColorNamenull824 function TCustomColorListBox.GetColorName(Index: Integer): string;
825 begin
826 Result := Items[Index];
827 end;
828
TCustomColorListBox.GetColorRectWidthnull829 function TCustomColorListBox.GetColorRectWidth: Integer;
830 begin
831 if ColorRectWidthStored then
832 Result := FColorRectWidth
833 else
834 Result := Scale96ToFont(cDefaultColorRectWidth);
835 end;
836
837 {------------------------------------------------------------------------------
838 Method: TCustomColorListBox.SetSelected
839 Params: Value
840 Returns: Nothing
841
842 Use SetSelected to set the item in the ColorListBox when appointed a color
843 from code.
844
845 ------------------------------------------------------------------------------}
846 procedure TCustomColorListBox.SetSelected(Value: TColor);
847 var
848 c: integer;
849 begin
850 if HandleAllocated then
851 begin
852 FSelected := Value;
853 for c := Ord(cbCustomColor in Style) to Items.Count - 1 do
854 begin
855 if Colors[c] = Value then
856 begin
857 ItemIndex := c;
858 Exit;
859 end;
860 end;
861 if cbCustomColor in Style then
862 begin
863 Items.Objects[0] := TObject(PtrInt(Value));
864 ItemIndex := 0;
865 invalidate;
866 end
867 else
868 ItemIndex := -1;
869 end
870 else
871 FSelected := Value;
872 end;
873
874 procedure TCustomColorListBox.SetStyle(const AValue: TColorBoxStyle);
875 begin
876 if FStyle <> AValue then
877 begin
878 FStyle := AValue;
879 SetColorList;
880 end;
881 end;
882
883 procedure TCustomColorListBox.ColorProc(const s: AnsiString);
884 var
885 AColor: TColor;
886 Index: Integer;
887 ColorCaption: String;
888 begin
889 if IdentToColor(s, AColor) then
890 begin
891 // check clDefault
892 if not (cbIncludeDefault in Style) and (AColor = clDefault) then
893 Exit;
894 // check clNone
895 if not (cbIncludeNone in Style) and (AColor = clNone) then
896 Exit;
897 // check System colors
898 if not (cbSystemColors in Style) and ((AColor and SYS_COLOR_BASE) <> 0) then
899 Exit;
900 // check Standard, Extended colors
901 if ([cbStandardColors, cbExtendedColors] * Style <> [cbStandardColors, cbExtendedColors]) and
902 ColorIndex(AColor, Index) then
903 begin
904 if not (cbStandardColors in Style) and (Index < StandardColorsCount) then
905 Exit;
906 if not (cbExtendedColors in Style) and
907 (Index < StandardColorsCount + ExtendedColorCount) and
908 (Index >= StandardColorsCount) then
909 Exit;
910 end;
911
912 if cbPrettyNames in Style then
913 ColorCaption := GetPrettyColorName(s)
914 else
915 ColorCaption := s;
916
917 Items.AddObject(ColorCaption, TObject(PtrInt(AColor)));
918 end;
919 end;
920
ColorRectWidthStorednull921 function TCustomColorListBox.ColorRectWidthStored: Boolean;
922 begin
923 Result := FColorRectWidth >= 0;
924 end;
925
926 procedure TCustomColorListBox.DoAutoAdjustLayout(
927 const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double
928 );
929 begin
930 inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion);
931
932 if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
933 begin
934 if ColorRectWidthStored then
935 FColorRectWidth := Round(FColorRectWidth * AXProportion);
936 Invalidate;
937 end;
938 end;
939
940 {------------------------------------------------------------------------------
941 Method: TCustomColorListBox.DrawItem
942 Params: Index, Rect, State
943 Returns: Nothing
944
945 Use DrawItem to customdraw an item in the ColorListBox. A color preview is drawn
946 and the item rectangle is made smaller and given to the inherited method to
947 draw the corresponding text. The Brush color and Pen color where changed and
948 reset to their original values.
949
950 ------------------------------------------------------------------------------}
951 procedure TCustomColorListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
952 var
953 r: TRect;
954 BrushColor, PenColor, NewColor: TColor;
955 noFill: boolean;
956 begin
957 if Index < 0 then
958 Exit;
959
960 r.top := Rect.top + ColorRectOffset;
961 r.bottom := Rect.bottom - ColorRectOffset;
962 r.left := Rect.left + ColorRectOffset;
963 r.right := r.left + ColorRectWidth;
964
965 if not(odBackgroundPainted in State) then
966 Canvas.FillRect(Rect);
967
968 BrushColor := Canvas.Brush.Color;
969 PenColor := Canvas.Pen.Color;
970
971 NewColor := Colors[Index];
972 noFill := NewColor = clNone;
973 if noFill then
974 NewColor := NoneColorColor
975 else
976 if NewColor = clDefault then
977 NewColor := DefaultColorColor;
978
979 Canvas.Brush.Color := NewColor;
980 Canvas.Pen.Color := clBlack;
981
982 Canvas.Rectangle(BidiFlipRect(r, Rect, UseRightToLeftAlignment));
983
984 if noFill then
985 begin
986 Canvas.Line(r.Left, r.Top, r.Right-1, r.Bottom-1);
987 Canvas.Line(r.Left, r.Bottom-1, r.Right-1, r.Top);
988 end;
989
990 Canvas.Brush.Color := BrushColor;
991 Canvas.Pen.Color := PenColor;
992
993 r := Rect;
994 r.left := r.left + ColorRectWidth + ColorRectOffset + 1;
995
996 Include(State,odBackgroundPainted);
997 inherited DrawItem(Index, BidiFlipRect(r, Rect, UseRightToLeftAlignment), State);
998 end;
999 {------------------------------------------------------------------------------
1000 Method: TCustomColorListBox.SetColorList
1001 Params: None
1002 Returns: Nothing
1003
1004 Use SetColorList to fill the itemlist in the ColorListBox with the right color
1005 entries. Based on the value of the Palette property.
1006
1007 ------------------------------------------------------------------------------}
1008 procedure TCustomColorListBox.SetColorList;
1009 var
1010 OldSelected: Integer;
1011 begin
1012 // we need to wait while we finish loading since we depend on style and OnGetColors event
1013 if (csLoading in ComponentState) then
1014 Exit;
1015 OldSelected := FSelected;
1016 with Items do
1017 begin
1018 Clear;
1019 if cbCustomColor in Style then
1020 Items.AddObject(rsCustomColorCaption, TObject(PtrInt(clBlack)));
1021 GetColorValues(@ColorProc);
1022 if (cbCustomColors in Style) then
1023 DoGetColors;
1024 end;
1025 Selected := OldSelected;
1026 end;
1027
1028 procedure TCustomColorListBox.Loaded;
1029 begin
1030 inherited Loaded;
1031 SetColorList;
1032 end;
1033
1034 procedure TCustomColorListBox.InitializeWnd;
1035 begin
1036 inherited InitializeWnd;
1037 Selected := FSelected;
1038 end;
1039
1040 procedure TCustomColorListBox.DoGetColors;
1041 begin
1042 if Assigned(OnGetColors) then
1043 OnGetColors(Self, Items)
1044 end;
1045
1046 procedure TCustomColorListBox.DoSelectionChange(User: Boolean);
1047 begin
1048 if User then
1049 begin
1050 if (cbCustomColor in Style) and (ItemIndex = 0) then // custom color has been selected
1051 PickCustomColor;
1052 if ItemIndex <> -1 then
1053 FSelected := Colors[ItemIndex];
1054 end;
1055 inherited DoSelectionChange(User);
1056 end;
1057
TCustomColorListBox.PickCustomColornull1058 function TCustomColorListBox.PickCustomColor: Boolean;
1059 begin
1060 if csDesigning in ComponentState then
1061 begin
1062 Result := False;
1063 Exit;
1064 end;
1065
1066 with TColorDialog.Create(Self) do
1067 begin
1068 Color := Colors[0];
1069 Result := Execute;
1070 if Result then
1071 begin
1072 Items.Objects[0] := TObject(PtrInt(Color));
1073 invalidate;
1074 end;
1075 Free;
1076 end;
1077 end;
1078
1079 {------------------------------------------------------------------------------}
1080 end.
1081