mmclrbtn.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [phone]               =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/index.html               =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 26.11.98 - 00:54:58 $                                        =}
{========================================================================}
unit MMClrBtn;

{$I COMPILER.INC}

interface

uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils,
    Graphics,
    Messages,
    StdCtrls,
    Classes,
    Controls,
    Dialogs,
    MMObj,
    MMUtils,
    MMButton,
    MMString;

const
    GridRows        = 5;
    GridCols        = 4;
    GridCells       = GridRows*GridCols;
    GridCellSize    = 18;
    GridMargin      = 3;
    GridWidth       = GridCols * GridCellSize;
    PopupWidth      = GridWidth + 2*GridMargin;
    GridHeight      = GridRows * GridCellSize;
    CustomLeft      = GridWidth-GridCellSize;
    DelimTop        = GridHeight + GridMargin div 2;
    CustomTop       = DelimTop + GridMargin div 2 + GridMargin;
    PopupHeight     = CustomTop + GridCellSize + 2*GridMargin;
    
    MM_DROPCOLORDLG = MM_USER + 1;

type
    {-- TMMColorSpeedButton --------------------------------------------------}
    TMMCustomColorButton= class;

    TMMColorSpeedButton = class(TMMSpeedButton)
    private
        function        GetColorButton: TMMCustomColorButton;
    protected
        procedure       Paint; override;
        procedure       FocusLine(X1, Y1, X2, Y2: integer);
        procedure       DrawColor(Canvas: TCanvas; const Rect: TRect);
        procedure       DrawDelimiter(Canvas: TCanvas; Left, Top, Bottom: Integer);
    public
        property        ColorButton: TMMCustomColorButton read GetColorButton;
    end;

    {-- TMMColorPopup --------------------------------------------------------}
    TMMColorPopUp       = class(TMMCustomControl)
    private
        FOpened         : Boolean;
        FIndex          : Integer;
        FColors         : array[0..GridCells-1] of TColor;
        FDrawCustom     : Boolean;
        FButton         : TButton;
        FSave           : Pointer;

        function        GetButtonCaption: string;
        procedure       SetButtonCaption(Value: string);
    protected
        procedure       CreateParams(var Params: TCreateParams); override;
        procedure       WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
        procedure       CloseUp(OK: Boolean);
        procedure       DropDown;
        function        ColorButton: TMMCustomColorButton;
        function        GetColorByIndex(Index: Integer): TColor;
        function        GetIndexByColor(Color: TColor): Integer;
        procedure       Paint; override;
        procedure       DrawItem(Canvas: TCanvas; i: Integer);
        procedure       DrawCustomColor(Canvas: TCanvas);
        procedure       DrawColorCell(Canvas: TCanvas; const Rect: TRect; Color: TColor; Focused: Boolean);
        procedure       MouseMove(Shift: TShiftState; X, Y: Integer); override;
        procedure       MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
        procedure       MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
        procedure       KeyDown(var Key: Word; Shift: TShiftState); override;
        function        IndexAt(X, Y: Integer): Integer;
        procedure       SetIndex(Value: Integer);
        procedure       CustomClick(Sender: TObject);
        procedure       DrawDelimiter(Canvas: TCanvas);
        procedure       CustomExit(Sender: TObject);
    public
        constructor     Create(AOwner: TComponent); override;

        property        ButtonCaption: string read GetButtonCaption write SetButtonCaption;
    end;

    {-- TMMCustomColorButton -------------------------------------------------}
    TMMCustomColorButton = class(TMMCustomControl)
    private
        FButton        : TMMColorSpeedButton;
        FValue         : TColor;
        FFocusColor    : TColor;
        FPopup         : TMMColorPopup;
        FColorDlg      : TColorDialog;
        FButtonCaption : string;
        FShowCurrent   : Boolean;
        FOnChange      : TNotifyEvent;

        procedure SetFocusColor(Value: TColor);
        function  GetGlyph: TBitmap;
        procedure SetGlyph(Value: TBitmap);
        function  GetNumGlyphs: Integer;
        procedure SetNumGlyphs(Value: Integer);
        procedure SetValue(Value: TColor);
        function  GetCustomColors: TStrings;
        procedure SetCustomColors(Value: TStrings);
        procedure SetButtonCaption(Value: string);
    protected
        procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
        procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
        procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
        procedure CMEnabledChanged(var Message); message CM_ENABLEDCHANGED;
        procedure BtnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
        procedure KeyDown(var Key: Word; Shift: TShiftState); override;
        procedure Change; dynamic;
        procedure BtnClick(Sender: TObject);
        procedure ShowPopup;
        procedure MMDropColorDlg(var Message); message MM_DROPCOLORDLG;
        function  Popup: TMMColorPopup;
    public
        constructor Create(AOwner: TComponent); override;

    protected
        property    Width default 43;
        property    Height default 21;
        property    TabStop default True;
        property    FocusColor: TColor read FFocusColor write SetFocusColor default clBlack;
        property    Glyph: TBitmap read GetGlyph write SetGlyph;
        property    NumGlyphs: Integer read GetNumGlyphs write SetNumGlyphs default 1;
        property    Value: TColor read FValue write SetValue default clBlack;
        property    CustomColors: TStrings read GetCustomColors write SetCustomColors;
        property    ButtonCaption: string read FButtonCaption write SetButtonCaption;
        property    ShowCurrent: Boolean read FShowCurrent write FShowCurrent default False;
        property    OnChange: TNotifyEvent read FOnChange write FOnChange;
    end;

    {-- TMMColorButton -------------------------------------------------------}
    TMMColorButton = class(TMMCustomColorButton)
    published
        property    Width;
        property    Height;
        property    TabStop;
        property    TabOrder;
        property    FocusColor;
        property    Glyph;
        property    NumGlyphs;
        property    Value;
        property    CustomColors;
        property    ButtonCaption;
        property    ShowCurrent;
        property    OnChange;

        property    Enabled;
        property    Visible;
    end;

