Расширяем возможности кнопок в 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