{$I DFS.INC}  { Standard defines for all Delphi Free Stuff components }

{------------------------------------------------------------------------------}
{ TdfsColorButton v2.61                                                        }
{------------------------------------------------------------------------------}
{ A Windows 95 and NT 4 style color selection button.  It displays a palette   }
{ of 20 color for fast selction and a button to bring up the color dialog.     }
{                                                                              }
{ Copyright 2000-2001, Brad Stowers.  All Rights Reserved.                     }
{                                                                              }
{ Copyright:                                                                   }
{ All Delphi Free Stuff (hereafter "DFS") source code is copyrighted by        }
{ Bradley D. Stowers (hereafter "author"), and shall remain the exclusive      }
{ property of the author.                                                      }
{                                                                              }
{ Distribution Rights:                                                         }
{ You are granted a non-exlusive, royalty-free right to produce and distribute }
{ compiled binary files (executables, DLLs, etc.) that are built with any of   }
{ the DFS source code unless specifically stated otherwise.                    }
{ You are further granted permission to redistribute any of the DFS source     }
{ code in source code form, provided that the original archive as found on the }
{ DFS web site (http://www.delphifreestuff.com) is distributed unmodified. For }
{ example, if you create a descendant of TdfsColorButton, you must include in  }
{ the distribution package the colorbtn.zip file in the exact form that you    }
{ downloaded it from http://www.delphifreestuff.com/mine/files/colorbtn.zip.   }
{                                                                              }
{ Restrictions:                                                                }
{ Without the express written consent of the author, you may not:              }
{   * Distribute modified versions of any DFS source code by itself. You must  }
{     include the original archive as you found it at the DFS site.            }
{   * Sell or lease any portion of DFS source code. You are, of course, free   }
{     to sell any of your own original code that works with, enhances, etc.    }
{     DFS source code.                                                         }
{   * Distribute DFS source code for profit.                                   }
{                                                                              }
{ Warranty:                                                                    }
{ There is absolutely no warranty of any kind whatsoever with any of the DFS   }
{ source code (hereafter "software"). The software is provided to you "AS-IS", }
{ and all risks and losses associated with it's use are assumed by you. In no  }
{ event shall the author of the softare, Bradley D. Stowers, be held           }
{ accountable for any damages or losses that may occur from use or misuse of   }
{ the software.                                                                }
{                                                                              }
{ Support:                                                                     }
{ Support is provided via the DFS Support Forum, which is a web-based message  }
{ system.  You can find it at http://www.delphifreestuff.com/discus/           }
{ All DFS source code is provided free of charge. As such, I can not guarantee }
{ any support whatsoever. While I do try to answer all questions that I        }
{ receive, and address all problems that are reported to me, you must          }
{ understand that I simply can not guarantee that this will always be so.      }
{                                                                              }
{ Clarifications:                                                              }
{ If you need any further information, please feel free to contact me directly.}
{ This agreement can be found online at my site in the "Miscellaneous" section.}
{------------------------------------------------------------------------------}
{ The lateset version of my components are always available on the web at:     }
{   http://www.delphifreestuff.com/                                            }
{ See DFSClrBn.txt for notes, known issues, and revision history.              }
{------------------------------------------------------------------------------}
{ Date last modified:  June 28, 2001                                           }
{------------------------------------------------------------------------------}


unit DFSClrBn;

interface

uses
  WinTypes, WinProcs, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
  Buttons, ExtCtrls, CBtnForm;


{$IFDEF DFS_WIN32}
  {$R DFSClrBn.res}
{$ELSE}
  {$R DFSClrBn.r16}
{$ENDIF}


{$IFDEF DFS_COMPILER_3_UP}
resourcestring
{$ELSE}
const
{$ENDIF}
  SOtherBtnCaption = '&Other';

const
  { This shuts up C++Builder 3 about the redefiniton being different. There
    seems to be no equivalent in C1.  Sorry. }
  {$IFDEF DFS_CPPB_3_UP}
  {$EXTERNALSYM DFS_COMPONENT_VERSION}
  {$ENDIF}
  DFS_COMPONENT_VERSION = 'TdfsColorButton v2.61';

type
  TdfsColorButton = class(TButton)
  private
    FShowColorHints: boolean;
    FOnGetColorHintText: TdfsColorHintTextEvent;
    FCurrentPaletteIndex: integer;
    FPaletteForm: TdfsColorButtonPalette;
    FSectionName: string;
    FOtherBtnCaption: string;
    FColorsLoaded: boolean;
    FCanvas: TCanvas;
    IsFocused: boolean;
    FStyle: TButtonStyle;
    FColor: TColor;
    FPaletteDisplayed: boolean;
    FCycleColors: boolean;
    FPaletteColors: TPaletteColors;
    FOtherColor: TColor;
    FCustomColors: TCustomColors;
    FIgnoreTopmosts: boolean;
{$IFDEF DFS_WIN32}
    FFlat: boolean;
    FCustomColorsKey: string;
{$ELSE}
    FCustomColorsINI: string;
{$ENDIF}
    FOnColorChange: TNotifyEvent;
    FArrowBmp: TBitmap;
    FDisabledArrowBmp: TBitmap;
    FIsMouseOver: boolean;
    FInhibitClick: boolean;

    procedure CNMeasureItem(var Msg: TWMMeasureItem); message CN_MEASUREITEM;
    procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
{$IFDEF DFS_WIN32}
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
{$ENDIF}

    procedure SetStyle(Value: TButtonStyle);
    procedure SetColor(Value: TColor);
    procedure SetPaletteColorIndex(Value: integer);
    procedure SetPaletteColors(Value: TPaletteColors);
    procedure SetCustomColors(Value: TCustomColors);
    procedure SetArrowBmp(Value: TBitmap);
    procedure SetDisabledArrowBmp(Value: TBitmap);
{$IFDEF DFS_WIN32}
    procedure SetFlat(Value: boolean);
{$ENDIF}

    procedure DrawItem(const DrawItemStruct: TDrawItemStruct);
    procedure PaletteSetColor(Sender: TObject; IsOther: boolean; AColor: TColor);
    procedure PaletteClosed(Sender: TObject);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure Loaded; override;
    procedure SetButtonStyle(ADefault: Boolean); override;
    procedure SetDefaultColors; virtual;

    function GetSectionName: string; virtual;
    procedure SaveCustomColors; virtual;
    procedure LoadCustomColors; virtual;
    function GetVersion: string;
    procedure SetVersion(const Val: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
		procedure DoColorChange; virtual;

    property PaletteColorIndex: integer
       read FCurrentPaletteIndex
       write SetPaletteColorIndex;
    property ArrowBmp: TBitmap
       read FArrowBmp
       write SetArrowBmp;
    property DisabledArrowBmp: TBitmap
       read FDisabledArrowBmp
       write SetDisabledArrowBmp;
    property IgnoreTopmosts: boolean
       read FIgnoreTopmosts
       write FIgnoreTopmosts;
  published
    property Version: string
       read GetVersion
       write SetVersion
       stored FALSE;
    property ShowColorHints: boolean
       read FShowColorHints
       write FShowColorHints
       default TRUE;
    property Style: TButtonStyle
       read FStyle
       write SetStyle
       default bsAutoDetect;
    property OtherBtnCaption: string
       read FOtherBtnCaption
       write FOtherBtnCaption;
    property OtherColor: TColor
       read FOtherColor
       write FOtherColor;
    property CycleColors: boolean
       read FCycleColors
       write FCycleColors
       default FALSE;
    property PaletteColors: TPaletteColors
       read FPaletteColors
       write SetPaletteColors
       stored TRUE;
    property CustomColors: TCustomColors
       read FCustomColors
       write SetCustomColors
       stored TRUE;
    { This property has to come after PaletteColors because it needs to use it }
    property Color: TColor
       read FColor
       write SetColor
       default clBlack;
{$IFDEF DFS_WIN32}
    property Flat: boolean
       read FFlat
       write SetFlat
       default FALSE;
    property CustomColorsKey: string
       read FCustomColorsKey
       write FCustomColorsKey;
{$ELSE}
    property CustomColorsINI: string
       read FCustomColorsINI
       write FCustomColorsINI;
{$ENDIF}
		property OnColorChange: TNotifyEvent
       read FOnColorChange
       write FOnColorChange;
    property OnGetColorHintText: TdfsColorHintTextEvent
       read FOnGetColorHintText
       write FOnGetColorHintText;
  end;

implementation

uses
  {$IFDEF DFS_WIN32}
  Registry,
  {$ELSE}
  IniFiles,
  {$ENDIF}
  SysUtils;


{$IFNDEF DFS_COMPILER_3_UP}
{ Delphi 1 & 2 don't have this, just fake it }
type
  TCustomForm = TForm;
{$ENDIF}

constructor TdfsColorButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FIgnoreTopmosts := FALSE;
  FInhibitClick := FALSE;
  FShowColorHints := TRUE;
  FCurrentPaletteIndex := 0;
  FCycleColors := FALSE;
  FArrowBmp := TBitmap.Create;
  FDisabledArrowBmp := TBitmap.Create;
  { I had a report that the Handle assignment was failing for someone who had
    a large project, but that changing to LoadFromResource fixed it.
    Unfortunately, this isn't available in Delphi 1. }
  {$IFDEF DFS_WIN32}
  FArrowBmp.LoadFromResourceName(HInstance, 'DFS_ARROW_BMP');
  FDisabledArrowBmp.LoadFromResourceName(HInstance, 'DFS_ARROW_DISABLED_BMP');
  {$ELSE}
  FArrowBmp.Handle := LoadBitmap(HInstance, 'DFS_ARROW_BMP');
  FDisabledArrowBmp.Handle := LoadBitmap(HInstance, 'DFS_ARROW_DISABLED_BMP');
  {$ENDIF}
  FPaletteColors := TColorArrayClass.Create(4,5);
  FCustomColors := TColorArrayClass.Create(8,2);
  FPaletteForm := NIL;
  FOtherBtnCaption := SOtherBtnCaption;
  FColorsLoaded := FALSE;
  FCanvas := TCanvas.Create;
  FStyle := bsAutoDetect;
  FColor := clBlack;
  FPaletteDisplayed := FALSE;
  Caption := '';
  FIsMouseOver := FALSE;
  {$IFDEF DFS_DELPHI_3_UP}
  ControlStyle := ControlStyle + [csReflector];
  {$ENDIF}
  {$IFDEF DFS_WIN32}
  FFlat := FALSE;
  FCustomColorsKey := '';
  {$ELSE}
  FCustomColorsINI := '';
  {$ENDIF}
  SetDefaultColors;
  Width := 45;
  Height := 22;
end;

destructor TdfsColorButton.Destroy;
begin
  SaveCustomColors;
  FCanvas.Free;
  FPaletteColors.Free;
  FCustomColors.Free;
  FArrowBmp.Free;
  FDisabledArrowBmp.Free;
  inherited Destroy;
end;

procedure TdfsColorButton.CreateWnd;
begin
  inherited CreateWnd;

  if not FColorsLoaded then
    LoadCustomColors;
end;


procedure TdfsColorButton.Loaded;
begin
  inherited Loaded;

  LoadCustomColors;
end;


procedure TdfsColorButton.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style OR BS_OWNERDRAW;
end;

procedure TdfsColorButton.SetStyle(Value: TButtonStyle);
begin
  if Value <> FStyle then
  begin
    FStyle := Value;
    Invalidate;
  end;
end;

procedure TdfsColorButton.SetColor(Value: TColor);
var
  x: integer;
  Found: boolean;
begin
  if Value <> FColor then
  begin
    FColor := Value;
    Found := FALSE;
    for x := 1 to FPaletteColors.Count do
    begin
      if FColor = FPaletteColors.Colors[x] then
      begin
        FCurrentPaletteIndex := x;
        Found := TRUE;
        break;
      end;
    end;
    if not Found then
      FCurrentPaletteIndex := 0;

    Invalidate;
    DoColorChange;
  end;
end;

procedure TdfsColorButton.SetPaletteColorIndex(Value: integer);
begin
  if (Value <> FCurrentPaletteIndex) and (Value >= 0) and
     (Value <= FPaletteColors.Count) then
  begin
    FCurrentPaletteIndex := Value;
    if Value = 0 then
      FColor := OtherColor
    else
      FColor := FPaletteColors.Colors[Value];
    Invalidate;
    DoColorChange;
  end;
end;

procedure TdfsColorButton.CNMeasureItem(var Msg: TWMMeasureItem);
begin
  with Msg.MeasureItemStruct^ do
  begin
    itemWidth := Width;
    itemHeight := Height;
  end;
  Msg.Result := 1;
end;

procedure TdfsColorButton.CNDrawItem(var Msg: TWMDrawItem);
begin
  DrawItem(Msg.DrawItemStruct^);
  Msg.Result := 1;
end;

{ Borrowed from RxLib }
procedure ShadeRect(DC: HDC; const Rect: TRect);
const
  HatchBits: array[0..7] of Word = ($11, $22, $44, $88, $11, $22, $44, $88);
var
  Bitmap: HBitmap;
  SaveBrush: HBrush;
  SaveTextColor, SaveBkColor: TColorRef;
begin
  Bitmap := CreateBitmap(8, 8, 1, 1, @HatchBits);
  SaveBrush := SelectObject(DC, CreatePatternBrush(Bitmap));
  try
    SaveTextColor := SetTextColor(DC, clWhite);
    SaveBkColor := SetBkColor(DC, clBlack);
    with Rect do PatBlt(DC, Left, Top, Right - Left, Bottom - Top, $00A000C9);
    SetBkColor(DC, SaveBkColor);
    SetTextColor(DC, SaveTextColor);
  finally
    DeleteObject(SelectObject(DC, SaveBrush));
    DeleteObject(Bitmap);
  end;
end;


(* There's a bug in the Delphi 2.0x optimization compiler.  If you don't turn
   off optimization under Delphi 2.0x, you will get an internal error C1217.
   This bug is not present in Delphi 1 or 3.
   There appears to be a similar bug in C++Builder 1.  I get an internal error
   C1310.  Same fix for it as for Delphi.  Doesn't appear in C++Builder 3.    *)

{$IFDEF DFS_COMPILER_2}
  {$IFOPT O+}
    {$DEFINE DFS_OPTIMIZATION_ON}
    {$O-}
  {$ENDIF}
{$ENDIF}
procedure TdfsColorButton.DrawItem(const DrawItemStruct: TDrawItemStruct);
var
  IsDown, IsDefault: Boolean;
  R: TRect;
  Flags: Longint;
  CursorPos: TPoint;
  BtnRect: TRect;
  Bmp: TBitmap;
{$IFNDEF DFS_WIN32}
  NewStyle: boolean;
  Bevel: integer;
  TextBounds: TRect;
{$ENDIF}
begin
  FCanvas.Handle := DrawItemStruct.hDC;
  try
    R := ClientRect;

    with DrawItemStruct do
    begin
      IsDown := (itemState and ODS_SELECTED <> 0) or (FPaletteDisplayed);
      IsDefault := itemState and ODS_FOCUS <> 0;
    end;

    GetCursorPos(CursorPos);
    BtnRect.TopLeft := Parent.ClientToScreen(Point(Left, Top));
    BtnRect.BottomRight := Parent.ClientToScreen(Point(Left + Width,
       Top + Height));
    FIsMouseOver := PtInRect(BtnRect, CursorPos);

{$IFDEF DFS_WIN32}
    Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
    if IsDown then Flags := Flags or DFCS_PUSHED;
    if DrawItemStruct.itemState and ODS_DISABLED <> 0 then
      Flags := Flags or DFCS_INACTIVE;
    { Don't draw flat if mouse is over it or has the input focus }
    if FFlat and (not FIsMouseOver) and (not Focused) then
      Flags := Flags or DFCS_FLAT;

    if IsDown then
    begin
      FCanvas.Pen.Color := clWindowFrame;
      FCanvas.Pen.Width := 1;
      FCanvas.Brush.Style := bsClear;
      FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);

      { DrawFrameControl must draw within this border }
      InflateRect(R, -1, -1);
    end;

    { DrawFrameControl does not draw a pressed button correctly }
    if IsDown then
    begin
      FCanvas.Pen.Color := clBtnShadow;
      FCanvas.Pen.Width := 1;
      FCanvas.Brush.Color := clBtnFace;
      FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
      InflateRect(R, -1, -1);
    end else begin
      if (csDesigning in ComponentState) or
         (FFlat and ((Flags and DFCS_FLAT) = 0)) then
      begin
        // Flat, but it has focus or mouse is over.
        FCanvas.Pen.Color := clBtnHighlight;
        FCanvas.MoveTo(R.Left, R.Bottom-1);
        FCanvas.LineTo(R.Left, R.Top);
        FCanvas.LineTo(R.Right-1, R.Top);
        FCanvas.Pen.Color := clBtnShadow;
        FCanvas.LineTo(R.Right-1, R.Bottom-1);
        FCanvas.LineTo(R.Left, R.Bottom-1);
        InflateRect(R, -1, -1);
        FCanvas.Brush.Color := clBtnFace;
        FCanvas.FillRect(R);
      end else begin
        DrawFrameControl(DrawItemStruct.hDC, R, DFC_BUTTON, Flags);
        if (Flags and DFCS_FLAT) <> 0 then
        begin
          { I don't know why, but it insists on drawing this little rectangle }
          InflateRect(R, 2, 2);
          FCanvas.Brush.Color := clBtnFace;
          FCanvas.FrameRect(R);
          InflateRect(R, -2, -2);
        end;
      end;
    end;

    R := ClientRect;
    if IsDown then
      OffsetRect(R, 1, 1);
    InflateRect(R, -3, -3);
    if IsFocused and IsDefault then
    begin
      FCanvas.Pen.Color := clWindowFrame;
      FCanvas.Brush.Color := clBtnFace;
      DrawFocusRect(FCanvas.Handle, R);
    end;
    InflateRect(R, -1, -1);
{$ELSE}

    NewStyle := ((Style = bsAutoDetect) and NewStyleControls) or (Style = bsNew);

    if NewStyle then Bevel := 1
    else Bevel := 2;

    R := DrawButtonFace(FCanvas, ClientRect, Bevel, FStyle, not NewStyle,
      IsDown, IsDefault or IsFocused);

    if IsDefault then
    begin
      FCanvas.Brush.Color := clBtnFace;
      TextBounds := R;
      if NewStyle then
      begin
        InflateRect(TextBounds, -2, -2);
        if IsDown then OffsetRect(TextBounds, -1, -1);
      end
      else InflateRect(TextBounds, -2, -2);
      DrawFocusRect(FCanvas.Handle, TextBounds);
    end;
    InflateRect(R, -3, -3);

{$ENDIF}

    { Draw the color rect }
    InflateRect(R, -2, -1);
    Dec(R.Right, 10);
    if (not Enabled) or ((DrawItemStruct.itemState and ODS_DISABLED) <> 0) then
    begin
      FCanvas.Brush.Color := clWindowFrame;
      FCanvas.FrameRect(R);
      InflateRect(R, -1, -1);
      ShadeRect(FCanvas.Handle, R);
    end else begin
      FCanvas.Pen.Color := clWindowFrame;
      FCanvas.Pen.Width := 1;
      FCanvas.Brush.Style := bsClear;
      FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
      FCanvas.Brush.Color := FColor;
      FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
    end;

    { Draw divider line }
    R.Left := R.Right + 3;
    FCanvas.Pen.Color := clBtnShadow;
    FCanvas.MoveTo(R.Left, R.Top);
    FCanvas.LineTo(R.Left, R.Bottom);
    inc(R.Left);
    FCanvas.Pen.Color := clBtnHighlight;
    FCanvas.MoveTo(R.Left, R.Top);
    FCanvas.LineTo(R.Left, R.Bottom);

    { Draw the arrow }
    if Enabled or ((DrawItemStruct.itemState and ODS_DISABLED) = 0) then
      Bmp := FArrowBmp
    else
      Bmp := FDisabledArrowBmp;
    inc(R.Left, 1);
    inc(R.Top, ((R.Bottom - R.Top) div 2) - (Bmp.Height div 2));
    R.Right := R.Left + Bmp.Width-1;
    R.Bottom := R.Top + Bmp.Height-1;
    FCanvas.Brush.Color := clBtnFace;
    FCanvas.BrushCopy(R, Bmp, Rect(0, 0, Bmp.Width-1, Bmp.Height-1),
       Bmp.Canvas.Pixels[0, Bmp.Height-1]);
  finally
    FCanvas.Handle := 0;
  end;
end;
{$IFDEF DFS_OPTIMIZATION_ON}
  {$O+}
  {$UNDEF DFS_OPTIMIZATION_ON}
{$ENDIF}


procedure TdfsColorButton.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TdfsColorButton.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TdfsColorButton.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
end;

procedure TdfsColorButton.SetButtonStyle(ADefault: Boolean);
begin
  if ADefault <> IsFocused then
  begin
    IsFocused := ADefault;
    Refresh;
  end;
end;

procedure TdfsColorButton.Click;
var
  PalXY: TPoint;
  ArrowHit: boolean;
  NewIdx: integer;
  CursorPos: TPoint;
  ParentForm: TCustomForm;
{$IFDEF DFS_WIN32}
  ScreenRect: TRect;
{$ENDIF}
begin
  if FInhibitClick then
  begin
    FInhibitClick := FALSE;
    exit;
  end;

  if not FIgnoreTopmosts then
{$IFDEF DFS_DELPHI_3_UP}
    Application.NormalizeAllTopMosts;
{$ELSE}
    Application.NormalizeTopMosts;
{$ENDIF}

  GetCursorPos(CursorPos);
  CursorPos := ScreenToClient(CursorPos);
  ArrowHit := CursorPos.X > (Width - 13);
  if FCycleColors and (not ArrowHit) then
  begin
    NewIdx := FCurrentPaletteIndex + 1;
    if NewIdx > PaletteColors.Count then
      PaletteColorIndex := 0
    else
      PaletteColorIndex := NewIdx;
  end else begin
    FPaletteForm := TdfsColorButtonPalette.Create(Self);
    PalXY := Parent.ClientToScreen(Point(Left, Top + Height));
  {$IFDEF DFS_WIN32}
    { Screen.Width and Height don't account for non-hidden task bar. }
    SystemParametersInfo(SPI_GETWORKAREA, 0, @ScreenRect, 0);
    if PalXY.Y + FPaletteForm.Height > ScreenRect.Bottom then
      { No room to display below the button, show it above instead }
      PalXY := Parent.ClientToScreen(Point(Left, Top - 121));
    if PalXY.X < ScreenRect.Left then
      { No room to display horizontally, shift right }
      PalXY.X := ScreenRect.Left
    else if PalXY.X + FPaletteForm.Width > ScreenRect.Right then
      { No room to display horizontally, shift left }
      PalXY.X := ScreenRect.Right - 78;
    FPaletteForm.SetBounds(PalXY.X, PalXY.Y, FPaletteForm.Width,
      FPaletteForm.Height);
  {$ELSE}
    if PalXY.Y + FPaletteForm.Height > Screen.Height then
      { No room to display below the button, show it above instead }
      PalXY := Parent.ClientToScreen(Point(Left, Top - 121));
    if PalXY.X < 0 then
      { No room to display horizontally, shift right }
      PalXY.X := 0
    else if PalXY.X + FPaletteForm.Width > Screen.Width then
      { No room to display horizontally, shift left }
      PalXY.X := Screen.Width - 78;
    FPaletteForm.SetBounds(PalXY.X, PalXY.Y, FPaletteForm.Width,
      FPaletteForm.Height);
  {$ENDIF}
    FPaletteForm.ShowColorHints := ShowColorHints;
    FPaletteForm.btnOther.Caption := OtherBtnCaption;
    FPaletteForm.OtherColor := OtherColor;
    FPaletteForm.StartColor := Color;
    FPaletteForm.SetParentColor := PaletteSetColor;
    FPaletteForm.PaletteClosed := PaletteClosed;
    FPaletteForm.PaletteColors := PaletteColors;
    FPaletteForm.CustomColors := CustomColors;
    FPaletteForm.OnGetColorHintText := FOnGetColorHintText;
    FPaletteDisplayed := TRUE;
    Refresh;
    FPaletteForm.Show;
    ParentForm := GetParentForm(Self);
    if ParentForm <> NIL then
      FlashWindow(ParentForm.Handle, TRUE);
  end;
end;

procedure TdfsColorButton.PaletteSetColor(Sender: TObject; IsOther: boolean;
   AColor: TColor);
begin
  Color := AColor;
  if IsOther then
    OtherColor := AColor;
end;

procedure TdfsColorButton.PaletteClosed(Sender: TObject);
var
  CP: TPoint;
  ParentForm: TCustomForm;
begin
  ParentForm := GetParentForm(Self);
  if ParentForm <> NIL then
    FlashWindow(ParentForm.Handle, FALSE);
  if FPaletteForm = NIL then exit;
  if not FPaletteForm.KeyboardClose then
  begin
    GetCursorPos(CP);
    CP := ScreenToClient(CP);
    if (CP.X >= 0) and (CP.X < Width) and (CP.Y >= 0) and (CP.Y < Height) then
      FInhibitClick := TRUE;
  end;
  CustomColors := FPaletteForm.CustomColors;
  FPaletteDisplayed := FALSE;
  Invalidate;
  FPaletteForm := NIL;
  if not FIgnoreTopmosts then
    Application.RestoreTopMosts;
end;

procedure TdfsColorButton.SetPaletteColors(Value: TPaletteColors);
begin
  FPaletteColors.Assign(Value);
end;

procedure TdfsColorButton.SetCustomColors(Value: TCustomColors);
begin
  FCustomColors.Assign(Value);
end;


function ColorEnumProc(Pen : PLogPen; Colors : PColorArrayCallback): integer;
   {$IFDEF DFS_WIN32} stdcall; {$ELSE} export; {$ENDIF}
begin
  if Pen^.lopnStyle = PS_SOLID then
  begin
    if Colors^[0] < 20 then
    begin
      inc(Colors^[0]);
      Colors^[Colors^[0]] := Pen^.lopnColor;
      Result := 1;
    end else
      Result := 0;
  end else
    Result := 1;
end;


procedure TdfsColorButton.SetDefaultColors;
var
  X, Y: integer;
  DefColors: TColorArrayCallback;
  DC: HDC;
  {$IFNDEF DFS_WIN32}
  CallbackProc: TFarProc;
  {$ENDIF}
begin
  DC := GetDC(GetDesktopWindow);
  try
    if GetDeviceCaps(DC, NUMCOLORS) = 16 then
    begin
      { 16 color mode, enum colors to fill array }
      FillChar(DefColors, SizeOf(DefColors), #0);
      {$IFDEF DFS_WIN32}
      EnumObjects(DC, OBJ_PEN, @ColorEnumProc, LPARAM(@DefColors));
      {$ELSE}
      CallbackProc := MakeProcInstance(@ColorEnumProc, hInstance);
      try
        EnumObjects(DC, OBJ_PEN, CallbackProc, @DefColors);
      finally
        FreeProcInstance(CallbackProc);
      end;
      {$ENDIF}

      for X := 1 to 4 do
      begin
        for Y := 1 to 5 do
        begin
          PaletteColors[X,Y] := DefColors[(X-1)*5+Y];
        end;
      end;
    end else begin
      { Lots 'o colors, pick the ones we want. }
      PaletteColors[1,1] := RGB(255,255,255);
      PaletteColors[1,2] := RGB(255,0,0);
      PaletteColors[1,3] := RGB(0,255,0);
      PaletteColors[1,4] := RGB(0,0,255);
      PaletteColors[1,5] := RGB(191,215,191);
      PaletteColors[2,1] := RGB(0,0,0);
      PaletteColors[2,2] := RGB(127,0,0);
      PaletteColors[2,3] := RGB(0,127,0);
      PaletteColors[2,4] := RGB(0,0,127);
      PaletteColors[2,5] := RGB(159,191,239);
      PaletteColors[3,1] := RGB(191,191,191);
      PaletteColors[3,2] := RGB(255,255,0);
      PaletteColors[3,3] := RGB(0,255,255);
      PaletteColors[3,4] := RGB(255,0,255);
      PaletteColors[3,5] := RGB(255,247,239);
      PaletteColors[4,1] := RGB(127,127,127);
      PaletteColors[4,2] := RGB(127,127,0);
      PaletteColors[4,3] := RGB(0,127,127);
      PaletteColors[4,4] := RGB(127,0,127);
      PaletteColors[4,5] := RGB(159,159,159);
    end;
  finally
    ReleaseDC(GetDesktopWindow, DC);
  end;

  for x := 1 to 8 do
    for y := 1 to 2 do
      CustomColors[x,y] := clWhite;

  FOtherColor := clBtnFace;
end;


function TdfsColorButton.GetSectionName: string;
begin
  Result := Self.Name;
  if Parent <> NIL then
    Result := Parent.Name + '.' + Result;
end;


procedure TdfsColorButton.SaveCustomColors;
var
  {$IFDEF DFS_WIN32}
  Reg: TRegIniFile;
  {$ELSE}
  Ini: TIniFile;
  {$ENDIF}
  Colors: string;
  x: integer;
  y: integer;
begin
  Colors := '';
  for x := 1 to 8 do
  begin
    for y := 1 to 2 do
    begin
      Colors := Colors + '$' + IntToHex(CustomColors[x,y], 8) + ',';
    end;
  end;
  Delete(Colors, Length(Colors), 1); { strip last comma }

  {$IFDEF DFS_WIN32}
  if FCustomColorsKey <> '' then
  begin
    Reg := TRegIniFile.Create(FCustomColorsKey);
    try
      Reg.WriteString('Colors', FSectionName, Colors);
    finally
      Reg.Free;
    end;
  end;
  {$ELSE}
  if FCustomColorsINI <> '' then
  begin
    Ini := TIniFile.Create(FCustomColorsINI);
    try
      Ini.WriteString('Colors', FSectionName, Colors);
    finally
      Ini.Free;
    end;
  end;
  {$ENDIF}
end;


procedure TdfsColorButton.LoadCustomColors;
var
  {$IFDEF DFS_WIN32}
  Reg: TRegIniFile;
  {$ELSE}
  Ini: TIniFile;
  {$ENDIF}
  Colors: string;
  AColor: string;
  CPos: byte;
  x: integer;
  y: integer;
begin
  Colors := '';
  FSectionName := GetSectionName;
  FColorsLoaded := TRUE;

  {$IFDEF DFS_WIN32}
  if FCustomColorsKey <> '' then
  begin
    Reg := TRegIniFile.Create(FCustomColorsKey);
    try
      Colors := Reg.ReadString('Colors', FSectionName, '');
    finally
      Reg.Free;
    end;
  {$ELSE}
  if FCustomColorsINI <> '' then
  begin
    Ini := TIniFile.Create(FCustomColorsINI);
    try
      Colors := Ini.ReadString('Colors', FSectionName, '');
    finally
      Ini.Free;
    end;
  {$ENDIF}
		if Colors <> '' then
		begin
      x := 1;
      y := 1;
      CPos := Pos(',', Colors);
      while CPos > 0 do
      begin
        AColor := Copy(Colors, 1, CPos-1);
        CustomColors[x,y] := StrToIntDef(AColor, clWhite);
        inc(y);
        if y > 2 then
        begin
          y := 1;
          inc(x);
          if x > 8 then
            break;  { all done }
        end;
        Colors := Copy(Colors, CPos+1, Length(Colors));
      end;    { while }
		end;
  end;
end;


procedure TdfsColorButton.DoColorChange;
begin
  if assigned(FOnColorChange) then
    FOnColorChange(Self);
end;

procedure TdfsColorButton.SetArrowBmp(Value: TBitmap);
begin
  if Value <> NIL then
  begin
    FArrowBmp.Assign(Value);
    Invalidate;
  end;
end;

procedure TdfsColorButton.SetDisabledArrowBmp(Value: TBitmap);
begin
  if Value <> NIL then
  begin
    FDisabledArrowBmp.Assign(Value);
    Invalidate;
  end;
end;

{$IFDEF DFS_WIN32}
procedure TdfsColorButton.SetFlat(Value: boolean);
begin
  if Value <> FFlat then
  begin
    FFlat := Value;
    Invalidate;
  end;
end;

procedure TdfsColorButton.CMMouseEnter(var Message: TMessage);
begin
  if FFlat and (not FIsMouseOver) then
    Invalidate;
end;

procedure TdfsColorButton.CMMouseLeave(var Message: TMessage);
begin
  if FFlat and (FIsMouseOver) then
    Invalidate;
end;
{$ENDIF}

function TdfsColorButton.GetVersion: string;
begin
  Result := DFS_COMPONENT_VERSION;
end;

procedure TdfsColorButton.SetVersion(const Val: string);
begin
  { empty write method, just needed to get it to show up in Object Inspector }
end;

end.


