source: trunk/Packages/Graphics32/GR32_Dsgn_Color.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 20.7 KB
Line 
1unit GR32_Dsgn_Color;
2
3(* ***** BEGIN LICENSE BLOCK *****
4 * Version: MPL 1.1 or LGPL 2.1 with linking exception
5 *
6 * The contents of this file are subject to the Mozilla Public License Version
7 * 1.1 (the "License"); you may not use this file except in compliance with
8 * the License. You may obtain a copy of the License at
9 * http://www.mozilla.org/MPL/
10 *
11 * Software distributed under the License is distributed on an "AS IS" basis,
12 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13 * for the specific language governing rights and limitations under the
14 * License.
15 *
16 * Alternatively, the contents of this file may be used under the terms of the
17 * Free Pascal modified version of the GNU Lesser General Public License
18 * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions
19 * of this license are applicable instead of those above.
20 * Please see the file LICENSE.txt for additional information concerning this
21 * license.
22 *
23 * The Original Code is Graphics32
24 *
25 * The Initial Developer of the Original Code is
26 * Alex A. Denisov
27 *
28 * Portions created by the Initial Developer are Copyright (C) 2000-2009
29 * the Initial Developer. All Rights Reserved.
30 *
31 * Contributor(s):
32 *
33 * ***** END LICENSE BLOCK ***** *)
34
35interface
36
37{$I GR32.inc}
38
39uses
40 Classes, SysUtils,
41{$IFDEF FPC}
42 RTLConsts, LazIDEIntf, PropEdits, Graphics, Dialogs, Forms,
43 {$IFDEF Windows}
44 Windows, Registry,
45 {$ENDIF}
46{$ELSE}
47 Consts,
48 DesignIntf, DesignEditors, VCLEditors,
49 Windows, Registry, Graphics, Dialogs, Forms, Controls,
50{$ENDIF}
51 GR32, GR32_Image;
52
53type
54 { TColorManager }
55 PColorEntry = ^TColorEntry;
56 TColorEntry = record
57 Name: string[31];
58 Color: TColor32;
59 end;
60
61 TColorManager = class(TList)
62 public
63 destructor Destroy; override;
64 procedure AddColor(const AName: string; AColor: TColor32);
65 procedure EnumColors(Proc: TGetStrProc);
66 function FindColor(const AName: string): TColor32;
67 function GetColor(const AName: string): TColor32;
68 function GetColorName(AColor: TColor32): string;
69 procedure RegisterDefaultColors;
70 procedure RemoveColor(const AName: string);
71 end;
72
73{$IFDEF COMPILER2010_UP}
74 TColor32Dialog = class(TCommonDialog)
75 private
76 FColor: TColor32;
77 FCustomColors: TStrings;
78 procedure SetCustomColors(Value: TStrings);
79 public
80 function Execute(ParentWnd: HWND): Boolean; override;
81 published
82 property Color: TColor32 read FColor write FColor default clBlack32;
83 property CustomColors: TStrings read FCustomColors write SetCustomColors;
84 property Ctl3D default True;
85 end;
86{$ENDIF}
87
88 { TColor32Property }
89 TColor32Property = class(TIntegerProperty
90{$IFDEF EXT_PROP_EDIT}
91 , ICustomPropertyListDrawing, ICustomPropertyDrawing
92 {$IFDEF COMPILER2005_UP}, ICustomPropertyDrawing80{$ENDIF}
93{$ENDIF}
94 )
95 public
96 function GetAttributes: TPropertyAttributes; override;
97 function GetValue: string; override;
98 procedure GetValues(Proc: TGetStrProc); override;
99 procedure SetValue(const Value: string); override;
100{$IFDEF EXT_PROP_EDIT}
101 procedure Edit; override;
102 { ICustomPropertyListDrawing }
103 procedure ListMeasureWidth(const Value: string; ACanvas: TCanvas; var AWidth: Integer);
104 procedure ListMeasureHeight(const Value: string; ACanvas: TCanvas; var AHeight: Integer);
105 procedure ListDrawValue(const Value: string; ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
106 { ICustomPropertyDrawing }
107 procedure PropDrawName(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
108 procedure PropDrawValue(ACanvas: TCanvas; const ARect: TRect; ASelected: Boolean);
109 {$IFDEF COMPILER2005_UP}
110 { ICustomPropertyDrawing80 }
111 function PropDrawNameRect(const ARect: TRect): TRect;
112 function PropDrawValueRect(const ARect: TRect): TRect;
113 {$ENDIF}
114{$ENDIF}
115 end;
116
117procedure RegisterColor(const AName: string; AColor: TColor32);
118procedure UnregisterColor(const AName: string);
119
120var ColorManager: TColorManager;
121
122implementation
123
124{$IFDEF COMPILER2010_UP}
125uses
126 GR32_Dsgn_ColorPicker;
127{$ENDIF}
128
129{ TColorManager }
130
131destructor TColorManager.Destroy;
132var
133 I: Integer;
134begin
135 for I := 0 to Count - 1 do FreeMem(Items[I], SizeOf(TColorEntry));
136 inherited;
137end;
138
139procedure TColorManager.AddColor(const AName: string; AColor: TColor32);
140var
141 NewEntry: PColorEntry;
142begin
143 New(NewEntry);
144 if NewEntry = nil then
145 raise Exception.Create('Could not allocate memory for color registration!');
146 with NewEntry^ do
147 begin
148 Name := ShortString(AName);
149 Color := AColor;
150 end;
151 Add(NewEntry);
152end;
153
154procedure TColorManager.EnumColors(Proc: TGetStrProc);
155var
156 I: Integer;
157begin
158 for I := 0 to Count - 1 do Proc(string(TColorEntry(Items[I]^).Name));
159end;
160
161function TColorManager.FindColor(const AName: string): TColor32;
162var
163 I: Integer;
164begin
165 Result := clBlack32;
166 for I := 0 to Count - 1 do
167 with TColorEntry(Items[I]^) do
168 if string(Name) = AName then
169 begin
170 Result := Color;
171 Break;
172 end;
173end;
174
175function TColorManager.GetColor(const AName: string): TColor32;
176var
177 S: string;
178
179 function HexToClr(const HexStr: string): Cardinal;
180 var
181 I: Integer;
182 C: Char;
183 begin
184 Result := 0;
185 for I := 1 to Length(HexStr) do
186 begin
187 C := HexStr[I];
188 case C of
189 '0'..'9': Result := Int64(16) * Result + (Ord(C) - $30);
190 'A'..'F': Result := Int64(16) * Result + (Ord(C) - $37);
191 'a'..'f': Result := Int64(16) * Result + (Ord(C) - $57);
192 else
193 raise EConvertError.Create('Illegal character in hex string');
194 end;
195 end;
196 end;
197
198begin
199 S := Trim(AName);
200 if S[1] = '$' then S := Copy(S, 2, Length(S) - 1);
201 if (S[1] = 'c') and (S[2] = 'l') then Result := FindColor(S)
202 else
203 try
204 Result := HexToClr(S);
205 except
206 Result := clBlack32;
207 end;
208end;
209
210function TColorManager.GetColorName(AColor: TColor32): string;
211var
212 I: Integer;
213begin
214 for I := 0 to Count - 1 do
215 with TColorEntry(Items[I]^) do
216 if Color = AColor then
217 begin
218 Result := string(TColorEntry(Items[I]^).Name);
219 Exit;
220 end;
221 Result := '$' + IntToHex(AColor, 8);
222end;
223
224procedure TColorManager.RegisterDefaultColors;
225begin
226 Capacity := 50;
227 AddColor('clBlack32', clBlack32);
228 AddColor('clDimGray32', clDimGray32);
229 AddColor('clGray32', clGray32);
230 AddColor('clLightGray32', clLightGray32);
231 AddColor('clWhite32', clWhite32);
232 AddColor('clMaroon32', clMaroon32);
233 AddColor('clGreen32', clGreen32);
234 AddColor('clOlive32', clOlive32);
235 AddColor('clNavy32', clNavy32);
236 AddColor('clPurple32', clPurple32);
237 AddColor('clTeal32', clTeal32);
238 AddColor('clRed32', clRed32);
239 AddColor('clLime32', clLime32);
240 AddColor('clYellow32', clYellow32);
241 AddColor('clBlue32', clBlue32);
242 AddColor('clFuchsia32', clFuchsia32);
243 AddColor('clAqua32', clAqua32);
244
245 AddColor('clTrWhite32', clTrWhite32);
246 AddColor('clTrBlack32', clTrBlack32);
247 AddColor('clTrRed32', clTrRed32);
248 AddColor('clTrGreen32', clTrGreen32);
249 AddColor('clTrBlue32', clTrBlue32);
250
251 AddColor('clAliceBlue32', clAliceBlue32);
252 AddColor('clAntiqueWhite32', clAntiqueWhite32);
253 AddColor('clAquamarine32', clAquamarine32);
254 AddColor('clAzure32', clAzure32);
255 AddColor('clBeige32', clBeige32);
256 AddColor('clBisque32', clBisque32);
257 AddColor('clBlancheDalmond32', clBlancheDalmond32);
258 AddColor('clBlueViolet32', clBlueViolet32);
259 AddColor('clBrown32', clBrown32);
260 AddColor('clBurlyWood32', clBurlyWood32);
261 AddColor('clCadetblue32', clCadetblue32);
262 AddColor('clChartReuse32', clChartReuse32);
263 AddColor('clChocolate32', clChocolate32);
264 AddColor('clCoral32', clCoral32);
265 AddColor('clCornFlowerBlue32', clCornFlowerBlue32);
266 AddColor('clCornSilk32', clCornSilk32);
267 AddColor('clCrimson32', clCrimson32);
268 AddColor('clDarkBlue32', clDarkBlue32);
269 AddColor('clDarkCyan32', clDarkCyan32);
270 AddColor('clDarkGoldenRod32', clDarkGoldenRod32);
271 AddColor('clDarkGray32', clDarkGray32);
272 AddColor('clDarkGreen32', clDarkGreen32);
273 AddColor('clDarkGrey32', clDarkGrey32);
274 AddColor('clDarkKhaki32', clDarkKhaki32);
275 AddColor('clDarkMagenta32', clDarkMagenta32);
276 AddColor('clDarkOliveGreen32', clDarkOliveGreen32);
277 AddColor('clDarkOrange32', clDarkOrange32);
278 AddColor('clDarkOrchid32', clDarkOrchid32);
279 AddColor('clDarkRed32', clDarkRed32);
280 AddColor('clDarkSalmon32', clDarkSalmon32);
281 AddColor('clDarkSeaGreen32', clDarkSeaGreen32);
282 AddColor('clDarkSlateBlue32', clDarkSlateBlue32);
283 AddColor('clDarkSlateGray32', clDarkSlateGray32);
284 AddColor('clDarkSlateGrey32', clDarkSlateGrey32);
285 AddColor('clDarkTurquoise32', clDarkTurquoise32);
286 AddColor('clDarkViolet32', clDarkViolet32);
287 AddColor('clDeepPink32', clDeepPink32);
288 AddColor('clDeepSkyBlue32', clDeepSkyBlue32);
289 AddColor('clDodgerBlue32', clDodgerBlue32);
290 AddColor('clFireBrick32', clFireBrick32);
291 AddColor('clFloralWhite32', clFloralWhite32);
292 AddColor('clGainsBoro32', clGainsBoro32);
293 AddColor('clGhostWhite32', clGhostWhite32);
294 AddColor('clGold32', clGold32);
295 AddColor('clGoldenRod32', clGoldenRod32);
296 AddColor('clGreenYellow32', clGreenYellow32);
297 AddColor('clGrey32', clGrey32);
298 AddColor('clHoneyDew32', clHoneyDew32);
299 AddColor('clHotPink32', clHotPink32);
300 AddColor('clIndianRed32', clIndianRed32);
301 AddColor('clIndigo32', clIndigo32);
302 AddColor('clIvory32', clIvory32);
303 AddColor('clKhaki32', clKhaki32);
304 AddColor('clLavender32', clLavender32);
305 AddColor('clLavenderBlush32', clLavenderBlush32);
306 AddColor('clLawnGreen32', clLawnGreen32);
307 AddColor('clLemonChiffon32', clLemonChiffon32);
308 AddColor('clLightBlue32', clLightBlue32);
309 AddColor('clLightCoral32', clLightCoral32);
310 AddColor('clLightCyan32', clLightCyan32);
311 AddColor('clLightGoldenRodYellow32', clLightGoldenRodYellow32);
312 AddColor('clLightGray32', clLightGray32);
313 AddColor('clLightGreen32', clLightGreen32);
314 AddColor('clLightGrey32', clLightGrey32);
315 AddColor('clLightPink32', clLightPink32);
316 AddColor('clLightSalmon32', clLightSalmon32);
317 AddColor('clLightSeagreen32', clLightSeagreen32);
318 AddColor('clLightSkyblue32', clLightSkyblue32);
319 AddColor('clLightSlategray32', clLightSlategray32);
320 AddColor('clLightSlategrey32', clLightSlategrey32);
321 AddColor('clLightSteelblue32', clLightSteelblue32);
322 AddColor('clLightYellow32', clLightYellow32);
323 AddColor('clLtGray32', clLtGray32);
324 AddColor('clMedGray32', clMedGray32);
325 AddColor('clDkGray32', clDkGray32);
326 AddColor('clMoneyGreen32', clMoneyGreen32);
327 AddColor('clLegacySkyBlue32', clLegacySkyBlue32);
328 AddColor('clCream32', clCream32);
329 AddColor('clLimeGreen32', clLimeGreen32);
330 AddColor('clLinen32', clLinen32);
331 AddColor('clMediumAquamarine32', clMediumAquamarine32);
332 AddColor('clMediumBlue32', clMediumBlue32);
333 AddColor('clMediumOrchid32', clMediumOrchid32);
334 AddColor('clMediumPurple32', clMediumPurple32);
335 AddColor('clMediumSeaGreen32', clMediumSeaGreen32);
336 AddColor('clMediumSlateBlue32', clMediumSlateBlue32);
337 AddColor('clMediumSpringGreen32', clMediumSpringGreen32);
338 AddColor('clMediumTurquoise32', clMediumTurquoise32);
339 AddColor('clMediumVioletRed32', clMediumVioletRed32);
340 AddColor('clMidnightBlue32', clMidnightBlue32);
341 AddColor('clMintCream32', clMintCream32);
342 AddColor('clMistyRose32', clMistyRose32);
343 AddColor('clMoccasin32', clMoccasin32);
344 AddColor('clNavajoWhite32', clNavajoWhite32);
345 AddColor('clOldLace32', clOldLace32);
346 AddColor('clOliveDrab32', clOliveDrab32);
347 AddColor('clOrange32', clOrange32);
348 AddColor('clOrangeRed32', clOrangeRed32);
349 AddColor('clOrchid32', clOrchid32);
350 AddColor('clPaleGoldenRod32', clPaleGoldenRod32);
351 AddColor('clPaleGreen32', clPaleGreen32);
352 AddColor('clPaleTurquoise32', clPaleTurquoise32);
353 AddColor('clPaleVioletred32', clPaleVioletred32);
354 AddColor('clPapayaWhip32', clPapayaWhip32);
355 AddColor('clPeachPuff32', clPeachPuff32);
356 AddColor('clPeru32', clPeru32);
357 AddColor('clPlum32', clPlum32);
358 AddColor('clPowderBlue32', clPowderBlue32);
359 AddColor('clPurple32', clPurple32);
360 AddColor('clRosyBrown32', clRosyBrown32);
361 AddColor('clRoyalBlue32', clRoyalBlue32);
362 AddColor('clSaddleBrown32', clSaddleBrown32);
363 AddColor('clSalmon32', clSalmon32);
364 AddColor('clSandyBrown32', clSandyBrown32);
365 AddColor('clSeaGreen32', clSeaGreen32);
366 AddColor('clSeaShell32', clSeaShell32);
367 AddColor('clSienna32', clSienna32);
368 AddColor('clSilver32', clSilver32);
369 AddColor('clSkyblue32', clSkyblue32);
370 AddColor('clSlateBlue32', clSlateBlue32);
371 AddColor('clSlateGray32', clSlateGray32);
372 AddColor('clSlateGrey32', clSlateGrey32);
373 AddColor('clSnow32', clSnow32);
374 AddColor('clSpringgreen32', clSpringgreen32);
375 AddColor('clSteelblue32', clSteelblue32);
376 AddColor('clTan32', clTan32);
377 AddColor('clThistle32', clThistle32);
378 AddColor('clTomato32', clTomato32);
379 AddColor('clTurquoise32', clTurquoise32);
380 AddColor('clViolet32', clViolet32);
381 AddColor('clWheat32', clWheat32);
382 AddColor('clWhitesmoke32', clWhitesmoke32);
383 AddColor('clYellowgreen32', clYellowgreen32);
384end;
385
386procedure TColorManager.RemoveColor(const AName: string);
387var
388 I: Integer;
389begin
390 for I := 0 to Count - 1 do
391 if CompareText(string(TColorEntry(Items[I]^).Name), AName) = 0 then
392 begin
393 Delete(I);
394 Break;
395 end;
396end;
397
398procedure RegisterColor(const AName: string; AColor: TColor32);
399begin
400 ColorManager.AddColor(AName, AColor);
401end;
402
403procedure UnregisterColor(const AName: string);
404begin
405 ColorManager.RemoveColor(AName);
406end;
407
408
409{ TColor32Dialog }
410
411{$IFDEF COMPILER2010_UP}
412procedure TColor32Dialog.SetCustomColors(Value: TStrings);
413begin
414 FCustomColors.Assign(Value);
415end;
416
417function TColor32Dialog.Execute(ParentWnd: HWND): Boolean;
418var
419 ColorPicker: TFormColorPicker;
420begin
421 ColorPicker := TFormColorPicker.Create(nil);
422 try
423 ColorPicker.Color := FColor;
424 Result := ColorPicker.ShowModal = mrOK;
425 if Result then
426 FColor := ColorPicker.Color;
427 finally
428 ColorPicker.Free;
429 end;
430end;
431{$ENDIF}
432
433
434{ TColor32Property }
435
436{$IFDEF EXT_PROP_EDIT}
437procedure TColor32Property.Edit;
438var
439{$IFDEF COMPILER2010_UP}
440 ColorDialog: TColor32Dialog;
441{$ELSE}
442 ColorDialog: TColorDialog;
443{$ENDIF}
444 IniFile: TRegIniFile;
445
446 procedure GetCustomColors;
447 begin
448 if BaseRegistryKey = '' then Exit;
449 IniFile := TRegIniFile.Create(BaseRegistryKey);
450 try
451 IniFile.ReadSectionValues(SCustomColors, ColorDialog.CustomColors);
452 except
453 { Ignore errors while reading values }
454 end;
455 end;
456
457 procedure SaveCustomColors;
458 var
459 I, P: Integer;
460 S: string;
461 begin
462 if IniFile <> nil then
463 with ColorDialog do
464 for I := 0 to CustomColors.Count - 1 do
465 begin
466 S := CustomColors.Strings[I];
467 P := Pos('=', S);
468 if P <> 0 then
469 begin
470 S := Copy(S, 1, P - 1);
471 IniFile.WriteString(SCustomColors, S, CustomColors.Values[S]);
472 end;
473 end;
474 end;
475
476begin
477 IniFile := nil;
478{$IFDEF COMPILER2010_UP}
479 ColorDialog := TColor32Dialog.Create(Application);
480{$ELSE}
481 ColorDialog := TColorDialog.Create(Application);
482{$ENDIF}
483 try
484 GetCustomColors;
485 ColorDialog.Color := GetOrdValue;
486 ColorDialog.HelpContext := 25010;
487{$IFNDEF COMPILER2010_UP}
488 ColorDialog.Options := [cdShowHelp];
489{$ENDIF}
490 if ColorDialog.Execute then
491 SetOrdValue(Cardinal(ColorDialog.Color));
492 SaveCustomColors;
493 finally
494 IniFile.Free;
495 ColorDialog.Free;
496 end;
497end;
498{$ENDIF}
499
500function TColor32Property.GetAttributes: TPropertyAttributes;
501begin
502 Result := [paMultiSelect, {$IFDEF EXT_PROP_EDIT}paDialog,{$ENDIF} paValueList,
503 paRevertable];
504end;
505
506procedure TColor32Property.GetValues(Proc: TGetStrProc);
507begin
508 try
509 ColorManager.EnumColors(Proc);
510 except
511 on E: Exception do ShowMessage(E.Message);
512 end;
513end;
514
515function TColor32Property.GetValue: string;
516begin
517 try
518 Result := ColorManager.GetColorName(Cardinal(GetOrdValue));
519 except
520 on E: Exception do ShowMessage(E.Message);
521 end;
522end;
523
524procedure TColor32Property.SetValue(const Value: string);
525begin
526 try
527 SetOrdValue(Cardinal(ColorManager.GetColor(Value)));
528 Modified;
529 except
530 on E: Exception do ShowMessage(E.Message);
531 end;
532end;
533
534{$IFDEF EXT_PROP_EDIT}
535
536procedure TColor32Property.ListMeasureWidth(const Value: string; ACanvas: TCanvas; var AWidth: Integer);
537begin
538 // implementation dummie to satisfy interface. Don't change default value.
539end;
540
541procedure TColor32Property.ListMeasureHeight(const Value: string; ACanvas: TCanvas; var AHeight: Integer);
542begin
543 // implementation dummie to satisfy interface. Don't change default value.
544end;
545
546procedure TColor32Property.ListDrawValue(const Value: string; ACanvas: TCanvas;
547 const ARect: TRect; ASelected: Boolean);
548var
549 Right: Integer;
550 C: TColor32;
551 i, j: Integer;
552 W, H: Integer;
553 Bitmap32: TBitmap32;
554begin
555 try
556 Right := (ARect.Bottom - ARect.Top) + ARect.Left;
557 Bitmap32 := TBitmap32.Create;
558 try
559 W := Right - ARect.Left - 2;
560 H := ARect.Bottom - ARect.Top - 2;
561 Bitmap32.SetSize(W, H);
562 if Assigned(ColorManager) then
563 C := ColorManager.GetColor(Value)
564 else
565 C := clWhite32;
566 if (W > 8) and (H > 8) then
567 begin
568 if not (C and $FF000000 = $FF000000) then
569 begin
570 for j := 0 to H - 1 do
571 for i := 0 to W - 1 do
572 if Odd(i div 3) = Odd(j div 3) then
573 Bitmap32[i, j] := clBlack32
574 else
575 Bitmap32[i, j] := clWhite32;
576 end;
577 Bitmap32.FillRectT(0, 0, W, H, C);
578 end;
579 Bitmap32.FrameRectTS(0, 0, W, H, $DF000000);
580 Bitmap32.RaiseRectTS(1, 1, W - 1, H - 1, 20);
581 Bitmap32.DrawTo(ACanvas.Handle, ARect.Left + 1, ARect.Top + 1);
582 finally
583 Bitmap32.Free;
584 DefaultPropertyListDrawValue(Value, ACanvas,
585 Rect(Right, ARect.Top, ARect.Right, ARect.Bottom), ASelected);
586 end;
587 except
588 on E: Exception do ShowMessage(E.Message);
589 end;
590end;
591
592procedure TColor32Property.PropDrawValue(ACanvas: TCanvas; const ARect: TRect;
593 ASelected: Boolean);
594begin
595 if GetVisualValue <> '' then
596 ListDrawValue(GetVisualValue, ACanvas, ARect, True{ASelected})
597 else
598 DefaultPropertyDrawValue(Self, ACanvas, ARect);
599end;
600
601procedure TColor32Property.PropDrawName(ACanvas: TCanvas; const ARect: TRect;
602 ASelected: Boolean);
603begin
604 DefaultPropertyDrawName(Self, ACanvas, ARect);
605end;
606
607{$IFDEF COMPILER2005_UP}
608function TColor32Property.PropDrawNameRect(const ARect: TRect): TRect;
609begin
610 Result := ARect;
611end;
612
613function TColor32Property.PropDrawValueRect(const ARect: TRect): TRect;
614begin
615 Result := Rect(ARect.Left, ARect.Top, (ARect.Bottom - ARect.Top) + ARect.Left, ARect.Bottom);
616end;
617{$ENDIF}
618
619{$ENDIF}
620
621
622initialization
623 ColorManager := TColorManager.Create;
624 ColorManager.RegisterDefaultColors;
625
626finalization
627 ColorManager.Free;
628
629end.
Note: See TracBrowser for help on using the repository browser.