unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TMyCustomPanel =
class (TPanel)
public
procedure doPaintBackground(
const ARect: TRect);
virtual;
procedure doPaintBorder(
const ARect: TRect);
procedure Paint;
override;
end;
TMyPicturePanel =
class (TMyCustomPanel)
public
FBackgroundBitmap: TBitmap;
procedure doPaintBackground(
const ARect: TRect);
override;
end;
TForm1 =
class(TForm)
Panel1: TPanel;
Image1: TImage;
procedure FormCreate(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TMyCustomPanel.doPaintBorder(
const ARect: TRect);
begin
if not ParentBackground
then
begin
Canvas.Brush.Color := clBlue;
Canvas.FrameRect(ARect);
end;
end;
procedure TMyCustomPanel.Paint;
var Rect: TRect;
begin
Rect := GetClientRect;
doPaintBackground(Rect);
doPaintBorder(Rect);
end;
procedure TMyCustomPanel.doPaintBackground(
const ARect: TRect);
begin
if not ParentBackground
then
begin
Canvas.Brush.Color := Color;
Canvas.FillRect(ARect);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
with TMyCustomPanel.Create(self)
do
begin
Parent := self;
Top := 10;
Left := 10;
Height := 50;
Width := 50;
ParentBackground := false;
Color := clRed;
end;
with TMyPicturePanel.Create(self)
do
begin
Parent := self;
Top := 80;
Left := 10;
Height := 50;
Width := 50;
ParentBackground := false;
Color := clMaroon;
FBackgroundBitmap := TBitmap.Create();
FBackgroundBitmap.Width := 30;
FBackgroundBitmap.Height := 30;
FBackgroundBitmap.Canvas.CopyRect(Rect(0, 0, 30, 30), Image1.Canvas, Rect(0, 0, 30, 30));
end;
end;
{ TMyPicturePanel }
//procedure TMyPicturePanel.doPaintBackground(const ARect: TRect);
//begin
// inherited;
//
// if Assigned(FBackgroundBitmap) then
// begin
// BitBlt(Canvas.Handle,
// ARect.Left + 2,
// ARect.Top + 2,
// FBackgroundBitmap.Width,
// FBackgroundBitmap.Height,
// FBackgroundBitmap.Canvas.Handle,
// 0,
// 0,
// SRCCOPY
// );
// end;
//end;
{ TMyPicturePanel }
var Hmsimg32: THandle = 0;
// Funktion fürs AlphaBlending, bei Fehlschlag einfaches Copy
// Gründe fürs Fehlschlagen:
// kein Win98/2000/XP
// Kein Source 32bit
// ...
function TryAlphaBlend(
DC: HDC; p2, p3, p4, p5: Integer;
DC6: HDC; p7, p8, p9, p10: Integer; p11: TBlendFunction): Boolean;
var F:
function(
DC: HDC; p2, p3, p4, p5: Integer;
DC6: HDC; p7, p8, p9, p10: Integer;
p11: TBlendFunction): BOOL;
stdcall;
begin
Result := False;
if Hmsimg32 = 0
then
Hmsimg32 := LoadLibrary(msimg32);
if Hmsimg32 <> 0
then
begin
@F := GetProcAddress(Hmsimg32, '
AlphaBlend');
if @F <>
nil then
Result := F(
DC, p2, p3, p4, p5, DC6, p7, p8, p9, p10, p11);
end;
if not Result
then
Result := BitBlt(
DC, p2, p3, p4, p5, DC6, p7, p8, SRCCOPY);
end;
// TryAlphaBlend
procedure TMyPicturePanel.doPaintBackground(
const ARect: TRect);
var BlendFunction: TBlendFunction;
begin
inherited;
// draw background image if availabe
if Assigned(FBackgroundBitmap)
then
begin
BlendFunction.AlphaFormat := 0;
BlendFunction.AlphaFormat := 0;
BlendFunction.BlendFlags := 0;
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.SourceConstantAlpha := 100;
// 0 .. 255 (255 = volle Sichtbarkeit)
TryAlphaBlend(Canvas.Handle,
ARect.Left + 2,
ARect.Top + 2,
FBackgroundBitmap.Width,
FBackgroundBitmap.Height,
FBackgroundBitmap.Canvas.Handle,
0,
0,
FBackgroundBitmap.Width,
FBackgroundBitmap.Height,
BlendFunction
);
end;
end;
end.