Расширяем возможности кнопок в Delphi
01.01.2007
Пример показывает, как сделать кнопку с тремя состояниями. В обычном состоянии она сливается с формой. При наведении на такую кнопку курсором мышки, она становится выпуклой. Ну и, соотвественно, при нажатии, кнопка становится вогнутой.
Также можно создать до 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;
// То же, что и всех компонент
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.
{====================================================================}
Взято из https://forum.sources.ru