Расширяем возможности кнопок в Delphi

unit NewButton;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs;

const
  fShift = 2; // Изменяем изображение и заголовок , когда кнопка нажата.
  fHiColor = $DDDDDD; // Цвет нажатой кнопки (светло серый)
  // Windows создаёт этот цвет путём смешивания пикселей clSilver и clWhite (50%).
  // такой цвет хорошо выделяет нажатую и отпущенную кнопки.

type
  TNewButton = class(TCustomControl)
  private
    { Private declarations }
    fMouseOver,fMouseDown : Boolean;
    fEnabled : Boolean;
    // То же, что и всех компонент
    fGlyph : TPicture;
    // То же, что и в SpeedButton
    fGlyphTop,fGlyphLeft : Integer;
    // Верх и лево Glyph на изображении кнопки
    fTextTop,fTextLeft : Integer;
    // Верх и лево текста на изображении кнопки
    fNumGlyphs : Integer;
    // То же, что и в SpeedButton
    fCaption : string;
    // Текст на кнопке
    fFaceColor : TColor;
    // Цвет изображения (да-да, вы можете задавать цвет изображения кнопки

    procedure fLoadGlyph(G : TPicture);
    procedure fSetGlyphLeft(I : Integer);
    procedure fSetGlyphTop(I : Integer);
    procedure fSetCaption(S : string);
    procedure fSetTextTop(I : Integer);
    procedure fSetTextLeft(I : Integer);
    procedure fSetFaceColor(C : TColor);
    procedure fSetNumGlyphs(I : Integer);
    procedure fSetEnabled(B : Boolean);

  protected
    { Protected declarations }
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure WndProc(var message : TMessage); override;
    // Таким способом компонент определяет - находится ли курсор мышки на нём или нет
    // Если курсор за пределами кнопки, то она всё равно продолжает принимать сообщения мышки.
    // Так же кнопка будет принимать сообщения, если на родительском окне нет фокуса.

  public
    { Public declarations }
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;

  published
    { Published declarations }
    {----- Properties -----}
    property Action;
    // Property AllowUp не поддерживается
    property Anchors;
    property BiDiMode;
    property Caption : string
    read fCaption write fSetCaption;
    property Constraints;
    property Cursor;
    // Property Down не поддерживается
    property Enabled : Boolean
    read fEnabled write fSetEnabled;
    // Property Flat не поддерживается
    property FaceColor : TColor
    read fFaceColor write fSetFaceColor;
    property Font;
    property Glyph : TPicture // Такой способ позволяет получить серую кнопку, которая сможет
    // находиться в трёх положениях.
    // После нажатия на кнопку, с помощью редактора картинок Delphi
    // можно будет создать картинки для всех положений кнопки..
    read fGlyph write fLoadGlyph;
    // Property GroupIndex не поддерживается
    property GlyphLeft : Integer
    read fGlyphLeft write fSetGlyphLeft;
    property GlyphTop : Integer
    read fGlyphTop write fSetGlyphTop;
    property Height;
    property Hint;
    // Property Layout не поддерживается
    property Left;
    // Property Margin не поддерживается
    property name;
    property NumGlyphs : Integer
    read fNumGlyphs write fSetNumGlyphs;
    property ParentBiDiMode;
    property ParentFont;
    property ParentShowHint;
    // Property PopMenu не поддерживается
    property ShowHint;
    // Property Spacing не поддерживается
    property Tag;
    property Textleft : Integer
    read fTextLeft write fSetTextLeft;
    property TextTop : Integer
    read fTextTop write fSetTextTop;

    property Top;
    // Property Transparent не поддерживается
    property Visible;
    property Width;
    {--- События ---}
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
end;

procedure register; // Hello

implementation


procedure TNewButton.fSetEnabled(B : Boolean);
begin
  if B <> fEnabled then
  begin
    fEnabled := B;
    Invalidate;
  end;
end;

procedure TNewButton.fSetNumGlyphs(I : Integer);
begin
  if I > 0 then
    if I <> fNumGlyphs then
    begin
      fNumGlyphs := I;
      Invalidate;
    end;
end;

procedure TNewButton.fSetFaceColor(C : TColor);
begin
  if C <> fFaceColor then
  begin
    fFaceColor := C;
    Invalidate;
  end;
end;

procedure TNewButton.fSetTextTop(I : Integer);
begin
  if I >= 0 then
    if I <> fTextTop then
    begin
      fTextTop := I;
      Invalidate;
    end;
end;

procedure TNewButton.fSetTextLeft(I : Integer);
begin
  if I >= 0 then
    if I <> fTextLeft then
    begin
      fTextLeft := I;
      Invalidate;
    end;
end;

procedure TNewButton.fSetCaption(S : string);
begin
  if fCaption <> S then
  begin
    fCaption := S;
    SetTextBuf(PChar(S));
    Invalidate;
  end;
end;

procedure TNewButton.fSetGlyphLeft(I : Integer);
begin
  if I <> fGlyphLeft then
    if I >= 0 then
    begin
      fGlyphLeft := I;
      Invalidate;
    end;
