Спасибо большое!! 
Я тоже попробовал наследовать от TSpeedButton, при Transparent=true, получается ефект прозрачности.
Если кого-то интересует:
| Код |
unit LittleButton;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, Buttons;
Const fShift = 1;
type
TLittleButton = class(TSpeedButton)
private
{ Private declarations }
fMouseOver,fMouseDown : Boolean;
fEnabled : Boolean;
fTextTop,fTextLeft : Integer;
fCaption : String;
fOverColor : TColor; //Mouse-over color
fStartGradientColor : TColor;
fEndGradientColor : TColor;
Procedure fSetCaption(S : String);
Procedure fSetTextTop(I : Integer);
Procedure fSetTextLeft(I : Integer);
Procedure fSetEnabled(B : Boolean);
Procedure fSetOverColor(C : TColor);
Procedure fSetStartGradientColor(C : TColor);
Procedure fSetEndGradientColor(C : TColor);
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 }
Property Action;
Property Anchors;
Property BiDiMode;
Property Caption : String
read fCaption write fSetCaption;
Property Constraints;
Property Cursor;
Property Enabled : Boolean
read fEnabled write fSetEnabled;
Property EndGradientColor : TColor
read fEndGradientColor write fSetEndGradientColor;
Property Font;
Property Height;
Property Hint;
Property Left;
Property Name;
Property ParentFont;
Property ParentShowHint;
Property OverColor : TColor
read fOverColor write fSetOverColor;
Property ShowHint;
Property StartGradientColor : TColor
read fStartGradientColor write fSetStartGradientColor;
Property Tag;
Property Textleft : Integer
read fTextLeft write fSetTextLeft;
Property TextTop : Integer
read fTextTop write fSetTextTop;
Property Top;
Property Transparent;
Property Visible;
Property Width;
{--- Events ---}
Property OnClick;
Property OnDblClick;
Property OnMouseDown;
Property OnMouseMove;
Property OnMouseUp;
end;
procedure Register;
implementation
procedure TLittleButton.fSetEnabled(B : Boolean);
begin
if B<>fEnabled then
begin
fEnabled := B;
Invalidate;
end;
end;
procedure TLittleButton.fSetOverColor(C : TColor);
begin
if C<>fOverColor then
begin
fOverColor:=C;
Invalidate;
end;
end;
procedure TLittleButton.fSetStartGradientColor(C : TColor);
begin
if C<>fStartGradientColor then
begin
fStartGradientColor:=C;
Invalidate;
end;
end;
procedure TLittleButton.fSetEndGradientColor(C : TColor);
Begin
if C<>fEndGradientColor then
begin
fEndGradientColor:=C;
Invalidate;
end;
end;
procedure TLittleButton.fSetTextTop(I : Integer);
begin
if I>=0 then
if I<>fTextTop then
begin
fTextTop := I;
Invalidate;
end;
end;
procedure TLittleButton.fSetTextLeft(I : Integer);
begin
if I>=0 then
if I<>fTextLeft then
begin
fTextLeft:=I;
Invalidate;
end;
end;
procedure TLittleButton.fSetCaption(S : String);
begin
if fCaption<>S then
begin
fCaption := S;
SetTextBuf(PChar(S));
Invalidate;
end;
end;
procedure Register;
begin
RegisterComponents('Samples', [TLittleButton]);
end;
constructor TLittleButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Height := 30;
Width := 70;
fMouseOver := False;
fMouseDown := False;
fTextLeft := 2;
fTextTop := 2;
fEnabled := True;
fOverColor:=$009AD5FF;
fStartGradientColor:=$003091FE;
fEndGradientColor:=$008ED3FF;
end;
destructor TLittleButton.Destroy;
begin
inherited Destroy;
end;
procedure TLittleButton.Paint;
var Buffer : Array[0..127] of Char;
i : Integer;
Rs,Gs,Bs : Byte; //Start color
Re,Ge,Be : Byte; //End color
begin
//Colors of Start
Rs:=GetRValue(fStartGradientColor);
Gs:=GetGValue(fStartGradientColor);
Bs:=GetBValue(fStartGradientColor);
//Colors of End
Re:=GetRValue(fEndGradientColor);
Ge:=GetGValue(fEndGradientColor);
Be:=GetBValue(fEndGradientColor);
GetTextBuf(Buffer,SizeOf(Buffer));
if Buffer <> '' then fCaption := Buffer;
if fEnabled = False then fMouseDown := False;
if fMouseOver then
begin
Canvas.MoveTo(Width,0);
Canvas.Pen.Color := clBlack;
Canvas.LineTo(0,0);
Canvas.LineTo(0,Height - 1);
Canvas.LineTo(Width - 1,Height - 1);
Canvas.LineTo(Width - 1, - 1);
Canvas.Brush.Color:=fOverColor;
Canvas.FillRect(Rect(1,1,Width - 1,Height - 1));
end;
if fMouseDown and fMouseOver then
begin
for i:=1 to Height-2 do
begin
Canvas.Pen.Color:=RGB(Round(Rs-(Rs-Re)/Height*i),
Round(Gs-(Gs-Ge)/Height*i),
Round(Bs-(Bs-Be)/Height*i));
Canvas.MoveTo(1,i);
Canvas.LineTo(Width-1,i);
end;
end;
if fCaption <> '' then
begin
Canvas.Pen.Color := Font.Color;
Canvas.Font.Name := Font.Name;
Canvas.Brush.Style := bsClear;
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;
end;
procedure TLittleButton.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 TLittleButton.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 TLittleButton.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 // In region
else Bo:=False; // Out of Region
if Bo<>fMouseOver then
begin
fMouseOver:=Bo;
Invalidate;
end;
end;
inherited WndProc(Message);
end;
end.
|
Я знаю, что многие с этого форума напишут это лучше, но не судите меня - с Делфи я всерёз работаю только месяц. 
Простите, что побеспокоил.  |
