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

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