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



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

Пример тестировался под WinNT, SP5 и WIN95, SP1.

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

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

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;
// То же, что и всех компонент
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.


Далее: Рисование кнопок с кругленными краями »»