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

Материал из DRKB

Расширяем возможности кнопок в Delphi.[править | править код]

Пример показывает, как сделать кнопку с тремя состояниями. В обычном состоянии она сливается с формой. При наведении на такую кнопку курсором мышки, она становится выпуклой. Ну и, соотвественно, при нажатии, кнопка становится вогнутой.

Также можно создать до 4-х изображений для индикации состояния кнопки


  <--------- Ширина ---------> 
  +------+------+-----+------+    ^
  |Курсор|Курсор|нажа-|недос-|    | 
  |на кно|за пре| та  |тупна |  Высота 
  | пке  |делами|     |      |    | 
  +------+------+-----+------+    v


Вы так же можете присвоить кнопке текстовый заголовок. Можно расположить текст и изображение в любом месте кнопки. Для этого в пример добавлены четыре свойства:

  • TextTop и TextLeft, Для расположения текста заголовка на кнопке,
  • GlyphTop и GlyphLeft, Для расположения Glyph на кнопке.

Текст заголовка прорисовывается после изображения, потому что они используют одно пространство кнопки, и соответственно заголовок прорисуется поверх изображения. Бэкграунд текста сделан прозрачным. Соответственно мы увидим только текстовые символы поверх изображения.

Найденные баги

1) Если двигать мышку очень быстро, то кнопка может не вернуться в исходное состояние
2) Если кнопка находится в запрещённом состоянии, то при нажатии на неё, будет наблюдаться неприятное мерцание.


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; 
    // То же, что и в SpeedButton 
    FGlyph: TPicture; 
    // Верх и лево Glyph на изображении кнопки
    FGlyphTop, FGlyphLeft: Integer; 
    // Верх и лево текста на изображении кнопки 
    FTextTop, FTextLeft: Integer; 
    // То же, что и в SpeedButton 
    FNumGlyphs: Integer; 
    // Текст на кнопке 
    FCaption: String; 
    // Цвет изображения (да-да, вы можете задавать цвет изображения кнопки 
    FFaceColor: TColor; 

    procedure LoadGlyph(G: TPicture); 
    procedure SetGlyphLeft(I: Integer); 
    procedure SetGlyphTop(I: Integer); 
    procedure SetCaption(S: String); 
    procedure SetTextTop(I: Integer); 
    procedure SetTextLeft(I: Integer); 
    procedure SetFaceColor(C: TColor); 
    procedure SetNumGlyphs(I: Integer); 
    procedure SetEnabled(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 SetCaption; 
    property Constraints; 
    property Cursor; 
    // property Down не поддерживается 
    property Enabled: Boolean read FEnabled write SetEnabled; 
    // property Flat не поддерживается 
    property FaceColor: TColor read FFaceColor write SetFaceColor; 
    property Font; 
    // Такой способ позволяет получить серую кнопку, которая сможет
    //   находиться в трёх положениях. 
    // После нажатия на кнопку, с помощью редактора картинок Delphi 
    // можно будет создать картинки для всех положений кнопки.. 
    property Glyph: TPicture read FGlyph write LoadGlyph; 
    // property GroupIndex не поддерживается 
    property GlyphLeft: Integer read FGlyphLeft write SetGlyphLeft; 
    property GlyphTop: Integer read FGlyphTop write SetGlyphTop; 
    property Height; 
    property Hint; 
    // property Layout не поддерживается 
    property Left; 
    // property Margin не поддерживается 
    property Name; 
    property NumGlyphs: Integer read FNumGlyphs write SetNumGlyphs; 
    property ParentBiDiMode; 
    property ParentFont; 
    property ParentShowHint; 
    // property PopMenu не поддерживается 
    property ShowHint; 
    // property Spacing не поддерживается 
    property Tag; 
    property Textleft: Integer read FTextLeft write SetTextLeft; 
    property TextTop: Integer read FTextTop write SetTextTop; 

    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.SetEnabled(B: Boolean); 
begin 
  if B <> FEnabled then 
  begin 
    FEnabled := B; 
    Invalidate; 
  end; 
end; 
{--------------------------------------------------------------------} 
procedure TNewButton.SetNumGlyphs(I: Integer); 
begin 
  if I > 0 then 
    if I <> FNumGlyphs then 
    begin 
      FNumGlyphs := I; 
      Invalidate; 
    end; 
end; 
{--------------------------------------------------------------------} 
procedure TNewButton.SetFaceColor(C: TColor); 
begin 
  if C <> FFaceColor then 
  begin 
    FFaceColor := C; 
    Invalidate; 
  end; 
end; 
{--------------------------------------------------------------------} 
procedure TNewButton.SetTextTop(I: Integer); 
begin 
  if I >= 0 then 
    if I <> FTextTop then 
    begin 
      FTextTop := I; 
      Invalidate; 
    end; 
end; 
{--------------------------------------------------------------------} 
procedure TNewButton.SetTextLeft(I: Integer); 
begin 
  if I >= 0 then 
    if I <> FTextLeft then 
    begin 
      FTextLeft := I; 
      Invalidate; 
    end; 
end; 
{--------------------------------------------------------------------} 
procedure TNewButton.SetCaption(S: String); 
begin 
  if (FCaption <> S) then 
  begin 
    FCaption := S; 
    SetTextBuf(PChar(S)); 
    Invalidate; 
  end; 
end; 
{--------------------------------------------------------------------} 
procedure TNewButton.SetGlyphLeft(I: Integer); 
begin 
  if I <> FGlyphLeft then 
    if I >= 0 then 
    begin 
      FGlyphLeft := I; 
      Invalidate; 
    end; 
end; 
{--------------------------------------------------------------------} 
procedure TNewButton.SetGlyphTop(I: Integer); 
begin 
  if I <> FGlyphTop then 
    if I >= 0 then 
    begin 
      FGlyphTop := I; 
      Invalidate; 
    end; 
end; 
{--------------------------------------------------------------------} 
procedure TNewButton.LoadGlyph(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. 
{====================================================================}


Source: Взято из http://forum.sources.ru
ID: 01232