home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d123456 / DFS.ZIP / DFSClrBn.pas < prev    next >
Pascal/Delphi Source File  |  2001-06-28  |  31KB  |  1,018 lines
  1. {$I DFS.INC}  { Standard defines for all Delphi Free Stuff components }
  2.  
  3. {------------------------------------------------------------------------------}
  4. { TdfsColorButton v2.61                                                        }
  5. {------------------------------------------------------------------------------}
  6. { A Windows 95 and NT 4 style color selection button.  It displays a palette   }
  7. { of 20 color for fast selction and a button to bring up the color dialog.     }
  8. {                                                                              }
  9. { Copyright 2000-2001, Brad Stowers.  All Rights Reserved.                     }
  10. {                                                                              }
  11. { Copyright:                                                                   }
  12. { All Delphi Free Stuff (hereafter "DFS") source code is copyrighted by        }
  13. { Bradley D. Stowers (hereafter "author"), and shall remain the exclusive      }
  14. { property of the author.                                                      }
  15. {                                                                              }
  16. { Distribution Rights:                                                         }
  17. { You are granted a non-exlusive, royalty-free right to produce and distribute }
  18. { compiled binary files (executables, DLLs, etc.) that are built with any of   }
  19. { the DFS source code unless specifically stated otherwise.                    }
  20. { You are further granted permission to redistribute any of the DFS source     }
  21. { code in source code form, provided that the original archive as found on the }
  22. { DFS web site (http://www.delphifreestuff.com) is distributed unmodified. For }
  23. { example, if you create a descendant of TdfsColorButton, you must include in  }
  24. { the distribution package the colorbtn.zip file in the exact form that you    }
  25. { downloaded it from http://www.delphifreestuff.com/mine/files/colorbtn.zip.   }
  26. {                                                                              }
  27. { Restrictions:                                                                }
  28. { Without the express written consent of the author, you may not:              }
  29. {   * Distribute modified versions of any DFS source code by itself. You must  }
  30. {     include the original archive as you found it at the DFS site.            }
  31. {   * Sell or lease any portion of DFS source code. You are, of course, free   }
  32. {     to sell any of your own original code that works with, enhances, etc.    }
  33. {     DFS source code.                                                         }
  34. {   * Distribute DFS source code for profit.                                   }
  35. {                                                                              }
  36. { Warranty:                                                                    }
  37. { There is absolutely no warranty of any kind whatsoever with any of the DFS   }
  38. { source code (hereafter "software"). The software is provided to you "AS-IS", }
  39. { and all risks and losses associated with it's use are assumed by you. In no  }
  40. { event shall the author of the softare, Bradley D. Stowers, be held           }
  41. { accountable for any damages or losses that may occur from use or misuse of   }
  42. { the software.                                                                }
  43. {                                                                              }
  44. { Support:                                                                     }
  45. { Support is provided via the DFS Support Forum, which is a web-based message  }
  46. { system.  You can find it at http://www.delphifreestuff.com/discus/           }
  47. { All DFS source code is provided free of charge. As such, I can not guarantee }
  48. { any support whatsoever. While I do try to answer all questions that I        }
  49. { receive, and address all problems that are reported to me, you must          }
  50. { understand that I simply can not guarantee that this will always be so.      }
  51. {                                                                              }
  52. { Clarifications:                                                              }
  53. { If you need any further information, please feel free to contact me directly.}
  54. { This agreement can be found online at my site in the "Miscellaneous" section.}
  55. {------------------------------------------------------------------------------}
  56. { The lateset version of my components are always available on the web at:     }
  57. {   http://www.delphifreestuff.com/                                            }
  58. { See DFSClrBn.txt for notes, known issues, and revision history.              }
  59. {------------------------------------------------------------------------------}
  60. { Date last modified:  June 28, 2001                                           }
  61. {------------------------------------------------------------------------------}
  62.  
  63.  
  64. unit DFSClrBn;
  65.  
  66. interface
  67.  
  68. uses
  69.   WinTypes, WinProcs, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
  70.   Buttons, ExtCtrls, CBtnForm;
  71.  
  72.  
  73. {$IFDEF DFS_WIN32}
  74.   {$R DFSClrBn.res}
  75. {$ELSE}
  76.   {$R DFSClrBn.r16}
  77. {$ENDIF}
  78.  
  79.  
  80. {$IFDEF DFS_COMPILER_3_UP}
  81. resourcestring
  82. {$ELSE}
  83. const
  84. {$ENDIF}
  85.   SOtherBtnCaption = '&Other';
  86.  
  87. const
  88.   { This shuts up C++Builder 3 about the redefiniton being different. There
  89.     seems to be no equivalent in C1.  Sorry. }
  90.   {$IFDEF DFS_CPPB_3_UP}
  91.   {$EXTERNALSYM DFS_COMPONENT_VERSION}
  92.   {$ENDIF}
  93.   DFS_COMPONENT_VERSION = 'TdfsColorButton v2.61';
  94.  
  95. type
  96.   TdfsColorButton = class(TButton)
  97.   private
  98.     FShowColorHints: boolean;
  99.     FOnGetColorHintText: TdfsColorHintTextEvent;
  100.     FCurrentPaletteIndex: integer;
  101.     FPaletteForm: TdfsColorButtonPalette;
  102.     FSectionName: string;
  103.     FOtherBtnCaption: string;
  104.     FColorsLoaded: boolean;
  105.     FCanvas: TCanvas;
  106.     IsFocused: boolean;
  107.     FStyle: TButtonStyle;
  108.     FColor: TColor;
  109.     FPaletteDisplayed: boolean;
  110.     FCycleColors: boolean;
  111.     FPaletteColors: TPaletteColors;
  112.     FOtherColor: TColor;
  113.     FCustomColors: TCustomColors;
  114.     FIgnoreTopmosts: boolean;
  115. {$IFDEF DFS_WIN32}
  116.     FFlat: boolean;
  117.     FCustomColorsKey: string;
  118. {$ELSE}
  119.     FCustomColorsINI: string;
  120. {$ENDIF}
  121.     FOnColorChange: TNotifyEvent;
  122.     FArrowBmp: TBitmap;
  123.     FDisabledArrowBmp: TBitmap;
  124.     FIsMouseOver: boolean;
  125.     FInhibitClick: boolean;
  126.  
  127.     procedure CNMeasureItem(var Msg: TWMMeasureItem); message CN_MEASUREITEM;
  128.     procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;
  129.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  130.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  131.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  132. {$IFDEF DFS_WIN32}
  133.     procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
  134.     procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  135. {$ENDIF}
  136.  
  137.     procedure SetStyle(Value: TButtonStyle);
  138.     procedure SetColor(Value: TColor);
  139.     procedure SetPaletteColorIndex(Value: integer);
  140.     procedure SetPaletteColors(Value: TPaletteColors);
  141.     procedure SetCustomColors(Value: TCustomColors);
  142.     procedure SetArrowBmp(Value: TBitmap);
  143.     procedure SetDisabledArrowBmp(Value: TBitmap);
  144. {$IFDEF DFS_WIN32}
  145.     procedure SetFlat(Value: boolean);
  146. {$ENDIF}
  147.  
  148.     procedure DrawItem(const DrawItemStruct: TDrawItemStruct);
  149.     procedure PaletteSetColor(Sender: TObject; IsOther: boolean; AColor: TColor);
  150.     procedure PaletteClosed(Sender: TObject);
  151.   protected
  152.     procedure CreateParams(var Params: TCreateParams); override;
  153.     procedure CreateWnd; override;
  154.     procedure Loaded; override;
  155.     procedure SetButtonStyle(ADefault: Boolean); override;
  156.     procedure SetDefaultColors; virtual;
  157.  
  158.     function GetSectionName: string; virtual;
  159.     procedure SaveCustomColors; virtual;
  160.     procedure LoadCustomColors; virtual;
  161.     function GetVersion: string;
  162.     procedure SetVersion(const Val: string);
  163.   public
  164.     constructor Create(AOwner: TComponent); override;
  165.     destructor Destroy; override;
  166.     procedure Click; override;
  167.         procedure DoColorChange; virtual;
  168.  
  169.     property PaletteColorIndex: integer
  170.        read FCurrentPaletteIndex
  171.        write SetPaletteColorIndex;
  172.     property ArrowBmp: TBitmap
  173.        read FArrowBmp
  174.        write SetArrowBmp;
  175.     property DisabledArrowBmp: TBitmap
  176.        read FDisabledArrowBmp
  177.        write SetDisabledArrowBmp;
  178.     property IgnoreTopmosts: boolean
  179.        read FIgnoreTopmosts
  180.        write FIgnoreTopmosts;
  181.   published
  182.     property Version: string
  183.        read GetVersion
  184.        write SetVersion
  185.        stored FALSE;
  186.     property ShowColorHints: boolean
  187.        read FShowColorHints
  188.        write FShowColorHints
  189.        default TRUE;
  190.     property Style: TButtonStyle
  191.        read FStyle
  192.        write SetStyle
  193.        default bsAutoDetect;
  194.     property OtherBtnCaption: string
  195.        read FOtherBtnCaption
  196.        write FOtherBtnCaption;
  197.     property OtherColor: TColor
  198.        read FOtherColor
  199.        write FOtherColor;
  200.     property CycleColors: boolean
  201.        read FCycleColors
  202.        write FCycleColors
  203.        default FALSE;
  204.     property PaletteColors: TPaletteColors
  205.        read FPaletteColors
  206.        write SetPaletteColors
  207.        stored TRUE;
  208.     property CustomColors: TCustomColors
  209.        read FCustomColors
  210.        write SetCustomColors
  211.        stored TRUE;
  212.     { This property has to come after PaletteColors because it needs to use it }
  213.     property Color: TColor
  214.        read FColor
  215.        write SetColor
  216.        default clBlack;
  217. {$IFDEF DFS_WIN32}
  218.     property Flat: boolean
  219.        read FFlat
  220.        write SetFlat
  221.        default FALSE;
  222.     property CustomColorsKey: string
  223.        read FCustomColorsKey
  224.        write FCustomColorsKey;
  225. {$ELSE}
  226.     property CustomColorsINI: string
  227.        read FCustomColorsINI
  228.        write FCustomColorsINI;
  229. {$ENDIF}
  230.         property OnColorChange: TNotifyEvent
  231.        read FOnColorChange
  232.        write FOnColorChange;
  233.     property OnGetColorHintText: TdfsColorHintTextEvent
  234.        read FOnGetColorHintText
  235.        write FOnGetColorHintText;
  236.   end;
  237.  
  238. implementation
  239.  
  240. uses
  241.   {$IFDEF DFS_WIN32}
  242.   Registry,
  243.   {$ELSE}
  244.   IniFiles,
  245.   {$ENDIF}
  246.   SysUtils;
  247.  
  248.  
  249. {$IFNDEF DFS_COMPILER_3_UP}
  250. { Delphi 1 & 2 don't have this, just fake it }
  251. type
  252.   TCustomForm = TForm;
  253. {$ENDIF}
  254.  
  255. constructor TdfsColorButton.Create(AOwner: TComponent);
  256. begin
  257.   inherited Create(AOwner);
  258.   FIgnoreTopmosts := FALSE;
  259.   FInhibitClick := FALSE;
  260.   FShowColorHints := TRUE;
  261.   FCurrentPaletteIndex := 0;
  262.   FCycleColors := FALSE;
  263.   FArrowBmp := TBitmap.Create;
  264.   FDisabledArrowBmp := TBitmap.Create;
  265.   { I had a report that the Handle assignment was failing for someone who had
  266.     a large project, but that changing to LoadFromResource fixed it.
  267.     Unfortunately, this isn't available in Delphi 1. }
  268.   {$IFDEF DFS_WIN32}
  269.   FArrowBmp.LoadFromResourceName(HInstance, 'DFS_ARROW_BMP');
  270.   FDisabledArrowBmp.LoadFromResourceName(HInstance, 'DFS_ARROW_DISABLED_BMP');
  271.   {$ELSE}
  272.   FArrowBmp.Handle := LoadBitmap(HInstance, 'DFS_ARROW_BMP');
  273.   FDisabledArrowBmp.Handle := LoadBitmap(HInstance, 'DFS_ARROW_DISABLED_BMP');
  274.   {$ENDIF}
  275.   FPaletteColors := TColorArrayClass.Create(4,5);
  276.   FCustomColors := TColorArrayClass.Create(8,2);
  277.   FPaletteForm := NIL;
  278.   FOtherBtnCaption := SOtherBtnCaption;
  279.   FColorsLoaded := FALSE;
  280.   FCanvas := TCanvas.Create;
  281.   FStyle := bsAutoDetect;
  282.   FColor := clBlack;
  283.   FPaletteDisplayed := FALSE;
  284.   Caption := '';
  285.   FIsMouseOver := FALSE;
  286.   {$IFDEF DFS_DELPHI_3_UP}
  287.   ControlStyle := ControlStyle + [csReflector];
  288.   {$ENDIF}
  289.   {$IFDEF DFS_WIN32}
  290.   FFlat := FALSE;
  291.   FCustomColorsKey := '';
  292.   {$ELSE}
  293.   FCustomColorsINI := '';
  294.   {$ENDIF}
  295.   SetDefaultColors;
  296.   Width := 45;
  297.   Height := 22;
  298. end;
  299.  
  300. destructor TdfsColorButton.Destroy;
  301. begin
  302.   SaveCustomColors;
  303.   FCanvas.Free;
  304.   FPaletteColors.Free;
  305.   FCustomColors.Free;
  306.   FArrowBmp.Free;
  307.   FDisabledArrowBmp.Free;
  308.   inherited Destroy;
  309. end;
  310.  
  311. procedure TdfsColorButton.CreateWnd;
  312. begin
  313.   inherited CreateWnd;
  314.  
  315.   if not FColorsLoaded then
  316.     LoadCustomColors;
  317. end;
  318.  
  319.  
  320. procedure TdfsColorButton.Loaded;
  321. begin
  322.   inherited Loaded;
  323.  
  324.   LoadCustomColors;
  325. end;
  326.  
  327.  
  328. procedure TdfsColorButton.CreateParams(var Params: TCreateParams);
  329. begin
  330.   inherited CreateParams(Params);
  331.   Params.Style := Params.Style OR BS_OWNERDRAW;
  332. end;
  333.  
  334. procedure TdfsColorButton.SetStyle(Value: TButtonStyle);
  335. begin
  336.   if Value <> FStyle then
  337.   begin
  338.     FStyle := Value;
  339.     Invalidate;
  340.   end;
  341. end;
  342.  
  343. procedure TdfsColorButton.SetColor(Value: TColor);
  344. var
  345.   x: integer;
  346.   Found: boolean;
  347. begin
  348.   if Value <> FColor then
  349.   begin
  350.     FColor := Value;
  351.     Found := FALSE;
  352.     for x := 1 to FPaletteColors.Count do
  353.     begin
  354.       if FColor = FPaletteColors.Colors[x] then
  355.       begin
  356.         FCurrentPaletteIndex := x;
  357.         Found := TRUE;
  358.         break;
  359.       end;
  360.     end;
  361.     if not Found then
  362.       FCurrentPaletteIndex := 0;
  363.  
  364.     Invalidate;
  365.     DoColorChange;
  366.   end;
  367. end;
  368.  
  369. procedure TdfsColorButton.SetPaletteColorIndex(Value: integer);
  370. begin
  371.   if (Value <> FCurrentPaletteIndex) and (Value >= 0) and
  372.      (Value <= FPaletteColors.Count) then
  373.   begin
  374.     FCurrentPaletteIndex := Value;
  375.     if Value = 0 then
  376.       FColor := OtherColor
  377.     else
  378.       FColor := FPaletteColors.Colors[Value];
  379.     Invalidate;
  380.     DoColorChange;
  381.   end;
  382. end;
  383.  
  384. procedure TdfsColorButton.CNMeasureItem(var Msg: TWMMeasureItem);
  385. begin
  386.   with Msg.MeasureItemStruct^ do
  387.   begin
  388.     itemWidth := Width;
  389.     itemHeight := Height;
  390.   end;
  391.   Msg.Result := 1;
  392. end;
  393.  
  394. procedure TdfsColorButton.CNDrawItem(var Msg: TWMDrawItem);
  395. begin
  396.   DrawItem(Msg.DrawItemStruct^);
  397.   Msg.Result := 1;
  398. end;
  399.  
  400. { Borrowed from RxLib }
  401. procedure ShadeRect(DC: HDC; const Rect: TRect);
  402. const
  403.   HatchBits: array[0..7] of Word = ($11, $22, $44, $88, $11, $22, $44, $88);
  404. var
  405.   Bitmap: HBitmap;
  406.   SaveBrush: HBrush;
  407.   SaveTextColor, SaveBkColor: TColorRef;
  408. begin
  409.   Bitmap := CreateBitmap(8, 8, 1, 1, @HatchBits);
  410.   SaveBrush := SelectObject(DC, CreatePatternBrush(Bitmap));
  411.   try
  412.     SaveTextColor := SetTextColor(DC, clWhite);
  413.     SaveBkColor := SetBkColor(DC, clBlack);
  414.     with Rect do PatBlt(DC, Left, Top, Right - Left, Bottom - Top, $00A000C9);
  415.     SetBkColor(DC, SaveBkColor);
  416.     SetTextColor(DC, SaveTextColor);
  417.   finally
  418.     DeleteObject(SelectObject(DC, SaveBrush));
  419.     DeleteObject(Bitmap);
  420.   end;
  421. end;
  422.  
  423.  
  424. (* There's a bug in the Delphi 2.0x optimization compiler.  If you don't turn
  425.    off optimization under Delphi 2.0x, you will get an internal error C1217.
  426.    This bug is not present in Delphi 1 or 3.
  427.    There appears to be a similar bug in C++Builder 1.  I get an internal error
  428.    C1310.  Same fix for it as for Delphi.  Doesn't appear in C++Builder 3.    *)
  429.  
  430. {$IFDEF DFS_COMPILER_2}
  431.   {$IFOPT O+}
  432.     {$DEFINE DFS_OPTIMIZATION_ON}
  433.     {$O-}
  434.   {$ENDIF}
  435. {$ENDIF}
  436. procedure TdfsColorButton.DrawItem(const DrawItemStruct: TDrawItemStruct);
  437. var
  438.   IsDown, IsDefault: Boolean;
  439.   R: TRect;
  440.   Flags: Longint;
  441.   CursorPos: TPoint;
  442.   BtnRect: TRect;
  443.   Bmp: TBitmap;
  444. {$IFNDEF DFS_WIN32}
  445.   NewStyle: boolean;
  446.   Bevel: integer;
  447.   TextBounds: TRect;
  448. {$ENDIF}
  449. begin
  450.   FCanvas.Handle := DrawItemStruct.hDC;
  451.   try
  452.     R := ClientRect;
  453.  
  454.     with DrawItemStruct do
  455.     begin
  456.       IsDown := (itemState and ODS_SELECTED <> 0) or (FPaletteDisplayed);
  457.       IsDefault := itemState and ODS_FOCUS <> 0;
  458.     end;
  459.  
  460.     GetCursorPos(CursorPos);
  461.     BtnRect.TopLeft := Parent.ClientToScreen(Point(Left, Top));
  462.     BtnRect.BottomRight := Parent.ClientToScreen(Point(Left + Width,
  463.        Top + Height));
  464.     FIsMouseOver := PtInRect(BtnRect, CursorPos);
  465.  
  466. {$IFDEF DFS_WIN32}
  467.     Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
  468.     if IsDown then Flags := Flags or DFCS_PUSHED;
  469.     if DrawItemStruct.itemState and ODS_DISABLED <> 0 then
  470.       Flags := Flags or DFCS_INACTIVE;
  471.     { Don't draw flat if mouse is over it or has the input focus }
  472.     if FFlat and (not FIsMouseOver) and (not Focused) then
  473.       Flags := Flags or DFCS_FLAT;
  474.  
  475.     if IsDown then
  476.     begin
  477.       FCanvas.Pen.Color := clWindowFrame;
  478.       FCanvas.Pen.Width := 1;
  479.       FCanvas.Brush.Style := bsClear;
  480.       FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  481.  
  482.       { DrawFrameControl must draw within this border }
  483.       InflateRect(R, -1, -1);
  484.     end;
  485.  
  486.     { DrawFrameControl does not draw a pressed button correctly }
  487.     if IsDown then
  488.     begin
  489.       FCanvas.Pen.Color := clBtnShadow;
  490.       FCanvas.Pen.Width := 1;
  491.       FCanvas.Brush.Color := clBtnFace;
  492.       FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  493.       InflateRect(R, -1, -1);
  494.     end else begin
  495.       if (csDesigning in ComponentState) or
  496.          (FFlat and ((Flags and DFCS_FLAT) = 0)) then
  497.       begin
  498.         // Flat, but it has focus or mouse is over.
  499.         FCanvas.Pen.Color := clBtnHighlight;
  500.         FCanvas.MoveTo(R.Left, R.Bottom-1);
  501.         FCanvas.LineTo(R.Left, R.Top);
  502.         FCanvas.LineTo(R.Right-1, R.Top);
  503.         FCanvas.Pen.Color := clBtnShadow;
  504.         FCanvas.LineTo(R.Right-1, R.Bottom-1);
  505.         FCanvas.LineTo(R.Left, R.Bottom-1);
  506.         InflateRect(R, -1, -1);
  507.         FCanvas.Brush.Color := clBtnFace;
  508.         FCanvas.FillRect(R);
  509.       end else begin
  510.         DrawFrameControl(DrawItemStruct.hDC, R, DFC_BUTTON, Flags);
  511.         if (Flags and DFCS_FLAT) <> 0 then
  512.         begin
  513.           { I don't know why, but it insists on drawing this little rectangle }
  514.           InflateRect(R, 2, 2);
  515.           FCanvas.Brush.Color := clBtnFace;
  516.           FCanvas.FrameRect(R);
  517.           InflateRect(R, -2, -2);
  518.         end;
  519.       end;
  520.     end;
  521.  
  522.     R := ClientRect;
  523.     if IsDown then
  524.       OffsetRect(R, 1, 1);
  525.     InflateRect(R, -3, -3);
  526.     if IsFocused and IsDefault then
  527.     begin
  528.       FCanvas.Pen.Color := clWindowFrame;
  529.       FCanvas.Brush.Color := clBtnFace;
  530.       DrawFocusRect(FCanvas.Handle, R);
  531.     end;
  532.     InflateRect(R, -1, -1);
  533. {$ELSE}
  534.  
  535.     NewStyle := ((Style = bsAutoDetect) and NewStyleControls) or (Style = bsNew);
  536.  
  537.     if NewStyle then Bevel := 1
  538.     else Bevel := 2;
  539.  
  540.     R := DrawButtonFace(FCanvas, ClientRect, Bevel, FStyle, not NewStyle,
  541.       IsDown, IsDefault or IsFocused);
  542.  
  543.     if IsDefault then
  544.     begin
  545.       FCanvas.Brush.Color := clBtnFace;
  546.       TextBounds := R;
  547.       if NewStyle then
  548.       begin
  549.         InflateRect(TextBounds, -2, -2);
  550.         if IsDown then OffsetRect(TextBounds, -1, -1);
  551.       end
  552.       else InflateRect(TextBounds, -2, -2);
  553.       DrawFocusRect(FCanvas.Handle, TextBounds);
  554.     end;
  555.     InflateRect(R, -3, -3);
  556.  
  557. {$ENDIF}
  558.  
  559.     { Draw the color rect }
  560.     InflateRect(R, -2, -1);
  561.     Dec(R.Right, 10);
  562.     if (not Enabled) or ((DrawItemStruct.itemState and ODS_DISABLED) <> 0) then
  563.     begin
  564.       FCanvas.Brush.Color := clWindowFrame;
  565.       FCanvas.FrameRect(R);
  566.       InflateRect(R, -1, -1);
  567.       ShadeRect(FCanvas.Handle, R);
  568.     end else begin
  569.       FCanvas.Pen.Color := clWindowFrame;
  570.       FCanvas.Pen.Width := 1;
  571.       FCanvas.Brush.Style := bsClear;
  572.       FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  573.       FCanvas.Brush.Color := FColor;
  574.       FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
  575.     end;
  576.  
  577.     { Draw divider line }
  578.     R.Left := R.Right + 3;
  579.     FCanvas.Pen.Color := clBtnShadow;
  580.     FCanvas.MoveTo(R.Left, R.Top);
  581.     FCanvas.LineTo(R.Left, R.Bottom);
  582.     inc(R.Left);
  583.     FCanvas.Pen.Color := clBtnHighlight;
  584.     FCanvas.MoveTo(R.Left, R.Top);
  585.     FCanvas.LineTo(R.Left, R.Bottom);
  586.  
  587.     { Draw the arrow }
  588.     if Enabled or ((DrawItemStruct.itemState and ODS_DISABLED) = 0) then
  589.       Bmp := FArrowBmp
  590.     else
  591.       Bmp := FDisabledArrowBmp;
  592.     inc(R.Left, 1);
  593.     inc(R.Top, ((R.Bottom - R.Top) div 2) - (Bmp.Height div 2));
  594.     R.Right := R.Left + Bmp.Width-1;
  595.     R.Bottom := R.Top + Bmp.Height-1;
  596.     FCanvas.Brush.Color := clBtnFace;
  597.     FCanvas.BrushCopy(R, Bmp, Rect(0, 0, Bmp.Width-1, Bmp.Height-1),
  598.        Bmp.Canvas.Pixels[0, Bmp.Height-1]);
  599.   finally
  600.     FCanvas.Handle := 0;
  601.   end;
  602. end;
  603. {$IFDEF DFS_OPTIMIZATION_ON}
  604.   {$O+}
  605.   {$UNDEF DFS_OPTIMIZATION_ON}
  606. {$ENDIF}
  607.  
  608.  
  609. procedure TdfsColorButton.CMFontChanged(var Message: TMessage);
  610. begin
  611.   inherited;
  612.   Invalidate;
  613. end;
  614.  
  615. procedure TdfsColorButton.CMEnabledChanged(var Message: TMessage);
  616. begin
  617.   inherited;
  618.   Invalidate;
  619. end;
  620.  
  621. procedure TdfsColorButton.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  622. begin
  623.   Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
  624. end;
  625.  
  626. procedure TdfsColorButton.SetButtonStyle(ADefault: Boolean);
  627. begin
  628.   if ADefault <> IsFocused then
  629.   begin
  630.     IsFocused := ADefault;
  631.     Refresh;
  632.   end;
  633. end;
  634.  
  635. procedure TdfsColorButton.Click;
  636. var
  637.   PalXY: TPoint;
  638.   ArrowHit: boolean;
  639.   NewIdx: integer;
  640.   CursorPos: TPoint;
  641.   ParentForm: TCustomForm;
  642. {$IFDEF DFS_WIN32}
  643.   ScreenRect: TRect;
  644. {$ENDIF}
  645. begin
  646.   if FInhibitClick then
  647.   begin
  648.     FInhibitClick := FALSE;
  649.     exit;
  650.   end;
  651.  
  652.   if not FIgnoreTopmosts then
  653. {$IFDEF DFS_DELPHI_3_UP}
  654.     Application.NormalizeAllTopMosts;
  655. {$ELSE}
  656.     Application.NormalizeTopMosts;
  657. {$ENDIF}
  658.  
  659.   GetCursorPos(CursorPos);
  660.   CursorPos := ScreenToClient(CursorPos);
  661.   ArrowHit := CursorPos.X > (Width - 13);
  662.   if FCycleColors and (not ArrowHit) then
  663.   begin
  664.     NewIdx := FCurrentPaletteIndex + 1;
  665.     if NewIdx > PaletteColors.Count then
  666.       PaletteColorIndex := 0
  667.     else
  668.       PaletteColorIndex := NewIdx;
  669.   end else begin
  670.     FPaletteForm := TdfsColorButtonPalette.Create(Self);
  671.     PalXY := Parent.ClientToScreen(Point(Left, Top + Height));
  672.   {$IFDEF DFS_WIN32}
  673.     { Screen.Width and Height don't account for non-hidden task bar. }
  674.     SystemParametersInfo(SPI_GETWORKAREA, 0, @ScreenRect, 0);
  675.     if PalXY.Y + FPaletteForm.Height > ScreenRect.Bottom then
  676.       { No room to display below the button, show it above instead }
  677.       PalXY := Parent.ClientToScreen(Point(Left, Top - 121));
  678.     if PalXY.X < ScreenRect.Left then
  679.       { No room to display horizontally, shift right }
  680.       PalXY.X := ScreenRect.Left
  681.     else if PalXY.X + FPaletteForm.Width > ScreenRect.Right then
  682.       { No room to display horizontally, shift left }
  683.       PalXY.X := ScreenRect.Right - 78;
  684.     FPaletteForm.SetBounds(PalXY.X, PalXY.Y, FPaletteForm.Width,
  685.       FPaletteForm.Height);
  686.   {$ELSE}
  687.     if PalXY.Y + FPaletteForm.Height > Screen.Height then
  688.       { No room to display below the button, show it above instead }
  689.       PalXY := Parent.ClientToScreen(Point(Left, Top - 121));
  690.     if PalXY.X < 0 then
  691.       { No room to display horizontally, shift right }
  692.       PalXY.X := 0
  693.     else if PalXY.X + FPaletteForm.Width > Screen.Width then
  694.       { No room to display horizontally, shift left }
  695.       PalXY.X := Screen.Width - 78;
  696.     FPaletteForm.SetBounds(PalXY.X, PalXY.Y, FPaletteForm.Width,
  697.       FPaletteForm.Height);
  698.   {$ENDIF}
  699.     FPaletteForm.ShowColorHints := ShowColorHints;
  700.     FPaletteForm.btnOther.Caption := OtherBtnCaption;
  701.     FPaletteForm.OtherColor := OtherColor;
  702.     FPaletteForm.StartColor := Color;
  703.     FPaletteForm.SetParentColor := PaletteSetColor;
  704.     FPaletteForm.PaletteClosed := PaletteClosed;
  705.     FPaletteForm.PaletteColors := PaletteColors;
  706.     FPaletteForm.CustomColors := CustomColors;
  707.     FPaletteForm.OnGetColorHintText := FOnGetColorHintText;
  708.     FPaletteDisplayed := TRUE;
  709.     Refresh;
  710.     FPaletteForm.Show;
  711.     ParentForm := GetParentForm(Self);
  712.     if ParentForm <> NIL then
  713.       FlashWindow(ParentForm.Handle, TRUE);
  714.   end;
  715. end;
  716.  
  717. procedure TdfsColorButton.PaletteSetColor(Sender: TObject; IsOther: boolean;
  718.    AColor: TColor);
  719. begin
  720.   Color := AColor;
  721.   if IsOther then
  722.     OtherColor := AColor;
  723. end;
  724.  
  725. procedure TdfsColorButton.PaletteClosed(Sender: TObject);
  726. var
  727.   CP: TPoint;
  728.   ParentForm: TCustomForm;
  729. begin
  730.   ParentForm := GetParentForm(Self);
  731.   if ParentForm <> NIL then
  732.     FlashWindow(ParentForm.Handle, FALSE);
  733.   if FPaletteForm = NIL then exit;
  734.   if not FPaletteForm.KeyboardClose then
  735.   begin
  736.     GetCursorPos(CP);
  737.     CP := ScreenToClient(CP);
  738.     if (CP.X >= 0) and (CP.X < Width) and (CP.Y >= 0) and (CP.Y < Height) then
  739.       FInhibitClick := TRUE;
  740.   end;
  741.   CustomColors := FPaletteForm.CustomColors;
  742.   FPaletteDisplayed := FALSE;
  743.   Invalidate;
  744.   FPaletteForm := NIL;
  745.   if not FIgnoreTopmosts then
  746.     Application.RestoreTopMosts;
  747. end;
  748.  
  749. procedure TdfsColorButton.SetPaletteColors(Value: TPaletteColors);
  750. begin
  751.   FPaletteColors.Assign(Value);
  752. end;
  753.  
  754. procedure TdfsColorButton.SetCustomColors(Value: TCustomColors);
  755. begin
  756.   FCustomColors.Assign(Value);
  757. end;
  758.  
  759.  
  760. function ColorEnumProc(Pen : PLogPen; Colors : PColorArrayCallback): integer;
  761.    {$IFDEF DFS_WIN32} stdcall; {$ELSE} export; {$ENDIF}
  762. begin
  763.   if Pen^.lopnStyle = PS_SOLID then
  764.   begin
  765.     if Colors^[0] < 20 then
  766.     begin
  767.       inc(Colors^[0]);
  768.       Colors^[Colors^[0]] := Pen^.lopnColor;
  769.       Result := 1;
  770.     end else
  771.       Result := 0;
  772.   end else
  773.     Result := 1;
  774. end;
  775.  
  776.  
  777. procedure TdfsColorButton.SetDefaultColors;
  778. var
  779.   X, Y: integer;
  780.   DefColors: TColorArrayCallback;
  781.   DC: HDC;
  782.   {$IFNDEF DFS_WIN32}
  783.   CallbackProc: TFarProc;
  784.   {$ENDIF}
  785. begin
  786.   DC := GetDC(GetDesktopWindow);
  787.   try
  788.     if GetDeviceCaps(DC, NUMCOLORS) = 16 then
  789.     begin
  790.       { 16 color mode, enum colors to fill array }
  791.       FillChar(DefColors, SizeOf(DefColors), #0);
  792.       {$IFDEF DFS_WIN32}
  793.       EnumObjects(DC, OBJ_PEN, @ColorEnumProc, LPARAM(@DefColors));
  794.       {$ELSE}
  795.       CallbackProc := MakeProcInstance(@ColorEnumProc, hInstance);
  796.       try
  797.         EnumObjects(DC, OBJ_PEN, CallbackProc, @DefColors);
  798.       finally
  799.         FreeProcInstance(CallbackProc);
  800.       end;
  801.       {$ENDIF}
  802.  
  803.       for X := 1 to 4 do
  804.       begin
  805.         for Y := 1 to 5 do
  806.         begin
  807.           PaletteColors[X,Y] := DefColors[(X-1)*5+Y];
  808.         end;
  809.       end;
  810.     end else begin
  811.       { Lots 'o colors, pick the ones we want. }
  812.       PaletteColors[1,1] := RGB(255,255,255);
  813.       PaletteColors[1,2] := RGB(255,0,0);
  814.       PaletteColors[1,3] := RGB(0,255,0);
  815.       PaletteColors[1,4] := RGB(0,0,255);
  816.       PaletteColors[1,5] := RGB(191,215,191);
  817.       PaletteColors[2,1] := RGB(0,0,0);
  818.       PaletteColors[2,2] := RGB(127,0,0);
  819.       PaletteColors[2,3] := RGB(0,127,0);
  820.       PaletteColors[2,4] := RGB(0,0,127);
  821.       PaletteColors[2,5] := RGB(159,191,239);
  822.       PaletteColors[3,1] := RGB(191,191,191);
  823.       PaletteColors[3,2] := RGB(255,255,0);
  824.       PaletteColors[3,3] := RGB(0,255,255);
  825.       PaletteColors[3,4] := RGB(255,0,255);
  826.       PaletteColors[3,5] := RGB(255,247,239);
  827.       PaletteColors[4,1] := RGB(127,127,127);
  828.       PaletteColors[4,2] := RGB(127,127,0);
  829.       PaletteColors[4,3] := RGB(0,127,127);
  830.       PaletteColors[4,4] := RGB(127,0,127);
  831.       PaletteColors[4,5] := RGB(159,159,159);
  832.     end;
  833.   finally
  834.     ReleaseDC(GetDesktopWindow, DC);
  835.   end;
  836.  
  837.   for x := 1 to 8 do
  838.     for y := 1 to 2 do
  839.       CustomColors[x,y] := clWhite;
  840.  
  841.   FOtherColor := clBtnFace;
  842. end;
  843.  
  844.  
  845. function TdfsColorButton.GetSectionName: string;
  846. begin
  847.   Result := Self.Name;
  848.   if Parent <> NIL then
  849.     Result := Parent.Name + '.' + Result;
  850. end;
  851.  
  852.  
  853. procedure TdfsColorButton.SaveCustomColors;
  854. var
  855.   {$IFDEF DFS_WIN32}
  856.   Reg: TRegIniFile;
  857.   {$ELSE}
  858.   Ini: TIniFile;
  859.   {$ENDIF}
  860.   Colors: string;
  861.   x: integer;
  862.   y: integer;
  863. begin
  864.   Colors := '';
  865.   for x := 1 to 8 do
  866.   begin
  867.     for y := 1 to 2 do
  868.     begin
  869.       Colors := Colors + '$' + IntToHex(CustomColors[x,y], 8) + ',';
  870.     end;
  871.   end;
  872.   Delete(Colors, Length(Colors), 1); { strip last comma }
  873.  
  874.   {$IFDEF DFS_WIN32}
  875.   if FCustomColorsKey <> '' then
  876.   begin
  877.     Reg := TRegIniFile.Create(FCustomColorsKey);
  878.     try
  879.       Reg.WriteString('Colors', FSectionName, Colors);
  880.     finally
  881.       Reg.Free;
  882.     end;
  883.   end;
  884.   {$ELSE}
  885.   if FCustomColorsINI <> '' then
  886.   begin
  887.     Ini := TIniFile.Create(FCustomColorsINI);
  888.     try
  889.       Ini.WriteString('Colors', FSectionName, Colors);
  890.     finally
  891.       Ini.Free;
  892.     end;
  893.   end;
  894.   {$ENDIF}
  895. end;
  896.  
  897.  
  898. procedure TdfsColorButton.LoadCustomColors;
  899. var
  900.   {$IFDEF DFS_WIN32}
  901.   Reg: TRegIniFile;
  902.   {$ELSE}
  903.   Ini: TIniFile;
  904.   {$ENDIF}
  905.   Colors: string;
  906.   AColor: string;
  907.   CPos: byte;
  908.   x: integer;
  909.   y: integer;
  910. begin
  911.   Colors := '';
  912.   FSectionName := GetSectionName;
  913.   FColorsLoaded := TRUE;
  914.  
  915.   {$IFDEF DFS_WIN32}
  916.   if FCustomColorsKey <> '' then
  917.   begin
  918.     Reg := TRegIniFile.Create(FCustomColorsKey);
  919.     try
  920.       Colors := Reg.ReadString('Colors', FSectionName, '');
  921.     finally
  922.       Reg.Free;
  923.     end;
  924.   {$ELSE}
  925.   if FCustomColorsINI <> '' then
  926.   begin
  927.     Ini := TIniFile.Create(FCustomColorsINI);
  928.     try
  929.       Colors := Ini.ReadString('Colors', FSectionName, '');
  930.     finally
  931.       Ini.Free;
  932.     end;
  933.   {$ENDIF}
  934.         if Colors <> '' then
  935.         begin
  936.       x := 1;
  937.       y := 1;
  938.       CPos := Pos(',', Colors);
  939.       while CPos > 0 do
  940.       begin
  941.         AColor := Copy(Colors, 1, CPos-1);
  942.         CustomColors[x,y] := StrToIntDef(AColor, clWhite);
  943.         inc(y);
  944.         if y > 2 then
  945.         begin
  946.           y := 1;
  947.           inc(x);
  948.           if x > 8 then
  949.             break;  { all done }
  950.         end;
  951.         Colors := Copy(Colors, CPos+1, Length(Colors));
  952.       end;    { while }
  953.         end;
  954.   end;
  955. end;
  956.  
  957.  
  958. procedure TdfsColorButton.DoColorChange;
  959. begin
  960.   if assigned(FOnColorChange) then
  961.     FOnColorChange(Self);
  962. end;
  963.  
  964. procedure TdfsColorButton.SetArrowBmp(Value: TBitmap);
  965. begin
  966.   if Value <> NIL then
  967.   begin
  968.     FArrowBmp.Assign(Value);
  969.     Invalidate;
  970.   end;
  971. end;
  972.  
  973. procedure TdfsColorButton.SetDisabledArrowBmp(Value: TBitmap);
  974. begin
  975.   if Value <> NIL then
  976.   begin
  977.     FDisabledArrowBmp.Assign(Value);
  978.     Invalidate;
  979.   end;
  980. end;
  981.  
  982. {$IFDEF DFS_WIN32}
  983. procedure TdfsColorButton.SetFlat(Value: boolean);
  984. begin
  985.   if Value <> FFlat then
  986.   begin
  987.     FFlat := Value;
  988.     Invalidate;
  989.   end;
  990. end;
  991.  
  992. procedure TdfsColorButton.CMMouseEnter(var Message: TMessage);
  993. begin
  994.   if FFlat and (not FIsMouseOver) then
  995.     Invalidate;
  996. end;
  997.  
  998. procedure TdfsColorButton.CMMouseLeave(var Message: TMessage);
  999. begin
  1000.   if FFlat and (FIsMouseOver) then
  1001.     Invalidate;
  1002. end;
  1003. {$ENDIF}
  1004.  
  1005. function TdfsColorButton.GetVersion: string;
  1006. begin
  1007.   Result := DFS_COMPONENT_VERSION;
  1008. end;
  1009.  
  1010. procedure TdfsColorButton.SetVersion(const Val: string);
  1011. begin
  1012.   { empty write method, just needed to get it to show up in Object Inspector }
  1013. end;
  1014.  
  1015. end.
  1016.  
  1017.  
  1018.