end;

procedure TNewButton.fSetGlyphTop(I : Integer);
begin
  if I <> fGlyphTop then
    if I >= 0 then
    begin
      fGlyphTop := I;
      Invalidate;
    end;
end;

procedure tNewButton.fLoadGlyph(G : TPicture);
var
  I : Integer;
begin
  fGlyph.Assign(G);
  if fGlyph.Height > 0 then
  begin
    I := fGlyph.Width div fGlyph.Height;
    if I <> fNumGlyphs then
      fNumGlyphs := I;
  end;
  Invalidate;
end;

procedure register; // Hello
begin
  RegisterComponents('Samples', [TNewButton]);
end;

constructor TNewButton.Create(AOwner : TComponent);
begin
  inherited Create(AOwner);
  { Инициализируем переменные }
  Height := 37;
  Width := 37;
  fMouseOver := False;
  fGlyph := TPicture.Create;
  fMouseDown := False;
  fGlyphLeft := 2;
  fGlyphTop := 2;
  fTextLeft := 2;
  fTextTop := 2;
  fFaceColor := clBtnFace;
  fNumGlyphs := 1;
  fEnabled := True;
end;

destructor TNewButton.Destroy;
begin
  if Assigned(fGlyph) then
    fGlyph.Free; // Освобождаем glyph
  inherited Destroy;
end;

procedure TNewButton.Paint;
var
  fBtnColor,fColor1,fColor2,
  fTransParentColor : TColor;
  Buffer : array[0..127] of Char;
  I,J : Integer;
  X0,X1,X2,X3,X4,Y0 : Integer;
  DestRect : TRect;
  TempGlyph : TPicture;
begin
  X0 := 0;
  X1 := fGlyph.Width div fNumGlyphs;
  X2 := X1 + X1;
  X3 := X2 + X1;
  X4 := X3 + X1;
  Y0 := fGlyph.Height;
  TempGlyph := TPicture.Create;
  TempGlyph.Bitmap.Width := X1;
  TempGlyph.Bitmap.Height := Y0;
  DestRect := Rect(0,0,X1,Y0);

  GetTextBuf(Buffer,SizeOf(Buffer)); // получаем caption
  if Buffer <> '' then
    fCaption := Buffer;

  if fEnabled = False then
    fMouseDown := False; // если недоступна, значит и не нажата

  if fMouseDown then
  begin
    fBtnColor := fHiColor; // Цвет нажатой кнопки
    fColor1 := clWhite; // Правая и нижняя окантовка кнопки, когда на неё нажали мышкой.
    fColor2 := clBlack; // Верхняя и левая окантовка кнопки, когда на неё нажали мышкой.
  end
  else
  begin
    fBtnColor := fFaceColor; // fFaceColor мы сами определяем
    fColor2 := clWhite; // Цвет левого и верхнего края кнопки, когда на неё находится курсор мышки
    fColor1 := clGray; // Цвет правого и нижнего края кнопки, когда на неё находится курсор мышки
  end;

  // Рисуем лицо кнопки :)
  Canvas.Brush.Color := fBtnColor;
  Canvas.FillRect(Rect(1,1,Width - 2,Height - 2));

  if fMouseOver then
  begin
    Canvas.MoveTo(Width,0);
    Canvas.Pen.Color := fColor2;
    Canvas.LineTo(0,0);
    Canvas.LineTo(0,Height - 1);
    Canvas.Pen.Color := fColor1;
    Canvas.LineTo(Width - 1,Height - 1);
    Canvas.LineTo(Width - 1, - 1);
  end;

  if Assigned(fGlyph) then // Bitmap загружен?
  begin
    if fEnabled then // Кнопка разрешена?
    begin
      if fMouseDown then // Мышка нажата?
      begin
        // Mouse down on the button so show Glyph 3 on the face
        if (fNumGlyphs >= 3) then
          TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
        fGlyph.Bitmap.Canvas,Rect(X2,0,X3,Y0));

        if (fNumGlyphs < 3) and (fNumGlyphs > 1)then
          TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
        fGlyph.Bitmap.Canvas,Rect(X0,0,X1,Y0));

        if (fNumGlyphs = 1) then
          TempGlyph.Assign(fGlyph);

        // Извините, лучшего способа не придумал...
        // Glyph.Bitmap.Прозрачность цвета не работает, если Вы выберете в качестве
        // прозрачного цвета clWhite...
        fTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1];
        for I := 0 to X1 - 1 do
          for J := 0 to Y0 - 1 do
            if TempGlyph.Bitmap.Canvas.Pixels[I,J] = fTransParentColor then
              TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor;
        //Рисуем саму кнопку
        Canvas.Draw(fGlyphLeft + 2,fGlyphTop + 2,TempGlyph.Graphic);
      end
      else
      begin
        if fMouseOver then
        begin
          // Курсор на кнопке, но не нажат, показываем Glyph 1 на морде кнопки
          // (если существует)
          if (fNumGlyphs > 1) then
            TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
          fGlyph.Bitmap.Canvas,Rect(0,0,X1,Y0));
          if (fNumGlyphs = 1) then
            TempGlyph.Assign(fGlyph);
        end
        else
        begin
          // Курсор за пределами кнопки, показываем Glyph 2 на морде кнопки (если есть)
          if (fNumGlyphs > 1) then
            TempGlyph.Bitmap.Canvas.CopyRect(DestRect,
          fGlyph.Bitmap.Canvas,Rect(X1,0,X2,Y0));
          if (fNumGlyphs = 1) then
            TempGlyph.Assign(fGlyph);
        end;
        // Извиняюсь, лучшего способа не нашёл...
        fTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1];
        for I := 0 to X1 - 1 do
          for J := 0 to Y0 - 1 do
            if TempGlyph.Bitmap.Canvas.Pixels[I,J] = fTransParentColor then
              TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor;
        //Рисуем bitmap на морде кнопки
        Canvas.Draw(fGlyphLeft,fGlyphTop,TempGlyph.Graphic);
      end;
    end
    else
    begin
      // Кнопка не доступна (disabled), показываем Glyph 4 на морде кнопки (если существует)
      if (fNumGlyphs = 4) then
        TempGlyph.Bitmap.Canvas.CopyRect(DestRect, fGlyph.Bitmap.Canvas,Rect(X3,0,X4,Y0))
      else
        TempGlyph.Bitmap.Canvas.CopyRect(DestRect, fGlyph.Bitmap.Canvas,Rect(0,0,X1,Y0));
      if (fNumGlyphs = 1) then
        TempGlyph.Assign(fGlyph.Graphic);

      // Извините, лучшего способа не нашлось...
      fTransParentColor := TempGlyph.Bitmap.Canvas.Pixels[0,Y0-1];
      for I := 0 to X1 - 1 do
        for J := 0 to Y0 - 1 do
          if TempGlyph.Bitmap.Canvas.Pixels[I,J] = fTransParentColor then
            TempGlyph.Bitmap.Canvas.Pixels[I,J] := fBtnColor;
      //Рисуем изображение кнопки
      Canvas.Draw(fGlyphLeft,fGlyphTop,TempGlyph.Graphic);
    end;
  end;

  // Рисуем caption
  if fCaption <> '' then
  begin
    Canvas.Pen.Color := Font.Color;
    Canvas.Font.name := Font.name;
    Canvas.Brush.Style := bsClear;
    //Canvas.Brush.Color := fBtnColor;
    Canvas.Font.Color := Font.Color;
    Canvas.Font.Size := Font.Size;
    Canvas.Font.Style := Font.Style;

    if fMouseDown then
      Canvas.TextOut(fShift + fTextLeft,fShift + fTextTop,fCaption)
    else
      Canvas.TextOut(fTextLeft,fTextTop,fCaption);
  end;

  TempGlyph.Free; // Освобождаем временный glyph
