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

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

Пример тестировался под winnt, sp5 и win95, sp1.

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



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

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

texttop и textleft, Для расположения текста заголовка на кнопке,
и:
glyphtop и glyphleft, Для расположения glyph на кнопке.

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

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



Совместимость: delphi 5.x (или выше)

Собственно сам исходничек:


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 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.