implementation

uses
    Buttons,
    ExtCtrls,
    Forms;

{$IFDEF WIN32}
    {$R MMCLRBTN.D32}
{$ELSE}
    {$R MMCLRBTN.D16}
{$ENDIF}

const
    ButtonRes = 'BM_CLRBTNDOWN';

{== TMMColorSpeedButton ==================================================}
procedure TMMColorSpeedButton.Paint;
var
    R, FR: TRect;
    ColorSize, GlyphSize: Integer;
begin
    if not Enabled and not (csDesigning in ComponentState) then
        FState := bsDisabled
    else if FState = bsDisabled then
        FState := bsUp;

    R := DrawButtonFace(Canvas, Rect(0, 0, Width, Height), 1, bsAutoDetect,
                        False, FState in [bsDown, bsExclusive], ColorButton.Focused);

    if Glyph = nil then
        GlyphSize := 0
    else
        GlyphSize := Glyph.Width + 2;

    ColorSize := R.Right - R.Left - GlyphSize - 2;

    if ColorSize < 0 then
        ColorSize := 0;

    if GlyphSize > 0 then
        DrawGlyph(Canvas,Rect(R.Left+ColorSize+2,R.Top,R.Right,R.Bottom));

    if (Enabled or (csDesigning in ComponentState)) and (ColorSize > 0) then
        DrawColor(Canvas,Rect(R.Left,R.Top,R.Left+ColorSize,R.Bottom));

    DrawDelimiter(Canvas,R.Left+ColorSize,R.Top+2,R.Bottom-2);

    if ColorButton.Focused then
    begin
        FR := Rect(R.Left,R.Top,R.Right-1,R.Bottom-1);
        InflateRect(FR,-1,-1);
        with FR do
        begin
            FocusLine(Left,Top,Right,Top);
            FocusLine(Right,Top,Right,Bottom);
            FocusLine(Left,Bottom,Right,Bottom);
            FocusLine(Left,Top,Left,Bottom);
        end;
    end;
end;

{-- TMMColorSpeedButton --------------------------------------------------}
procedure TMMColorSpeedButton.FocusLine(X1, Y1, X2, Y2: integer);
var
    i: Integer;
begin
    if (X1 = X2) then
    begin
        i := Y1;
        while i < Y2 do
        begin
            Canvas.Pixels[X1, i] := ColorButton.FFocusColor;
            Inc(i,2)
        end;
    end
    else if (Y1 = Y2) then
    begin
        i := X1;
        while i < X2 do
        begin
            Canvas.Pixels[i, Y1] := ColorButton.FFocusColor;
            Inc(i,2)
        end;
    end;
end;

{-- TMMColorSpeedButton --------------------------------------------------}
function TMMColorSpeedButton.GetColorButton: TMMCustomColorButton;
begin
    Result := Owner as TMMCustomColorButton;
end;

{-- TMMColorSpeedButton --------------------------------------------------}
procedure TMMColorSpeedButton.DrawColor(Canvas: TCanvas; const Rect: TRect);
var
    R: TRect;
begin
    with Canvas do
    begin
        R := Rect;
        InflateRect(R,-4,-2);
        Brush.Color := ColorButton.Value;
        Brush.Style := bsSolid;
        Pen.Color   := clBlack;
        Pen.Width   := 1;
        Rectangle(R.Left,R.Top,R.Right,R.Bottom);
    end;
end;

{-- TMMColorSpeedButton --------------------------------------------------}
procedure TMMColorSpeedButton.DrawDelimiter(Canvas: TCanvas; Left, Top, Bottom: Integer);
begin
    with Canvas do
    begin
        Pen.Color := clBtnShadow;
        Pen.Width := 1;
        MoveTo(Left,Top);
        LineTo(Left,Bottom);
        Pen.Color := clBtnHighlight;
        MoveTo(Left+1,Top);
        LineTo(Left+1,Bottom);
    end;