end;


// Нажата клавиша мышки на кнопке ?
procedure TNewButton.MouseDown(Button: TMouseButton;
  Shift: TShiftState;X, Y: Integer);
var
  ffMouseDown, ffMouseOver: Boolean;
begin
  ffMouseDown := True;
  ffMouseOver := True;
  if (ffMouseDown <> fMouseDown) or (ffMouseOver <> fMouseOver) then
  begin
    fMouseDown := ffMouseDown;
    fMouseOver := ffMouseOver;
    Invalidate; // не перерисовываем кнопку без необходимости.
  end;
  inherited MouseDown(Button,Shift,X,Y);;
end;

// Отпущена клавиша мышки на кнопке ?
procedure TNewButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  ffMouseDown, ffMouseOver : Boolean;
begin
  ffMouseDown := False;
  ffMouseOver := True;
  if (ffMouseDown <> fMouseDown) or (ffMouseOver <> fMouseOver) then
  begin
    fMouseDown := ffMouseDown;
    fMouseOver := ffMouseOver;
    Invalidate; // не перерисовываем кнопку без необходимости.
  end;
  inherited MouseUp(Button,Shift,X,Y);
end;

// Эта процедура перехватывает события мышки, если она даже за пределами кнопки
// Перехватываем оконные сообщения
procedure TNewButton.WndProc(var message : TMessage);
var
  P1,P2 : TPoint;
  Bo : Boolean;
begin
  if Parent <> nil then
  begin
    GetCursorPos(P1); // Получаем координаты курсона на экране
    P2 := Self.ScreenToClient(P1); // Преобразуем их в координаты относительно кнопки
    if (P2.X > 0) and (P2.X < Width) and (P2.Y > 0) and (P2.Y < Height) then
      Bo := True // Курсор мышки в области кнопки
    else
      Bo := False; // Курсор мышки за пределами кнопки

    if Bo <> fMouseOver then // не перерисовываем кнопку без необходимости.
    begin
      fMouseOver := Bo;
      Invalidate;
    end;
  end;
  inherited WndProc(message); // отправляем сообщение остальным получателям
end;

end.