cbtnform.pas

动态提示控件

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

{------------------------------------------------------------------------------}
{ 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 1999, 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:                                                                     }
{ 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.}
{------------------------------------------------------------------------------}
{ Feel free to contact me if you have any questions, comments or suggestions   }
{ at [e-mail].                                                       }
{ The lateset version of my components are always available on the web at:     }
{   http://www.delphifreestuff.com/                                            }
{------------------------------------------------------------------------------}
{ Date last modified:  February 23, 1999                                       }
{------------------------------------------------------------------------------}


{-----------------------------------------------------------------------------}
{ TDFSColorButtonPalette                                                      }
{-----------------------------------------------------------------------------}
{ Description:                                                                }
{   This is a support unit for the TDFSColorButton component (DFSClrBn.pas).  }
{-----------------------------------------------------------------------------}
unit CBtnForm;

interface

uses
  WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

const
  MAX_COLORS = (MaxInt div SizeOf(TColor));

type
  PColorArrayCallback = ^TColorArrayCallBack;
  TColorArrayCallback = Array[0..20] of TColorRef;

  TSetParentColorEvent = procedure(Sender: TObject; IsOther: boolean;
     AColor: TColor) of object;

  TDFSColorHintTextEvent = procedure(Sender: TObject; AColor: TColor;
     X, Y: integer; var HintStr: string) of object;

  EColorArrayIndexError = class(Exception);

  PColorArray = ^TColorArray;
  TColorArray = array[1..MAX_COLORS] of TColor;

  TColorArrayClass = class(TPersistent)
  private
    FXSize,
    FYSize: integer;
    FCount: integer;
    FColors: PColorArray;

    function GetColor(X, Y: integer): TColor;
    procedure SetColor(X, Y: integer; Value: TColor);
    procedure SetXSize(Value: integer);
    procedure SetYSize(Value: integer);
    function GetSingleColor(Index: integer): TColor;
    procedure SetSingleColor(Index: integer; Value: TColor);
  protected
    procedure CheckXYVals(X, Y: integer);
    procedure ReadXSize(Reader: TReader);
    procedure WriteXSize(Writer: TWriter);
    procedure ReadYSize(Reader: TReader);
    procedure WriteYSize(Writer: TWriter);
    procedure ReadColors(Reader: TReader);
    procedure WriteColors(Writer: TWriter);
  public
    constructor Create(X, Y: integer); virtual;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure DefineProperties(Filer: TFiler); override;
    function IsEqualTo(OtherColors: TColorArrayClass): boolean; virtual;

    property Color[X: integer; Y: integer]: TColor
       read GetColor
       write SetColor;
       default;
    property Colors[Index: integer]: TColor
      read GetSingleColor
      write SetSingleColor;
{  published}
    property XSize: integer
       read FXSize
       write SetXSize;
    property YSize: integer
       read FYSize
       write SetYSize;
    property Count: integer
       read FCount;
  end;

  TPaletteColors = TColorArrayClass;
  TCustomColors = TColorArrayClass;

  TDFSColorButtonPalette = class(TForm)
    btnOther: TButton;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormDeactivate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnOtherClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormClick(Sender: TObject);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure FormDestroy(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
  private
    FShowColorHints: boolean;
    FKeyboardClose: boolean;
    FPreventClose: boolean;
    FOldAppDeactivate: TNotifyEvent;
    FPaletteColors: TPaletteColors;
    FCustomColors: TCustomColors;
    FStartColor,
    FOtherColor: TColor;
    FLastFrame: TPoint;
    FSetParentColor: TSetParentColorEvent;
    FPaletteClosed: TNotifyEvent;
    FOldAppShowHint: TShowHintEvent;
    FOnGetColorHintText: TDFSColorHintTextEvent;

    function ValidColorIndex(X, Y: integer): boolean;
    procedure AppDeactivate(Sender: TObject);
    function GetSquareCoords(X, Y: integer): TRect;
    procedure DrawSquare(X, Y: integer; AColor: TColor; IsFocused: boolean);
    procedure FrameCurrentSquare(NewFrame: TPoint);
    function GetCurrentSquare: TPoint;
    procedure SetStartColor(Value: TColor);
    procedure SetPaletteColors(Value: TPaletteColors);
    procedure SetCustomColors(Value: TCustomColors);
    procedure PaletteShowHint(var HintStr: string; var CanShow: Boolean;
       var HintInfo: THintInfo);
    procedure SetShowColorHints(Val: boolean);
  protected
    function BuildHintText(AColor: TColor; X, Y: integer): string; virtual;
    procedure GetColorHintText(AColor: TColor; X, Y: integer;
       var HintStr: string); virtual;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    property ShowColorHints: boolean
       read FShowColorHints
       write SetShowColorHints;
    property KeyboardClose: boolean
       read FKeyboardClose
       write FKeyboardClose;
    property SetParentColor: TSetParentColorEvent
       read FSetParentColor
       write FSetParentColor;
    property PaletteClosed: TNotifyEvent
       read FPaletteClosed
       write FPaletteClosed;
    property StartColor: TColor
       read FStartColor
       write SetStartColor;
    property OtherColor: TColor
       read FOtherColor
       write FOtherColor;
    property PaletteColors: TPaletteColors
       read FPaletteColors
       write SetPaletteColors;
    property CustomColors: TCustomColors
       read FCustomColors
       write SetCustomColors;
    property OnGetColorHintText: TDFSColorHintTextEvent
       read FOnGetColorHintText
       write FOnGetColorHintText;
  end;


implementation

{$R *.DFM}

uses
  ExtCtrls;


constructor TColorArrayClass.Create(X, Y: integer);
begin
  inherited Create;

  FXSize := X;
  FYSize := Y;
  FCount := X * Y;
  GetMem(FColors, X * Y * SizeOf(TColor));
end;

destructor TColorArrayClass.Destroy;
begin
  FreeMem(FColors, FXSize * FYSize * SizeOf(TColor));
  FCount := 0;

  inherited Destroy;
end;

function TColorArrayClass.GetColor(X, Y: integer): TColor;
begin
  CheckXYVals(X, Y);
  Result := FColors^[(Y-1)*FXSize+X];
end;

procedure TColorArrayClass.SetColor(X, Y: integer; Value: TColor);
begin
  CheckXYVals(X, Y);
  FColors^[(Y-1)*FXSize+X] := Value;
end;

procedure TColorArrayClass.SetXSize(Value: integer);
begin
  if Value <> XSize then
  begin
    FreeMem(FColors, XSize * YSize * SizeOf(TColor));
    FXSize := Value;
    GetMem(FColors, XSize * YSize * SizeOf(TColor));
    FCount := XSize * YSize;
    { really need to recopy colors, but I'm lazy and don't need it right now }
  end;
end;

procedure TColorArrayClass.SetYSize(Value: integer);
begin
  if Value <> YSize then
  begin
    FreeMem(FColors, XSize * YSize * SizeOf(TColor));
    FYSize := Value;
    GetMem(FColors, XSize * YSize * SizeOf(TColor));
    FCount := XSize * YSize;
    { really need to recopy colors, but I'm lazy and don't need it right now }
  end;
end;

function TColorArrayClass.GetSingleColor(Index: integer): TColor;
begin
  if (Index < 1) or (Index > (XSize * YSize)) then
    raise EColorArrayIndexError.Create('Array index out of bounds');
  Result := FColors^[Index];
end;

procedure TColorArrayClass.SetSingleColor(Index: integer; Value: TColor);
begin
  if (Index < 1) or (Index > (XSize * YSize)) then
    raise EColorArrayIndexError.Create('Array index out of bounds');
  if FColors^[Index] <> Value then
    FColors^[Index] := Value;
end;

procedure TColorArrayClass.CheckXYVals(X, Y: integer);
begin
  if (X < 1) or (Y < 1) or (X > XSize) or (Y > YSize) then
    raise EColorArrayIndexError.Create('Array index out of bounds');
end;


procedure TColorArrayClass.ReadXSize(Reader: TReader);
begin
  XSize := Reader.ReadInteger;
end;

procedure TColorArrayClass.WriteXSize(Writer: TWriter);
begin
  Writer.WriteInteger(XSize);
end;

procedure TColorArrayClass.ReadYSize(Reader: TReader);
begin
  YSize := Reader.ReadInteger;
end;

procedure TColorArrayClass.WriteYSize(Writer: TWriter);
begin
  Writer.WriteInteger(YSize);
end;

procedure TColorArrayClass.ReadColors(Reader: TReader);
var
  X, Y: integer;
begin
  X := 1;
  Y := 1;
  Reader.ReadListBegin;
  while not Reader.EndOfList do
  begin
    Color[X, Y] := Reader.ReadInteger;
    if Y < YSize then
      inc(Y)
    else begin
      Y := 1;
      inc(X);
    end;
  end;
  Reader.ReadListEnd;
end;

procedure TColorArrayClass.WriteColors(Writer: TWriter);
var
  X, Y: integer;
begin
  Writer.WriteListBegin;
  for X := 1 to XSize do
    for Y := 1 to YSize do
      Writer.WriteInteger(Color[X, Y]);
  Writer.WriteListEnd;
end;

procedure TColorArrayClass.DefineProperties(Filer: TFiler);
begin
  Filer.DefineProperty('XSize', ReadXSize, WriteXSize, TRUE);
  Filer.DefineProperty('YSize', ReadYSize, WriteYSize, TRUE);
  Filer.DefineProperty('Colors', ReadColors, WriteColors, TRUE);
end;

procedure TColorArrayClass.Assign(Source: TPersistent);
var
  x, y: integer;
begin
  if Source is TColorArrayClass then
  begin
    FreeMem(FColors, XSize * YSize * SizeOf(TColor));
    FXSize := TColorArrayClass(Source).XSize;
    FYSize := TColorArrayClass(Source).YSize;
    FCount := FXSize * FYSize;
    GetMem(FColors, XSize * YSize * SizeOf(TColor));
    for x := 1 to XSize do
    begin
      for y := 1 to YSize do
      begin
        Color[x,y] := TColorArrayClass(Source).Color[x,y];
      end;
    end;
  end else
    inherited Assign(Source);
end;

function TColorArrayClass.IsEqualTo(OtherColors: TColorArrayClass): boolean;
var
  x, y: integer;
begin
  Result := FALSE;
  if OtherColors = Self then
  begin
    Result := TRUE;
    exit;
  end;
  if OtherColors <> NIL then
  begin
    if (XSize = OtherColors.XSize) and (YSize = OtherColors.YSize) then
    begin
      for x := 1 to XSize do
      begin
        for y := 1 to YSize do
        begin
          if Color[x,y] <> OtherColors.Color[x,y] then
            exit;
        end;
      end;
      Result := TRUE;  { all colors matched }
    end;
  end;
end;





constructor TDFSColorButtonPalette.Create(AOwner: TComponent);
begin
  { Inherited is going to fire FormCreate which needs the colors, so create our
    stuff before calling inherited. }
  FPaletteColors := TColorArrayClass.Create(4,5);
  FCustomColors := TColorArrayClass.Create(8,2);
  FKeyboardClose := FALSE;
  FShowColorHints := TRUE;

  inherited Create(AOwner);
end;

destructor TDFSColorButtonPalette.Destroy;
begin
  FPaletteColors.Free;
  FCustomColors.Free;

  inherited Destroy;
end;

procedure TDFSColorButtonPalette.Loaded;
begin
  inherited Loaded;

  ShowHint := FShowColorHints;
end;

procedure TDFSColorButtonPalette.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);

{$IFDEF DFS_WIN32}
  Params.Style := Params.Style AND NOT WS_CAPTION;
{$ELSE}
  Params.Style := WS_POPUP or WS_DLGFRAME or DS_MODALFRAME;
{$ENDIF}
end;

procedure TDFSColorButtonPalette.GetColorHintText(AColor: TColor; X, Y: integer;
   var HintStr: string);
begin
  if assigned(FOnGetColorHintText) then
    FOnGetColorHintText(Parent, AColor, X, Y, HintStr);
end;

procedure TDFSColorButtonPalette.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  Action := caFree;
  if assigned(FPaletteClosed) then
    FPaletteClosed(Self);
end;

procedure TDFSColorButtonPalette.FormDeactivate(Sender: TObject);
begin
  Close;
end;

procedure TDFSColorButtonPalette.FormPaint(Sender: TObject);
var
  X, Y: integer;
begin
  for X := 1 to 4 do
  begin
    for Y := 1 to 5 do
    begin
      { Draw color square }
      DrawSquare(X, Y, FPaletteColors[x,y], FALSE);
    end;
  end;

  { Draw seperator line }
  with Canvas do
  begin
    Pen.Color := clBtnShadow;
    MoveTo(2, 93);
    LineTo(ClientWidth - 2, 93);
    Pen.Color := clBtnHighlight;
    MoveTo(2, 94);
    LineTo(ClientWidth - 2, 94);
  end;

  { Draw "other" color }
  DrawSquare(0, 0, FOtherColor, FALSE);

  { Draw the current selection }
  FrameCurrentSquare(GetCurrentSquare)
end;

function TDFSColorButtonPalette.GetSquareCoords(X, Y: integer): TRect;
begin
  Result := Rect(0,0,0,0);