end;

{== TMMCustomButton ======================================================}
type
    TMMCustomButton = class(TButton)
    protected
        procedure   KeyDown(var Key: Word; Shift: TShiftState); override;
    end;

{-- TMMCustomButton ------------------------------------------------------}
procedure TMMCustomButton.KeyDown(var Key: Word; Shift: TShiftState);
begin
    if Key = VK_ESCAPE then
        PostMessage(Parent.Handle,WM_KEYDOWN,VK_ESCAPE,0);
end;

{== TMMColorPopup ========================================================}
constructor TMMColorPopup.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);

    Visible := False;
    Hide;
    TabStop := True;
    ClientWidth  := PopupWidth;
    ClientHeight := PopupHeight;
    FButton := TMMCustomButton.Create(Self);
    with FButton do
    begin
        Parent := Self;
        Left := GridMargin;
        Top := CustomTop;
        Width := GridWidth - GridCellSize - GridMargin;
        Height := GridCellSize;
        { TODO: Put to resource }
        Caption := '&Custom...';
        OnClick := CustomClick;
        OnExit := CustomExit;
    end;

   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMColorPopup --------------------------------------------------------}
procedure TMMColorPopup.CreateParams(var Params: TCreateParams);
begin
    inherited CreateParams(Params);
    Params.Style := WS_POPUP or WS_CLIPCHILDREN or WS_DLGFRAME;
{$IFDEF WIN32}
    Params.ExStyle := WS_EX_TOOLWINDOW;
{$ENDIF}
    Params.WindowClass.Style := Params.WindowClass.Style or CS_SAVEBITS;
end;

{-- TMMColorPopup --------------------------------------------------------}
procedure TMMColorPopup.WMKillFocus(var Message: TWMKillFocus);
var
    H: THandle;
begin
    H := Message.FocusedWnd;

    while (H <> 0) and (H <> Handle) do
        H := GetParent(H);

    if H = Handle then
        Exit;

    if FOpened then
        CloseUp(False);
end;

{-- TMMColorPopup --------------------------------------------------------}
function TMMColorPopup.ColorButton: TMMCustomColorButton;
begin
    Result := TMMCustomColorButton(Owner);
end;

{-- TMMColorPopup --------------------------------------------------------}
function TMMColorPopup.GetColorByIndex(Index: Integer): TColor;
begin
    Result := FColors[Index];
end;

{-- TMMColorPopup --------------------------------------------------------}
function TMMColorPopup.GetIndexByColor(Color: TColor): Integer;
begin
    Color := ColorToRGB(Color);
    for Result := Low(FColors) to High(FColors) do
        if ColorToRGB(FColors[Result]) = Color then
            Exit;
    Result := -1;
end;

{-- TMMColorPopup --------------------------------------------------------}
procedure TMMColorPopup.Paint;
var
    i: Integer;
    Offs: TBitmap;
begin
    Offs := TBitmap.Create;
    try
        Offs.Width  := ClientWidth;
        Offs.Height := ClientHeight;
        with Offs.Canvas do
        begin
            Brush.Color := clBtnFace;
            FillRect(ClientRect);
        end;
        for i := 0 to GridCells - 1 do
            DrawItem(Offs.Canvas,i);
        if FDrawCustom then
            DrawCustomColor(Offs.Canvas);
        DrawDelimiter(Offs.Canvas);
        Canvas.Draw(0,0,Offs);
    finally
        Offs.Free;
    end;
end;

{-- TMMColorPopup --------------------------------------------------------}
procedure TMMColorPopup.DrawCustomColor(Canvas: TCanvas);
begin
    DrawColorCell(Canvas,
                  Bounds(CustomLeft,CustomTop,GridCellSize,GridCellSize),
                  ColorButton.Value,
                  FIndex = -1);
end;

{-- TMMColorPopup --------------------------------------------------------}
procedure TMMColorPopup.DrawItem(Canvas: TCanvas; i: Integer);
var
    Row, Col: Integer;
begin
    Row := i div GridCols;
    Col := i mod GridCols;
    DrawColorCell(Canvas,
                  Bounds(Col*GridCellSize,Row*GridCellSize,GridCellSize,GridCellSize),
                  GetColorByIndex(i),FIndex=i);
end;

{-- TMMColorPopup --------------------------------------------------------}
procedure TMMColorPopup.DrawColorCell(Canvas: TCanvas; const Rect: TRect; Color: TColor; Focused: Boolean);
var
    R: TRect;
begin
    R := Rect;
    with Canvas do
    begin
        if Focused then
        begin
            Pen.Color := clBlack;
            Pen.Width := 1;