سلام
شکل درست این کامپوننت در حالت کلی به شکل زیر است:
unit CustomControl1;
interface
uses
Winapi.Windows, System.SysUtils, System.Classes, Vcl.Forms, Vcl.Controls,
messages, graphics, Vcl.Buttons;
type
TRGBArray = array [0 .. 32767] of TRGBTriple;
PRGBArray = ^TRGBArray;
type
TFlashBut = class(TCustomControl)
Private
FBmp: TBitmap;
BmpUp, BmpOver, BmpDown: TBitmap;
Status: Byte; // 0=Up;1=Over;2=Down;
IsOnBut: Boolean;
BitmapChanged: Boolean;
procedure SetBmp(B: TBitmap);
procedure MouseLeave(var Message: TMessage); message CM_MouseLeave;
procedure MouseEnter(var Message: TMessage); message CM_MouseEnter;
procedure MouseDown(var Message: TMessage); message WM_LButtonDown;
procedure MouseUp(var Message: TMessage); message WM_LButtonUp;
procedure SplitBitmap;
function GetBmp: TBitmap;
public
constructor Create(AOwner: TComponent); Override;
procedure Paint; OverRide;
Published
property ShowHint;
property Anchors;
property Bmp: TBitmap read GetBmp write SetBmp Stored True;
property OnClick;
end;
procedure Register;
implementation
function CreateRegion(Bmp: TBitmap): THandle;
var
X, Y, StartX: Integer;
Excl: THandle;
Row: PRGBArray;
TransparentColor: TRGBTriple;
begin
Bmp.PixelFormat := pf24Bit;
Result := CreateRectRGN(0, 0, Bmp.Width, Bmp.Height);
for Y := 0 to Bmp.Height - 1 do
begin
Row := Bmp.Scanline[Y];
StartX := -1;
if Y = 0 then
TransparentColor := Row[0];
for X := 0 to Bmp.Width - 1 do
begin
if (Row[X].rgbtRed = TransparentColor.rgbtRed) and
(Row[X].rgbtGreen = TransparentColor.rgbtGreen) and
(Row[X].rgbtBlue = TransparentColor.rgbtBlue) then
begin
if StartX = -1 then
StartX := X;
end
else
begin
if StartX > -1 then
begin
Excl := CreateRectRGN(StartX, Y, X + 1, Y + 1);
try
CombineRGN(Result, Result, Excl, RGN_DIFF);
StartX := -1;
finally
DeleteObject(Excl);
end;
end;
end;
end;
if StartX > -1 then
begin
Excl := CreateRectRGN(StartX, Y, Bmp.Width, Y + 1);
try
CombineRGN(Result, Result, Excl, RGN_DIFF);
finally
DeleteObject(Excl);
end;
end;
end;
end;
constructor TFlashBut.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
SetParent(TWinControl(AOwner));
Status := 0;
Width := 40;
Height := 50;
FBmp := TBitmap.Create;
BmpUp := TBitmap.Create;
BmpOver := TBitmap.Create;
BmpDown := TBitmap.Create;
BitmapChanged := False;
SetBmp(FBmp);
end;
procedure TFlashBut.SplitBitmap;
Var
W3: Word;
H: HRGN;
begin
W3 := FBmp.Width Div 3;
Width := W3;
Height := FBmp.Height;
BmpUp.Width := W3;
BmpUp.Height := FBmp.Height;
BmpUp.PixelFormat := pf24Bit;
BmpUp.Transparent := True;
BmpUp.TransparentMode := tmAuto;
BmpOver.Assign(BmpUp);
BmpDown.Assign(BmpUp);
BmpUp.Canvas.CopyRect(BmpUp.Canvas.ClipRect, FBmp.Canvas,
Rect(0, 0, FBmp.Width Div 3, FBmp.Height));
BmpOver.Canvas.CopyRect(BmpOver.Canvas.ClipRect, FBmp.Canvas,
Rect(W3, 0, W3 * 2, FBmp.Height));
BmpDown.Canvas.CopyRect(BmpDown.Canvas.ClipRect, FBmp.Canvas,
Rect(W3 * 2, 0, W3 * 3, FBmp.Height));
H := CreateRegion(BmpUp);
SetWindowRgn(Handle, H, True);
end;
function TFlashBut.GetBmp: TBitmap;
begin
Result := FBmp;
end;
procedure TFlashBut.MouseDown(var Message: TMessage);
begin
Status := 2;
Invalidate;
Inherited;
end;
procedure TFlashBut.MouseEnter(var Message: TMessage);
begin
Status := 1;
IsOnBut := True;
Invalidate;
Inherited;
end;
procedure TFlashBut.MouseLeave(var Message: TMessage);
begin
Status := 0;
IsOnBut := False;
Invalidate;
Inherited;
end;
procedure TFlashBut.MouseUp(var Message: TMessage);
begin
If IsOnBut = True then
Status := 1
Else
Status := 0;
Invalidate;
Inherited;
end;
procedure TFlashBut.Paint;
begin
inherited;
if BitmapChanged then
begin
SplitBitmap;
BitmapChanged := False;
end;
If Status = 0 then
Canvas.Draw(0, 0, BmpUp)
Else If Status = 1 then
Canvas.Draw(0, 0, BmpOver)
Else
Canvas.Draw(0, 0, BmpDown);
end;
procedure TFlashBut.SetBmp(B: TBitmap);
begin
FBmp.Assign(B);
Invalidate;
BitmapChanged := True;
end;
procedure Register;
begin
RegisterComponents('Samples', [TFlashBut]);
end;
end.